[Guile-commits] branch main updated: Hotfix to unify (x ...) patterns in match

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch main
in repository guile.

The following commit(s) were added to refs/heads/main by this push:
     new d4d4336  Hotfix to unify (x ...) patterns in match
d4d4336 is described below

commit d4d4336ede625d14434cca98fdb60eb1b282d8a8
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.
    * test-suite/tests/match.test.upstream: Add additional tests from
    upstream.
    
    See commit 05c546e38 in Chibi Scheme.  Thanks to Alex Shinn for help
    here!
---
 module/ice-9/match.upstream.scm      | 69 +++++++++++++++++++++++++++---------
 test-suite/tests/match.test          | 13 ++++++-
 test-suite/tests/match.test.upstream | 16 +++++++++
 3 files changed, 81 insertions(+), 17 deletions(-)

diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index b1fc371..ff5e535 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -210,6 +210,12 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 2021/06/21 - fix for `(a ...)' patterns where `a' is already bound
+;;              (thanks to Andy Wingo)
+;; 2020/09/04 - [OMITTED IN GUILE] perf fix for `not`; rename `..=', `..=', 
`..1' per SRFI 204
+;; 2020/08/21 - [OMITTED IN GUILE] fixing match-letrec with unhygienic 
insertion
+;; 2020/07/06 - [OMITTED IN GUILE] adding `..=' and `..=' patterns; fixing ,@ 
patterns
+;; 2016/10/05 - [OMITTED IN GUILE] treat keywords as literals, not 
identifiers, in Chicken
 ;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe)
 ;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns
 ;; 2014/11/24 - [OMITTED IN GUILE] adding Gauche's `@' pattern for named 
record field matching
@@ -509,9 +515,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 '()) ...)
@@ -525,30 +531,47 @@
                          fk i)))
            (else
             fk)))))
-    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
-     ;; general case, trailing patterns to match, keep track of the
-     ;; remaining list length so we don't need any backtracking
+    ((_ v p r g+s sk fk (i ...) ((id id-ls) ...))
      (match-verify-no-ellipsis
       r
-      (let* ((tail-len (length 'r))
-             (ls v)
-             (len (and (list? ls) (length ls))))
-        (if (or (not len) (< len tail-len))
-            fk
-            (let loop ((ls ls) (n len) (id-ls '()) ...)
-              (cond
+      (match-bound-identifier-memv
+       p
+       (i ...)
+       ;; p is bound, match the list up to the known length, then
+       ;; match the trailing patterns
+       (let loop ((ls v) (expect p))
+         (cond
+          ((null? expect)
+           (match-one ls r (#f #f) sk fk (i ...)))
+          ((pair? ls)
+           (let ((w (car ls))
+                 (e (car expect)))
+             (if (equal? (car ls) (car expect))
+                 (match-drop-ids (loop (cdr ls) (cdr expect)))
+                 fk)))
+          (else
+           fk)))
+       ;; general case, trailing patterns to match, keep track of the
+       ;; remaining list length so we don't need any backtracking
+       (let* ((tail-len (length 'r))
+              (ls v)
+              (len (and (list? ls) (length ls))))
+         (if (or (not len) (< len tail-len))
+             fk
+             (let loop ((ls ls) (n len) (id-ls '()) ...)
+               (cond
                 ((= n tail-len)
                  (let ((id (reverse id-ls)) ...)
-                   (match-one ls r (#f #f) (sk ...) fk i)))
+                   (match-one ls r (#f #f) sk fk (i ... id ...))))
                 ((pair? ls)
                  (let ((w (car ls)))
                    (match-one w p ((car ls) (set-car! ls))
                               (match-drop-ids
                                (loop (cdr ls) (- n 1) (cons id id-ls) ...))
                               fk
-                              i)))
+                              (i ...))))
                 (else
-                 fk)))))))))
+                 fk))))))))))
 
 ;; This is just a safety check.  Although unlike syntax-rules we allow
 ;; trailing patterns after an ellipsis, we explicitly disable multiple
@@ -915,3 +938,17 @@
              ;; otherwise x is a non-symbol datum
              ((sym? y sk fk) fk))))
        (sym? abracadabra success-k failure-k)))))
+
+(define-syntax match-bound-identifier-memv
+  (syntax-rules ()
+    ((match-bound-identifier-memv a (id ...) sk fk)
+     (match-check-identifier
+      a
+      (let-syntax
+          ((memv?
+            (syntax-rules (id ...)
+              ((memv? a sk2 fk2) fk2)
+              ((memv? anything-else sk2 fk2) sk2))))
+        (memv? random-sym-to-match sk fk))
+      fk))))
+
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).
diff --git a/test-suite/tests/match.test.upstream 
b/test-suite/tests/match.test.upstream
index 7cbb804..8dd73b5 100644
--- a/test-suite/tests/match.test.upstream
+++ b/test-suite/tests/match.test.upstream
@@ -30,6 +30,22 @@
 (test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 
b)) (+ a b)) (_ #f))))
 (test "duplicate quasiquote" 'ok (match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ 
#f)))
 
+(test "duplicate before ellipsis" #f
+  (match '(1 2) ((a a ...) a) (else #f)))
+(test "duplicate ellipsis pass" '(1 2)
+  (match '((1 2) (1 2)) (((x ...) (x ...)) x) (else #f)))
+(test "duplicate ellipsis fail" #f
+  (match '((1 2) (1 2 3)) (((x ...) (x ...)) x) (else #f)))
+(test "duplicate ellipsis trailing" '(1 2)
+  (match '((1 2 3) (1 2 3)) (((x ... 3) (x ... 3)) x) (else #f)))
+(test "duplicate ellipsis trailing fail" #f
+  (match '((1 2 3) (1 1 3)) (((x ... 3) (x ... 3)) x) (else #f)))
+(test "duplicate ellipsis fail trailing" #f
+  (match '((1 2 3) (1 2 4)) (((x ... 3) (x ... 3)) x) (else #f)))
+(test "ellipsis trailing" '(3 1 2)
+  (match '(1 2 3) ((x ... y) (cons y x)) (else #f)))
+
+
 (test "ellipses" '((a b c) (1 2 3))
   (match '((a . 1) (b . 2) (c . 3))
     (((x . y) ___) (list x y))))