artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

lib/match: ugly hygiene hack. FIXME.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-10-10 20:53:42 +02:00
parent d3fab554d5
commit c38ae1ebc5
1 changed files with 45 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

67
lib/match.scm
View file

@ -357,13 +357,18 @@
((match-two v (? pred . p) g+s sk fk i) ((match-two v (? pred . p) g+s sk fk i)
(if (pred v) (match-one v (and . p) g+s sk fk i) fk)) (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
((match-two v (= proc p) . x) ((match-two v (= proc p) . x)
(let ((w (proc v))) (match-one w p . x))) (let ((w (proc v))) (match-one w p . x))
;;(let ((W (proc v))) (match-one W p . x))
)
((match-two v (p ___ . r) g+s sk fk i) ((match-two v (p ___ . r) g+s sk fk i)
(match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
((match-two v (p) g+s sk fk i) ((match-two v (p) g+s sk fk i)
(if (and (pair? v) (null? (cdr v))) (if (and (pair? v) (null? (cdr v)))
(let ((w (car v))) (let ;;((w (car v)))
(match-one w p ((car v) (set-car! v)) sk fk i)) ((W (car v)))
;;(match-one w p ((car v) (set-car! v)) sk fk i)
(match-one W p ((car v) (set-car! v)) sk fk i)
)
fk)) fk))
((match-two v (p *** q) g+s sk fk i) ((match-two v (p *** q) g+s sk fk i)
(match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
@ -379,9 +384,12 @@
fk)) fk))
((match-two v (p . q) g+s sk fk i) ((match-two v (p . q) g+s sk fk i)
(if (pair? v) (if (pair? v)
(let ((w (car v)) (x (cdr v))) (let ;;((w (car v)) (x (cdr v)))
(match-one w p ((car v) (set-car! v)) ((W (car v)) (X (cdr v)))
(match-one x q ((cdr v) (set-cdr! v)) sk fk) (match-one ;;w p ((car v) (set-car! v))
W p ((car v) (set-car! v))
;;(match-one x q ((cdr v) (set-cdr! v)) sk fk)
(match-one X q ((cdr v) (set-cdr! v)) sk fk)
fk fk
i)) i))
fk)) fk))
@ -392,15 +400,20 @@
;; new symbol, in which case we just bind it, or if it's an ;; new symbol, in which case we just bind it, or if it's an
;; already bound symbol or some other literal, in which case we ;; already bound symbol or some other literal, in which case we
;; compare it with EQUAL?. ;; compare it with EQUAL?.
((match-two v x g+s (sk ...) fk (id ...)) (;;(match-two v x g+s (sk ...) fk (id ...))
(match-two V X g+s (sk ...) fk (id ...))
(let-syntax (let-syntax
((new-sym? ((new-sym?
(syntax-rules (id ...) (syntax-rules (id ...)
((new-sym? x sk2 fk2) sk2) ;;((new-sym? x sk2 fk2) sk2)
((new-sym? X sk2 fk2) sk2)
((new-sym? y sk2 fk2) fk2)))) ((new-sym? y sk2 fk2) fk2))))
(new-sym? random-sym-to-match (new-sym? random-sym-to-match
(let ((x v)) (sk ... (id ... x))) ;;(let ((x v)) (sk ... (id ... x)))
(if (equal? v x) (sk ... (id ...)) fk)))) (let ((X V)) (sk ... (id ... X)))
;;(if (equal? v x) (sk ... (id ...)) fk)
(if (equal? V X) (sk ... (id ...)) fk)
)))
)) ))
;; QUASIQUOTE patterns ;; QUASIQUOTE patterns
@ -425,16 +438,19 @@
(match-quasiquote v p g+s sk fk i . depth)) (match-quasiquote v p g+s sk fk i . depth))
((_ v (p . q) g+s sk fk i . depth) ((_ v (p . q) g+s sk fk i . depth)
(if (pair? v) (if (pair? v)
(let ((w (car v)) (x (cdr v))) (let ;;((w (car v)) (x (cdr v)))
((W (car v)) (X (cdr v)))
(match-quasiquote (match-quasiquote
w p g+s ;;w p g+s
(match-quasiquote-step x q g+s sk fk depth) W p g+s
;;(match-quasiquote-step x q g+s sk fk depth)
(match-quasiquote-step X q g+s sk fk depth)
fk i . depth)) fk i . depth))
fk)) fk))
((_ v #(elt ...) g+s sk fk i . depth) ((_ v #(elt ...) g+s sk fk i . depth)
(if (vector? v) (if (vector? v)
(let ((ls (vector->list v))) (let ((ls (vector->list v)))
(match-quasiquote ls (elt ...) g+s sk fk i . depth)) (match-quasiquote ls (elt ...) g+s sk fk i . depth))
fk)) fk))
((_ v x g+s sk fk i . depth) ((_ v x g+s sk fk i . depth)
(match-one v 'x g+s sk fk i)))) (match-one v 'x g+s sk fk i))))
@ -501,11 +517,16 @@
(define-syntax match-gen-ellipses (define-syntax match-gen-ellipses
(syntax-rules () (syntax-rules ()
((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) (;;(_ v p () g+s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier p (_ v P () g+s (sk ...) fk i ((id id-ls) ...))
;; simplest case equivalent to (p ...), just bind the list (match-check-identifier
(let ((p v)) ;;p
(if (list? p) P
;; simplest case equivalent to (p ...), just bind the list
(let ;;((p v))
((P v))
(if ;;(list? p)
(list? P)
(sk ... i) (sk ... i)
fk)) fk))
;; simple case, match all elements of the list ;; simple case, match all elements of the list
@ -514,8 +535,10 @@
((null? ls) ((null? ls)
(let ((id (reverse id-ls)) ...) (sk ... i))) (let ((id (reverse id-ls)) ...) (sk ... i)))
((pair? ls) ((pair? ls)
(let ((w (car ls))) (let ;;((w (car ls)))
(match-one w p ((car ls) (set-car! ls)) ((W (car ls)))
(match-one ;;w p ((car ls) (set-car! ls))
W p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk i))) fk i)))
(else (else