From 05c546e38d886a660018c6d9a3c6bec2bcf325d7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 21 Jun 2021 16:44:02 +0900 Subject: [PATCH] match fix for (a ...) patterns where a was already bound - thanks to Andy Wingo --- lib/chibi/match-test.sld | 15 +++++- lib/chibi/match/match.scm | 104 +++++++++++++++++++++++++++----------- 2 files changed, 89 insertions(+), 30 deletions(-) diff --git a/lib/chibi/match-test.sld b/lib/chibi/match-test.sld index dce4f4a1..85c6cb1d 100644 --- a/lib/chibi/match-test.sld +++ b/lib/chibi/match-test.sld @@ -50,7 +50,17 @@ (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))) + (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 "ellipses" '((a b c) (1 2 3)) (match '((a . 1) (b . 2) (c . 3)) @@ -69,6 +79,9 @@ (((? odd? n) ___) n) (((? number? n) ___) n))) + (test "ellipsis trailing" '(3 1 2) + (match '(1 2 3) ((x ... y) (cons y x)) (else #f))) + (test "failure continuation" 'ok (match '(1 2) ((a . b) (=> next) (if (even? a) 'fail (next))) diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index 599b5ad6..f9cfb201 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -242,6 +242,8 @@ ;; 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 - perf fix for `not`; rename `..=', `..=', `..1' per SRFI 204 ;; 2020/08/21 - fixing match-letrec with unhygienic insertion ;; 2020/07/06 - adding `..=' and `..=' patterns; fixing ,@ patterns @@ -565,37 +567,54 @@ (define-syntax match-gen-ellipsis (syntax-rules () ;; TODO: restore fast path when p is not already bound - ;; ((_ 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) - ;; fk)) - ;; ;; simple case, match all elements of the list - ;; (let loop ((ls v) (id-ls '()) ...) - ;; (cond - ;; ((null? ls) - ;; (let ((id (reverse id-ls)) ...) (sk ... i))) - ;; ((pair? ls) - ;; (let ((w (car ls))) - ;; (match-one w p ((car ls) (set-car! ls)) - ;; (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) - ;; fk i))) - ;; (else - ;; fk))))) + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just match the list + (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 '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + 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 (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 ... id ...)))) @@ -607,7 +626,8 @@ fk (i ...)))) (else - fk))))))))) + fk))) + ))))))) ;; Variant of the above where the rest pattern is in a quasiquote. @@ -1095,6 +1115,12 @@ (er-macro-transformer (lambda (expr rename compare) (if (eq? (cadr expr) (car (cddr expr))) + (cadr (cddr expr)) + (car (cddr (cddr expr))))))) + (define-syntax match-bound-identifier-memv + (er-macro-transformer + (lambda (expr rename compare) + (if (memv (cadr expr) (car (cddr expr))) (cadr (cddr expr)) (car (cddr (cddr expr)))))))) @@ -1115,6 +1141,12 @@ (er-macro-transformer (lambda (expr rename compare) (if (eq? (cadr expr) (car (cddr expr))) + (cadr (cddr expr)) + (car (cddr (cddr expr))))))) + (define-syntax match-bound-identifier-memv + (er-macro-transformer + (lambda (expr rename compare) + (if (memv (cadr expr) (car (cddr expr))) (cadr (cddr expr)) (car (cddr (cddr expr)))))))) @@ -1177,4 +1209,18 @@ ((eq b) sk) ((eq _) fk)))) (eq a)))))) + + ;; Variant of above for a list of ids. + (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)))) ))