Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

fixing match-letrec with unhygienic insertion (issue #574)

Browse source
This commit is contained in:
Alex Shinn 2020-08-21 10:18:16 +09:00
parent 0f6e0f56e0
commit 006f22ccd7
2 changed files with 127 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/chibi/match-test.sld
View file

@ -231,7 +231,7 @@
sum sum
(loop rest sum))))) (loop rest sum)))))
'(test "match-letrec" '(2 1 1 2) (test "match-letrec" '(2 1 1 2)
(match-letrec (((x y) (list 1 (lambda () (list a x)))) (match-letrec (((x y) (list 1 (lambda () (list a x))))
((a b) (list 2 (lambda () (list x a))))) ((a b) (list 2 (lambda () (list x a)))))
(append (y) (b)))) (append (y) (b))))

152
lib/chibi/match/match.scm
View file

@ -92,9 +92,16 @@
;;> \example{(match (list 1 2) ((a b c ..1) c))} ;;> \example{(match (list 1 2) ((a b c ..1) c))}
;;> \example{(match (list 1 2 3) ((a b c ..1) c))} ;;> \example{(match (list 1 2 3) ((a b c ..1) c))}
;;> The \scheme{..=} syntax is like \scheme{...} except that it takes ;;> The \scheme{..*} syntax is like \scheme{...} except that it takes
;;> a tailing integer \scheme{<n>} and requires the pattern to match ;;> two trailing integers \scheme{<n>} and \scheme{<m>}, and requires
;;> exactly \scheme{<n>} times. ;;> the pattern to match from \scheme{<n>} times.
;;> \example{(match (list 1 2 3) ((a b ..* 2 4) b))}
;;> \example{(match (list 1 2 3 4 5 6) ((a b ..* 2 4) b))}
;;> \example{(match (list 1 2 3 4) ((a b ..* 2 4 c) c))}
;;> The \scheme{(<expr> ..= <n>)} syntax is a shorthand for
;;> \scheme{(<expr> ..* <n> <n>)}.
;;> \example{(match (list 1 2) ((a b ..= 2) b))} ;;> \example{(match (list 1 2) ((a b ..= 2) b))}
;;> \example{(match (list 1 2 3) ((a b ..= 2) b))} ;;> \example{(match (list 1 2 3) ((a b ..= 2) b))}
@ -235,6 +242,7 @@
;; performance can be found at ;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm ;; http://synthcode.com/scheme/match-cond-expand.scm
;; ;;
;; 2020/08/21 - fixing match-letrec with unhygienic insertion
;; 2020/07/06 - adding `..=' and `..*' patterns; fixing ,@ patterns ;; 2020/07/06 - adding `..=' and `..*' patterns; fixing ,@ patterns
;; 2016/10/05 - treat keywords as literals, not identifiers, in Chicken ;; 2016/10/05 - treat keywords as literals, not identifiers, in Chicken
;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe) ;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe)
@ -939,34 +947,24 @@
(define-syntax match-let (define-syntax match-let
(syntax-rules () (syntax-rules ()
((_ ((var value) ...) . body) ((_ ((var value) ...) . body)
(match-let/helper let () () ((var value) ...) . body)) (match-let/aux () () ((var value) ...) . body))
((_ loop ((var init) ...) . body) ((_ loop ((var init) ...) . body)
(match-named-let loop () ((var init) ...) . body)))) (match-named-let loop () ((var init) ...) . body))))
;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec} (define-syntax match-let/aux
;;> matches and binds the variables with all match variables in scope.
(define-syntax match-letrec
(syntax-rules () (syntax-rules ()
((_ ((var value) ...) . body) ((_ ((var expr) ...) () () . body)
(match-let/helper letrec () () ((var value) ...) . body))))
(define-syntax match-let/helper
(syntax-rules ()
((_ let ((var expr) ...) () () . body)
(let ((var expr) ...) . body)) (let ((var expr) ...) . body))
((_ let ((var expr) ...) ((pat tmp) ...) () . body) ((_ ((var expr) ...) ((pat tmp) ...) () . body)
(let ((var expr) ...) (let ((var expr) ...)
(match-let* ((pat tmp) ...) (match-let* ((pat tmp) ...)
. body))) . body)))
((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) ((_ (v ...) (p ...) (((a . b) expr) . rest) . body)
(match-let/helper (match-let/aux (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) ((_ (v ...) (p ...) ((#(a ...) expr) . rest) . body)
((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) (match-let/aux (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
(match-let/helper ((_ (v ...) (p ...) ((a expr) . rest) . body)
let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) (match-let/aux (v ... (a expr)) (p ...) rest . body))))
((_ let (v ...) (p ...) ((a expr) . rest) . body)
(match-let/helper let (v ... (a expr)) (p ...) rest . body))))
(define-syntax match-named-let (define-syntax match-named-let
(syntax-rules () (syntax-rules ()
@ -990,6 +988,85 @@
((_ ((pat expr) . rest) . body) ((_ ((pat expr) . rest) . body)
(match expr (pat (match-let* rest . body)))))) (match expr (pat (match-let* rest . body))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Challenge stage - unhygienic insertion.
;;
;; It's possible to implement match-letrec without unhygienic
;; insertion by building the let+set! logic directly into the match
;; code above (passing a parameter to distinguish let vs letrec).
;; However, it makes the code much more complicated, so we religate
;; the complexity here.
;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec}
;;> matches and binds the variables with all match variables in scope.
(define-syntax match-letrec
(syntax-rules ()
((_ ((pat val) ...) . body)
(match-letrec-one (pat ...) (((pat val) ...) . body) ()))))
;; 1: extract all ids in all patterns
(define-syntax match-letrec-one
(syntax-rules ()
((_ (pat . rest) expr ((id tmp) ...))
(match-extract-vars
pat (match-letrec-one rest expr) (id ...) ((id tmp) ...)))
((_ () expr ((id tmp) ...))
(match-letrec-two expr () ((id tmp) ...)))))
;; 2: rewrite ids
(define-syntax match-letrec-two
(syntax-rules ()
((_ (() . body) ((var2 val2) ...) ((id tmp) ...))
;; We know the ids, their tmp names, and the renamed patterns
;; with the tmp names - expand to the classic letrec pattern of
;; let+set!. That is, we bind the original identifiers written
;; in the source with let, run match on their renamed versions,
;; then set! the originals to the matched values.
(let ((id (if #f #f)) ...)
(match-let ((var2 val2) ...)
(set! id tmp) ...
. body)))
((_ (((var val) . rest) . body) ((var2 val2) ...) ids)
(match-rewrite
var
ids
(match-letrec-two-step (rest . body) ((var2 val2) ...) ids val)))))
(define-syntax match-letrec-two-step
(syntax-rules ()
((_ next (rewrites ...) ids val var)
(match-letrec-two next (rewrites ... (var val)) ids))))
;; This is where the work is done. To rewrite all occurrences of any
;; id with its tmp, we need to walk the expression, using CPS to
;; restore the original structure. We also need to be careful to pass
;; the tmp directly to the macro doing the insertion so that it
;; doesn't get renamed. This trick was originally found by Al*
;; Petrofsky in a message titled "How to write seemingly unhygienic
;; macros using syntax-rules" sent to comp.lang.scheme in Nov 2001.
(define-syntax match-rewrite
(syntax-rules ()
((match-rewrite (p . q) ids k)
(match-rewrite p ids (match-rewrite2 q ids (match-cons k))))
((match-rewrite () ids (k ...))
(k ... ()))
((match-rewrite p () (k ...))
(k ... p))
((match-rewrite p ((id tmp) . rest) (k ...))
(match-identifier=? p id (k ... tmp) (match-rewrite p rest (k ...))))
))
(define-syntax match-rewrite2
(syntax-rules ()
((match-rewrite2 q ids (k ...) p)
(match-rewrite q ids (k ... p)))))
(define-syntax match-cons
(syntax-rules ()
((match-cons (k ...) p q)
(k ... (p . q)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Otherwise COND-EXPANDed bits. ;; Otherwise COND-EXPANDed bits.
@ -1007,7 +1084,13 @@
(lambda (expr rename compare) (lambda (expr rename compare)
(if (identifier? (cadr expr)) (if (identifier? (cadr expr))
(car (cddr expr)) (car (cddr expr))
(cadr (cddr expr))))))) (cadr (cddr expr))))))
(define-syntax match-identifier=?
(er-macro-transformer
(lambda (expr rename compare)
(if (compare (cadr expr) (car (cddr expr)))
(cadr (cddr expr))
(car (cddr (cddr expr))))))))
(chicken (chicken
(define-syntax match-check-ellipsis (define-syntax match-check-ellipsis
@ -1021,7 +1104,13 @@
(lambda (expr rename compare) (lambda (expr rename compare)
(if (and (symbol? (cadr expr)) (not (keyword? (cadr expr)))) (if (and (symbol? (cadr expr)) (not (keyword? (cadr expr))))
(car (cddr expr)) (car (cddr expr))
(cadr (cddr expr))))))) (cadr (cddr expr))))))
(define-syntax match-identifier=?
(er-macro-transformer
(lambda (expr rename compare)
(if (compare (cadr expr) (car (cddr expr)))
(cadr (cddr expr))
(car (cddr (cddr expr))))))))
(else (else
;; Portable versions ;; Portable versions
@ -1070,4 +1159,15 @@
((sym? x sk fk) sk) ((sym? x sk fk) sk)
;; otherwise x is a non-symbol datum ;; otherwise x is a non-symbol datum
((sym? y sk fk) fk)))) ((sym? y sk fk) fk))))
(sym? abracadabra success-k failure-k))))))) (sym? abracadabra success-k failure-k)))))
;; This check is inlined in some cases above, but included here for
;; the convenience of match-rewrite.
(define-syntax match-identifier=?
(syntax-rules ()
((match-identifier=? a b sk fk)
(let-syntax ((eq (syntax-rules (b)
((eq b) sk)
((eq _) fk))))
(eq a)))))
))