summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2021-06-17 21:25:31 +0200
committerAndy Wingo <wingo@pobox.com>2021-09-30 15:47:41 +0200
commitd4d4336ede625d14434cca98fdb60eb1b282d8a8 (patch)
tree60f3fc0825eead9cbc99c4d76f9f3bc9ea4bba69
parent74abae04aa68dc18676bd84c4a73324b0613475d (diff)
downloadguile-d4d4336ede625d14434cca98fdb60eb1b282d8a8.tar.gz
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!
-rw-r--r--module/ice-9/match.upstream.scm69
-rw-r--r--test-suite/tests/match.test13
-rw-r--r--test-suite/tests/match.test.upstream16
3 files changed, 81 insertions, 17 deletions
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index b1fc371b8..ff5e535db 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 6bf5bdd2c..b5dface86 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 7cbb80433..8dd73b566 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))))