better match, better unify

parent 27c23d49
* Enabled unification on scheme vectors
* Added support for customized setters and getters in <match>
* Fixed Bug that prevented <match> to work correclt on cons variables
\ No newline at end of file
......@@ -106,8 +106,8 @@
(define-syntax abs-drop
(syntax-rules ()
((_ a k ) k)
((_ a (k ...) v) (k ... v))))
((_ a s k ) k)
((_ a s (k ...) v) (k ... v))))
(define-syntax match-one*
(syntax-rules ()
......@@ -135,44 +135,48 @@
(define-syntax insert-abs*
(syntax-rules (begin)
((insert-abs abs (begin . l)) (begin . l))
((insert-abs abs (x)) (x))
((insert-abs abs (n nn ...)) (n abs nn ...))))
((insert-abs abs s (begin . l)) (begin . l))
((insert-abs abs s (x)) (x))
((insert-abs abs s (n nn ...)) (n abs s nn ...))))
(define-syntax match-two
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-two ,(syntax->datum (syntax l))))
(pk `(match-two ,(syntax->datum (syntax l))))
(syntax (match-two* . l))))))
(define-syntax match-two*
(syntax-rules (_ ___ *** <> arguments cond unquote unquote-splicing
quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v ()
((match-two (abs ((car cdr pair? null? equal? id . u_) pp)) s v ()
g+s (sk ...) fk i)
(let* ((s (null? v s)))
(if s
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s
(sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s fk))))
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (quote p)
((match-two (abs ((car cdr pair? null? equal? id . u_) pp)) s v (quote p)
g+s (sk ...) fk i)
(let ((s (equal? v 'p s)))
(if s
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s
(sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s fk))))
;;Stis unquote logic
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (unquote p)
((match-two (abs ((car cdr pair? null? equal? id . u_) pp)) s v (unquote p)
g+s (sk ...) fk i)
(let ((s (equal? v p s)))
(if s
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s
(sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s fk))))
((match-two (abs ((ccar ccdr ppair? null? equal? id) rr)) s v
((match-two (abs ((ccar ccdr ppair? null? equal? id . u_) rr)) s v
((unquote-splicing p) . ps) g+s sk fk i)
(let loop ((vv (id v s))
(pp p))
......@@ -182,28 +186,29 @@
(let ((s (equal? (ccar vv s) (car pp) s)))
(if s
(loop (id (ccdr vv s) s) (cdr pp))
(insert-abs (abs ((ccar ccdr ppair? null? equal? id)
rr)) fk)))
(insert-abs (abs ((ccar ccdr ppair? null? equal? id)
rr)) fk)))
(insert-abs (abs
((ccar ccdr ppair? null? equal? id . u_)
rr)) s fk)))
(insert-abs (abs ((ccar ccdr ppair? null? equal? id . u_)
rr)) s fk)))
(match-one (abs ((ccar ccdr ppair? null? equal? id) rr))
(match-one (abs ((ccar ccdr ppair? null? equal? id . u_) rr))
s vv ps g+s sk fk i))))
((match-two abs s () (arguments) g+s (sk ...) fk i)
(insert-abs abs (sk ... i)))
(insert-abs abs s (sk ... i)))
((match-two abs s (a as ...) (arguments p ps ...) g+s sk fk i)
(let ((v a))
(match-two abs s v p g+s (match-one s (as ...) (arguments ps ...)
(match-two abs s v p g+s (match-one (as ...) (arguments ps ...)
g+s sk fk) fk i)))
((match-two abs s v (quasiquote p) . x)
(match-quasiquote abs s v p . x))
((match-two abs s v (and) g+s (sk ...) fk i) (insert-abs abs (sk ... i)))
((match-two abs s v (and) g+s (sk ...) fk i) (insert-abs abs s (sk ... i)))
((match-two abs s v (and p q ...) g+s sk fk i)
(match-one abs s v p g+s (match-one s v (and q ...) g+s sk fk) fk i))
((match-two abs s v (or) g+s sk fk i) (insert-abs abs fk))
(match-one abs s v p g+s (match-one v (and q ...) g+s sk fk) fk i))
((match-two abs s v (or) g+s sk fk i) (insert-abs abs s fk))
((match-two abs s v (or p) . x)
(match-one abs s v p . x))
((match-two abs s v (or p ...) g+s sk fk i)
......@@ -211,7 +216,7 @@
(abs-drop (match-gen-or abs s v (p ...)
g+s sk fk i)) i ()))
((match-two abs s v (cond) g+s sk fk i) (insert-abs abs fk))
((match-two abs s v (cond) g+s sk fk i) (insert-abs abs s fk))
((match-two abs s v (cond p) . x)
(match-one abs s v p . x))
((match-two abs s v (cond p ps ...) g+s sk fk i)
......@@ -220,60 +225,86 @@
((match-two abs s v (not p) g+s (sk ...) (fk fkk ...) i)
(match-one abs s v p g+s (match-drop-ids (fk abs fkk ...)) (sk ... i) i))
((match-two abs ss v (get! getter) (g s) (sk ...) fk i)
(let ((getter (lambda () g))) (insert-abs abs (sk ... i))))
((match-two abs ss v (set! setter) (g (s ...)) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (insert-abs abs (sk ... i))))
((match-two (abs ((car cdr pair? null? equal? id . u_) pp)) ss v
(get! getter) (g s) (sk ...) fk i)
(let ((getter (lambda (s) (id g s))))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s
(sk ... i))))
((match-two abs s v (set! setter) (g (se ...)) (sk ...) fk i)
(let ((setter (lambda (ss p cc x) (let ((sss (se ... ss x))) (cc sss p)))))
(insert-abs abs s (sk ... i))))
((match-two abs s v (? pred . p) g+s sk fk i)
(if (pred (id v s))
(match-one abs s v (and . p) g+s sk fk i) (insert-abs abs fk)))
(match-one abs s v (and . p) g+s sk fk i)
(insert-abs abs s fk)))
;; stis, added $ support!
((match-two abs s v ($ n) g-s sk fk i)
(if (n v)
(insert-abs abs sk)
(insert-abs abs fk)))
(insert-abs abs s sk)
(insert-abs abs s fk)))
((match-two abs s v ($ nn p ...) g+s sk fk i)
(if (nn v)
(match-$ abs (and) 0 (p ...) s v sk fk i)
(insert-abs abs fk)))
(insert-abs abs s fk)))
;; stis, added the possibility to use set! and get to records
((match-two abs s v (= 0 m p) g+s sk fk i)
;; stis, added the possibility to use set! and get to records everything is
;; done through boxing here
((match-two (abs ((car cdr pair? null? equal? id (set-car! set-cdr! sset!)
. u_)
pp)) s v (= 0 m p) g+s sk fk i)
(let ((w (struct-ref v m)))
(match-one abs s w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
((match-two abs ss v (= g s p) g+s sk fk i)
(let ((w (g v))) (match-one abs ss w p ((g v) (s v)) sk fk i)))
((match-two abs s v (= proc p) g+s . x)
(let ((w (proc v))) (match-one abs s w p () . x)))
(match-one (abs ((car cdr pair? null? equal? id
(set-car! set-cdr! sset!) . u_)
pp)) s w p (w (set! w)) sk fk i)))
((match-two (abs ((car cdr pair? null? equal? id (set-car! set-cdr! sset!)
. u_)
pp)) ss v (= g s p)
g+s sk fk i)
(let ((w (g v)))
(match-one (abs ((car cdr pair? null? equal? id
(set-car! set-cdr! sset!) . u_)
pp)) ss w p (w (s w)) sk fk i)))
((match-two
(abs ((car cdr pair? null? equal? id (set-car! set-cdr! sset!) . u_) pp))
s v (= proc p) g+s . x)
(let ((w (proc v)))
(match-one (abs ((car cdr pair? null? equal? id
(set-car! set-cdr! sset!) . u_)
pp)) s w p (w (set! w)) . x)))
((match-two abs s v ((<> f p) . l) g+s sk fk i)
(let ((res (f v)))
(if res
(match-one abs s (car res) p g+s
(match-one s (cdr res) l g+s sk fk)
(call-with-values (lambda () (f v))
(lambda (s res)
(if res
(match-one abs s (car res) p g+s
(match-one (cdr res) l g+s sk fk)
fk i)
(insert-abs abs fk))))
(insert-abs abs s fk)))))
((match-two abs s v (p ___ . r) g+s sk fk i)
(match-extract-vars abs p (abs-drop (match-gen-ellipses abs s v p r g+s sk fk i) i ())))
(match-extract-vars abs p (abs-drop
(match-gen-ellipses abs s v p r
g+s sk fk i) i ())))
((match-two (abs phd) s v p g+s sk fk i)
(match-abstract () abs phd s v p g+s sk fk i))))
;; This does not transport s correctly
(define-syntax match-gen-or
(syntax-rules ()
((_ abs s v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
(let ((sk2 (lambda (id ...) (insert-abs abs (sk ... (i ... id ...))))))
(match-gen-or-step abs s v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
(let ((sk2 (lambda (id ...) (insert-abs abs s (sk ... (i ... id ...))))))
(match-gen-or-step abs s v p g+s (match-drop-ids (sk2 id ...))
fk (i ...))))))
(define-syntax match-gen-or-step
(syntax-rules ()
((_ abs s v () g+s sk fk . x)
;; no OR clauses, call the failure continuation
(insert-abs abs fk))
(insert-abs abs s fk))
((_ abs s v (p) . x)
;; last (or only) OR clause, just expand normally
(match-one abs s v p . x))
......@@ -291,16 +322,21 @@
(define-syntax match-three*
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? id) rr)) s v (p) g+s sk fk i)
((match-two (abs ((car cdr pair? null? id (set-car! set-cdr! sset!) . u_)
rr))
s v (p) g+s sk fk i)
(let-values (((w cd s) (pair? v s)))
(if s
(let ((s (null? cd s)))
(if s
(match-one (abs ((car cdr pair? null? id) rr)) s w p
(match-one (abs ((car cdr pair? null? id (set-car! set-cdr!
sset!) . u_) rr)) s w p
((car w)
(set-car! w)) sk fk i)
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
(insert-abs (abs ((car cdr pair? null? equal? id (set-car!
set-cdr! sset!) . u_) pp)) s fk)))
(insert-abs (abs ((car cdr pair? null? equal? id (set-car! set-cdr!
sset!) . u_) pp)) s fk))))
((match-two abs s v (p *** q) g+s sk fk i)
(match-extract-vars abs p (match-gen-search s v p q g+s sk fk i) i ()))
......@@ -308,27 +344,36 @@
((match-two abs s v (p *** . q) g+s sk fk i)
(match-syntax-error "invalid use of ***" (p *** . q)))
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (p . q)
((match-two (abs ((car cdr pair? null? equal? id set-car! set-cdr! sset!)
pp)) s v (p . q)
g+s sk fk i)
(let-values (((w x s) (pair? v s)))
(if s
(match-one (abs ((car cdr pair? null? equal? id) pp)) s w p
((car ww) (set-car! ww))
(match-one s x q ((cdr ww) (set-cdr! ww)) sk fk)
(match-one (abs ((car cdr pair? null? equal? id (set-car! set-cdr!
sset!) . u_) pp))
s w p ((car v) (set-car! v))
(match-one x q ((cdr v) (set-cdr! v)) sk fk)
fk
i)
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
((match-two abs s v #(p ...) g+s . x)
(match-vector abs s v 0 () (p ...) . x))
((match-two abs s v _ g+s (sk ...) fk i) (insert-abs abs (sk ... i)))
(insert-abs (abs ((car cdr pair? null? equal? id (set-car! set-cdr!
sset!) . u_) pp)) s fk))))
((match-two (abs ((car cdr pair? null? equal? iid . u_) pp)) s v #(p ...)
g+s sk fk i)
(let ((w (pk (iid v s))))
(if (pk (vector? w))
(match-vectorie
(abs ((car cdr pair? null? equal? id . u_) pp)) s w 0
(p ...) g+s sk fk i)
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s fk))))
((match-two abs s v _ g+s (sk ...) fk i) (insert-abs abs s (sk ... i)))
;; Not a pair or vector or special literal, test to see if it's a
;; 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
;; compare it with EQUAL?.
((match-two (abs ((car cdr pair? null? equal? iid) pp)) s v x
((match-two (abs ((car cdr pair? null? equal? iid . u_) pp)) s v x
g+s (sk ...) fk (id ...))
(let-syntax
((new-sym?
......@@ -337,15 +382,43 @@
((new-sym? y sk2 fk2) fk2))))
(new-sym? random-sym-to-match
(let ((x v))
(insert-abs (abs ((car cdr pair? null? equal? iid) pp))
(sk ... (id ... x))))
(insert-abs (abs ((car cdr pair? null? equal? iid . u_) pp))
s (sk ... (id ... x))))
(let ((s (equal? v x s)))
(if s
(insert-abs (abs ((car cdr pair? null? equal? iid) pp))
(insert-abs (abs ((car cdr pair? null? equal? iid . u_)
pp)) s
(sk ... (id ...)))
(insert-abs (abs ((car cdr pair? null? equal? iid) pp))
fk))))))))
(insert-abs (abs ((car cdr pair? null? equal? iid . u_)
pp))
s fk))))))))
(define-syntax match-vectorie
(lambda (x)
(syntax-case x ()
((_ . l)
#'(match-vector* . l)))))
(define-syntax match-vector*
(syntax-rules ()
((_ (abs ((car cdr pair? null? equal? id (set-car! set-cdr! sset!) . u_)
pp))
s w n (p ps ...) g+s sk fk i)
(let ((nnew (+ n 1))
(wnew (vector-ref w n)))
(match-one (abs ((car cdr pair? null? equal? id
(set-car! set-cdr! sset!) . u_)
pp))
s wnew p (wnew (sset! wnew))
(match-vectorie w nnew
(ps ...) g+s sk fk)
fk i)))
((_ (abs ((car cdr pair? null? equal? id . u_) pp)) s w n () s+g (sk ...)
. _)
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s
(sk ... i)))))
;;warn agains miss spelled abstractions
(define (check-sym x)
......@@ -359,7 +432,7 @@
(if (null? (cdr l))
(if (eq? (car l) #\>)
(warn (format #f
"<> like variable that is not an abstraction e.g. ~a"
"<> like variable that is not an abstraction e.g. ~a"
x)))
(loop (cdr l)))))))))))
(if (symbol? x)
......@@ -389,18 +462,22 @@
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret ((a bs ...) y)))
(if ret
(match-one (((a) us ... x ...) phd) s (cdr ret) ps g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd s y ((b bs ...) . ps) g+s sk fk i))))
(match-one (((a) us ... x ...) phd) s (cdr ret) ps
g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) s fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd s y
((b bs ...) . ps) g+s sk fk i))))
((q (x ...) ((a aa as ...) us ...) phd s y ((b bs ...) . ps) g+s sk fk i)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret ((a bs ...) y)))
(if ret
(let ((aa (car ret)))
(match-one (((a as ...) us ... x ...) phd) s (cdr ret) ps g+s sk fk (aa . i)))
(insert-abs (((a as ...) us ... x ...) phd) fk))))
(syntax (match-abstract ((a aa as ...) x ...) (us ...) phd s y ((b bs ...) . ps) g+s sk fk i))))
(match-one (((a as ...) us ... x ...) phd) s
(cdr ret) ps g+s sk fk (aa . i)))
(insert-abs (((a as ...) us ... x ...) phd) s fk))))
(syntax (match-abstract ((a aa as ...) x ...) (us ...) phd s y
((b bs ...) . ps) g+s sk fk i))))
......@@ -408,52 +485,63 @@
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret (a y)))
(if ret
(match-one (((a) us ... x ...) phd) s (cdr ret) ps g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd s y (b . ps) g+s sk fk i))))
(match-one (((a) us ... x ...) phd) s (cdr ret) ps
g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) s fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd s y (b . ps)
g+s sk fk i))))
((q (x ...) ((a aa as ...) us ...) phd s y (b . ps) g+s sk fk i)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret (a y)))
(if ret
(let ((aa (car ret)))
(match-one (((a as ...) us ... x ...) phd) s (cdr ret) ps g+s sk fk (aa . i)))
(insert-abs (((a as ...) us ... x ...) phd) fk))))
(syntax (match-abstract ((a aa as ...) x ...) (us ...) phd s y (b . ps) g+s sk fk i))))
(match-one (((a as ...) us ... x ...) phd) s
(cdr ret) ps g+s sk fk (aa . i)))
(insert-abs (((a as ...) us ... x ...) phd) s fk))))
(syntax (match-abstract ((a aa as ...) x ...) (us ...) phd s y
(b . ps) g+s sk fk i))))
((q () abs phd s y p g+s sk fk i)
(syntax (match-phd () phd abs s y p g+s sk fk i))))))
(define-syntax match-phd
(lambda (x)
(syntax-case x ()
((_ phd (c ( )) abs . l) (syntax (match-three (abs (c phd)) . l)))
((_ phd (c ( )) abs . l)
(syntax (match-three (abs (c phd)) . l)))
((_ (phd ...) (c ((h a) hh ...)) abs s v (h2 h3 x) g+s sk fk i)
(if (eq? (syntax->datum (syntax h)) (syntax->datum (syntax h2)))
(if (eq? (syntax->datum (syntax h)) (syntax->datum (syntax h3)))
(if (eq? (syntax->datum (syntax h))
(syntax->datum (syntax h3)))
(syntax (match-one (abs (a ((h a) hh ... phd ...))) s v x g+s
(set-phd-sk c sk) (set-phd-fk c fk) i))
(syntax (match-one (abs (a ((h a) hh ... phd ...))) s v (h3 x) g+s
(syntax (match-one (abs (a ((h a) hh ... phd ...))) s v
(h3 x) g+s
(set-phd-sk c sk) (set-phd-fk c fk) i)))
(syntax (match-phd ((h a) phd ...) (c (hh ...)) abs s v (h2 h3 x) g+s sk fk i))))
(syntax (match-phd ((h a) phd ...) (c (hh ...)) abs s v (h2 h3 x)
g+s sk fk i))))
((_ (phd ...) (c ((h a) hh ...)) abs s v (h2 . l) g+s sk fk i)
(if (eq? (syntax->datum (syntax h)) (syntax->datum (syntax h2)))
(syntax (match-one (abs (a ((h a) hh ... phd ...))) s v l g+s (set-phd-sk c sk) (set-phd-fk c fk) i))
(syntax (match-phd ((h a) phd ...) (c (hh ...)) abs s v (h2 . l) g+s sk fk i))))
(syntax (match-one (abs (a ((h a) hh ... phd ...))) s v l g+s
(set-phd-sk c sk) (set-phd-fk c fk) i))
(syntax (match-phd ((h a) phd ...) (c (hh ...)) abs s v (h2 . l)
g+s sk fk i))))
((_ () phd abs . l)
(syntax (match-three (abs phd) . l))))))
(define-syntax set-phd-fk
(syntax-rules (begin)
((_ abs cc (begin . l)) (begin . l))
((_ abs cc (fk)) (fk))
((_ (abs (c pp)) cc (fk fkk ...)) (fk (abs (cc pp)) fkk ...))))
((_ abs s cc (begin . l)) (begin . l))
((_ abs s cc (fk)) (fk))
((_ (abs (c pp)) s cc (fk fkk ...)) (fk (abs (cc pp)) s fkk ...))))
(define-syntax set-phd-sk
(syntax-rules (begin)
((_ abs cc (begin . l) i ...) (begin . l))
((_ abs cc (fk) i ...) (fk))
((_ (abs (c pp)) cc (fk fkk ...) i ...) (fk (abs (cc pp)) fkk ... i ...))))
((_ abs s cc (begin . l) i ...) (begin . l))
((_ abs s cc (fk) i ...) (fk))
((_ (abs (c pp)) s cc (fk fkk ...) i ...) (fk (abs (cc pp)) s
fkk ... i ...))))
(define-syntax match-$
(lambda (x)
......@@ -473,7 +561,8 @@
;(pk `(match-gen-ellipses ,@(syntax->datum (syntax l))))
(syntax (match-gen-ellipses* . l))))))
;; list? is not correctly transported hear, need a new format of abs
;; to support ellipses
(define-syntax match-gen-ellipses*
(syntax-rules ()
((_ abs s v p () g+s (sk ...) fk i ((id id-ls) ...))
......@@ -481,20 +570,20 @@
;; simplest case equivalent to (p ...), just bind the list
(let ((p v))
(if (list? p)
(insert-abs abs (sk ... i))
(insert-abs abs fk)))
(insert-abs abs s (sk ... i))
(insert-abs abs s fk)))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
(let loop ((ss s) (ls v) (id-ls '()) ...)
(cond
((null? ls)
(let ((id (reverse id-ls)) ...) (insert-abs abs (sk ... i))))
(let ((id (reverse id-ls)) ...) (insert-abs abs ss (sk ... i))))
((pair? ls)
(let ((w (car ls)))
(match-one abs s w p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
(match-one abs ss w p ((car ls) (set-car! ls))
(match-drop-ids (loop ss (cdr ls) (cons id id-ls) ...))
fk i)))
(else
(insert-abs abs fk))))))
(insert-abs abs s fk))))))
((_ abs s v p r g+s (sk ...) fk i ((id id-ls) ...))
;; general case, trailing patterns to match, keep track of the
......@@ -522,10 +611,11 @@
fk)))))))))
(define-syntax match-drop-ids
(syntax-rules ()
((_ expr ) expr)
((_ abs expr ids ...) expr)))
((_ expr ) expr)
((_ abs s expr ids ...) expr)))
(define-syntax match-gen-search
(syntax-rules ()
......@@ -556,7 +646,7 @@
;; the initial id-ls binding here is a dummy to get the right
;; number of '()s
(let ((id-ls '()) ...)
(try v (lambda () (insert-abs abs fk)) id-ls ...))))))
(try v (lambda () (insert-abs abs s fk)) id-ls ...))))))
(define-syntax match-quasiquote
(syntax-rules (unquote unquote-splicing quasiquote)
......@@ -569,7 +659,7 @@
(match-quasiquote s tmp rest g+s sk fk)
fk
i)
(insert-abs abs fk)))
(insert-abs abs s fk)))
((_ abs s v (quasiquote p) g+s sk fk i . depth)
(match-quasiquote abs s v p g+s sk fk i #f . depth))
((_ abs s v (unquote p) g+s sk fk i x . depth)
......@@ -583,12 +673,12 @@
abs s w p g+s
(match-quasiquote-step s x q g+s sk fk depth)
fk i . depth))
(insert-abs abs fk)))
(insert-abs abs s fk)))
((_ abs s v #(elt ...) g+s sk fk i . depth)
(if (vector? v)
(let ((ls (vector->list v)))
(match-quasiquote abs s ls (elt ...) g+s sk fk i . depth))
(insert-abs abs fk)))
(insert-abs abs s fk)))
((_ abs s v x g+s sk fk i . depth)
(match-one abs s v 'x g+s sk fk i))))
......@@ -607,7 +697,8 @@
;;We must be able to extract vars in the new constructs!!
(define-syntax match-extract-vars*
(syntax-rules (_ ___ *** ? $ <> = quote quasiquote unquote unquote-splicing and or not get! set!)
(syntax-rules (_ ___ *** ? $ <> = quote quasiquote unquote unquote-splicing
and or not get! set!)
((match-extract-vars abs (? pred . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs ($ rec . p) . x)
......@@ -680,7 +771,8 @@
(syntax (match-extract-vars
(((a . xs) us ... abs ...) phd) (w ...) k i ((x x-ls) . v)))
(syntax (abs-extract-vars
((a x . xs) abs ...) (us ...) phd ((b bs ...) w ...) k i v))))
((a x . xs) abs ...) (us ...) phd ((b bs ...) w ...)
k i v))))
((q (abs ...) ((a) us ...) phd ((b bs ...) w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
......@@ -738,16 +830,19 @@
(define-syntax match-extract-quasiquote-vars-step
(syntax-rules ()
((_ abs x k i v d ((v2 v2-ls) ...))
(match-extract-quasiquote-vars abs x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
(match-extract-quasiquote-vars abs x k (v2 ... . i) ((v2 v2-ls) ... . v)
d))
))
(define-syntax match-define
(syntax-rules (abstractions)
((q abstractions abs arg code)
(match-extract-vars abs arg (sieve (match-define-helper0 arg code) ()) () ()))
(match-extract-vars abs arg
(sieve (match-define-helper0 arg code) ()) () ()))
((q arg code)
(match-extract-vars () arg (sieve (match-define-helper0 arg code) ()) () ()))))
(match-extract-vars () arg
(sieve (match-define-helper0 arg code) ()) () ()))))
(define-syntax sieve
(syntax-rules ()
......@@ -824,7 +919,8 @@
match-two match match-next match-gen-ellipses
match-drop-ids match-gen-search match-quasiquote
match-quasiquote-step match-extract-vars-step
match-extract-quasiquote-vars match-extract-quasiquote-vars-step)
match-extract-quasiquote-vars
match-extract-quasiquote-vars-step)
"ice-9/match.upstream.scm")
......
......@@ -15,10 +15,11 @@
<and-i> and-interleave interleave tr S P CC CUT
<set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip>
<with-generators> <next-generator-value>
<cons> <values> <windlevel>
<cons> <values> <windlevel> _
<//> <update> <update-val> <fluid-let-syntax>
<let-with-guard> <let-with-lr-guard> let-with-guard let-with-lr-guard
<car> <cdr> <logical++> <logical-->)
<car> <cdr> <logical++> <logical-->
<f-vector> <vector>)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
......@@ -27,13 +28,18 @@
(define-syntax P (lambda (x) (error "P should be bound by fluid-let")))
(define-syntax CC (lambda (x) (error "CC should be bound by fluid-let")))
(define-syntax CUT (lambda (x) (error "CUT should be bound by fluid-let")))
(define-syntax _
(lambda (x)
(syntax-case x ()
((_ . _) (error "_ in guile-log is not a function"))
(_ #'(gp-var! S)))))
(define-syntax-rule (<scm> x) (gp->scm x S))
(define-syntax-rule (<cons> x y) (gp-cons! x y S))
(define-syntax-rule (<car> x) (gp-car (gp-lookup x S) S))
(define-syntax-rule (<cdr> x) (gp-cdr (gp-lookup x S) S))
(define-syntax-rule (<lookup> x) (gp-lookup x S))
(define-syntax let-values*
(syntax-rules ()
......@@ -588,8 +594,8 @@
(define-syntax <define>
(syntax-rules ()
((_ (name a ...) code ...)
(define (name <S> <Cut> <CC> a ...)
((_ (name . a) code ...)
(define (name <S> <Cut> <CC> . a)
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...))))))
......@@ -710,15 +716,6 @@
((_ w () code ...)
(parse<> w (<and> code ...)))))
(define-syntax letify
(lambda (x)
(syntax-case x ()
((_ w ((m f) pat val) code ...)
#`(let<>0 w (m #,(tr-pat #'pat) (f val)) code ...))
((_ w (m pat val) code ...)