Hi,
I just wanted to share some ideas that come to my mind to churn the prolog
into something more useful.
So I have been trying to rework Shins hygienic version if ice-9 match so that
it can be used as a backbone for it.
I currently have two matchers, one a fast and severely insecure that I'm
playing with. and a prompt based version that only needs a slight change to
guile sources. Now, there is many other ways to do backtracking. Two things
come to my mind. 1) based on returning a backtrack symbol or based on closures
now Shins code has a local variable that represents the next continuation and
one can easally hook in code to make that variable explicit and pass it as an
appropriate Cut closure. So in principle making the prolog engine work with
this system is a no brainer and this is where I'm heading now. But there is
some
extra work still needed to add to the matcher. E.g. we need to replace
car,cdr,pair? null? equal? with appropriate versions of it and then just go
from there. Oh well I have another extension. I want to improve the prolog
compiler to be more user friendly giving some better clues of parse errors and
the next discussion will be inline with that.
So here is the extension match, (see match-phd.scm attached to this file).
the prototype is exemplified like this
(match abstractions ((<a> a1 a2 a3) (<b>) (<c> c1 c2) ...)
phd ((*car *cdr *pair? null? equal?) ;;default
functions
(+ (*car *cdr *pair? null? equal?)) ;;+ uses
functions
(- ( car cdr pair? null? equal?))) ;;- uses ordinary
match
... usual match stuff here)
So for this example
(- <a> <a> <b> . L) will match the sequence of subpattern where reault data
will be stored in variables a1, a2, void and standard matching (-) will be
used.
Let's see an interesting code. You can execute this after putting the matcher
following this mail in ice-9 directory!
(use-modules (ice-9 match-phd))
;; Setting up the xmatch environment
;; We will work with elements of the form (List Row Column Depth) here
(define (*car x) (match x (((h . l) r c d) `(,h ,r ,c ,d))))
(define (*cdr x) (match x (((h . l) r c d) `(,l ,r ,(+ c 1) ,d))))
(define (*pair? x) (match x ((x r c d) (pair? x))))
(define (*null? x) (match x ((x r c d) (null? x))))
(define (*equal? x y) (match x ((x r c d) (equal? x y))))
;; defining xmatch utility - this just will use match but automatically fill
in
;; the header and make sure to use correct syntactic environment.
;; (make-phd-matcher name phd abs)
;; defaults is to use (*car ...), - means usual match will be done by (car
...)
;; we also tell the matcher to use a set of abstractions with appropriate
;; variables to bind to. xmatch will be anaphoric though.
(make-phd-matcher xmatch
((*car *cdr *pair? *null? *equal?)
( (+ (*car *cdr *pair? *null? *equal?))
(- ( car cdr pair? null? equal?))))
((<ws> )
(<up> )
(<down> )
(<npar?> )
(<pk> )
(<+> plus )
(<atom> atom )
(<statement> st )
(<statements*> sts )
(<statements> sts )))
;; sp? is a predicate for white characters and w? is nonwhite characters and
;; not ( or )
(define (sp? x) (member (car x) '(#\space #\tab #\newline)))
(define (w? x) (and (not (member (car x) '(#\( #\)))) (not (sp? x))))
;; first matcher just silintly parse away whities
;; matches 0 or more white characters and make sure to count lines
;; a newline counts here a a white character.
;; note how we turn the matcher into ordinary matching to fetch statistics
(define (<ws> X)
(xmatch X
( [#\newline . (- L r c d)] (<ws> `(,L ,(+ r 1) 0 ,d)) )
( [(? sp?) . L ] (<ws> L) )
( L (cons 'ws L) )))
;; <*> an abstraction that matches 0 or more (? m?) characters.
(define (<*> m?)
(define (f L X)
(xmatch X
([(? m? M) . U] (f (cons M L) U))
(U (cons (reverse L) U))))
(lambda (X) (f '() X)))
;; <*> an abstraction that matches 1 or more (? m?) characters.
(define (<+> m?)
(define (f L X)
(xmatch X
([(? m? M) . U] (f (cons (car M) L) U))
(U (cons (reverse L) U))))
(lambda (X)
(xmatch X
([(? m? M) . L] (f (cons (car M) '()) L))
(_ #f))))
;; debugger, just put it into a macther list to spy :-) on the matching
(define (<pk> X) (begin (pk (car X)) (cons 'ok X)))
;; atoms is just a sequence of 1 or more nonwhite characters.
;; note the use of the <+> abstraction!
(define (<atom> X)
(xmatch X
([(<+> w?) . L] (cons `(<atom> ,(list->string plus) ,@(cdr X)) L))
(_ #f)))
;; <down> and <up> will make sure to handle depth statistics
(define (<down> X) (match X ([L r c d] (cons #t `(,L ,r ,c ,(+ d 1))))))
(define (<up> X) (match X ([L r c 0] (error (format #f
"to many ) parenthesis
at row ~a column ~a"
r c)))
([L r c d] (cons #t `(,L ,r ,c ,(- d 1)))))
;; just a check at the end that paranthesis matches.
(define (<npar?> X) (match X
([L r c 0] (cons #t `(,L ,r ,c 0)))
([L r c d] (error (format #f "~a ) is missing at
the end!!" d)))))
;; <statement> atom or ( 0 or more statements )
(define (<statement> X)
(xmatch X
([<ws> (and H #\() <down> <statements*> <ws> #\) <up> . L]
(cons `(list ,(cadr sts) ,@(cdr H)) L))
([<ws> <atom> . L]
(cons atom L))
(_ #f)))
;; 0 or more statments inside a paranthesis e.g. need to look for ) pattern
(define (<statements*> X)
(xmatch X
([<ws> #\) . L] (cons `(stms ( )
,@(cdr X )) X))
([<statement> <statements*> . L] (cons `(stms (,st ,@(cadr sts))
,@(cddr st)) L))
(_ #f)))
;; 1 or more toplevel statements is demanded here
(define (<statements> X)
(xmatch X
([<statement> <statements> . L] (cons `(stms (,st ,@(cadr sts))
,@(cddr st)) L))
([<statement> . L] (cons `(stms (,st )
,@(cddr st)) L))
(_ #f)))
;; Oh well here comes a parser primitive, Need to initiate the Matcher.
(define (parse X) (xmatch `(,(string->list X) 0 0 0) ([<statements> <npar?>
<ws>] sts)))
;; Example (one can improve column numbers slightly here :-))
(parse "
one
big
fat ( hacker eat (cucumber with mustard
(pokes the stomache)))
oh well
")
>>>
(stms ( (<atom> "one" 1 0 0)
(<atom> "big" 2 0 0)
(<atom> "fat" 3 0 0)
(list ( (<atom> "hacker" 3 6 1)
(<atom> "eat" 3 13 1)
(list ( (<atom> "cucumber" 3 18 2)
(<atom> "with" 3 27 2)
(<atom> "mustard" 3 32 2)
(list ( (<atom> "pokes" 4 9 3)
(<atom> "the" 4 15 3)
(<atom> "stomache" 4 19 3))
4 8 2))
3 17 1))
3 4 0)
(<atom> "oh" 5 0 0)
(<atom> "well" 5 3 0))
1 0 0)
Have fun
/Stefan
;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
;; Modifying upstream version (match.upstream.scm) by Alex Shinn
;; 2010/08/29 - match abstractions and unquote added
(define-module (ice-9 match-phd)
#:use-module (srfi srfi-9)
#:export (match-define match-let* match-let match-letrec match-lambda*
match-lambda match make-phd-matcher))
(define-syntax match
(syntax-rules (abstractions phd)
((match)
(match-syntax-error "missing match expression"))
((match atom)
(match-syntax-error "no match clauses"))
((match abstractions abs phd p . l)
(match* (abs p) . l))
((match phd p abstractions abs . l)
(match* (abs p) . l))
((match abstractions abs . l)
(match* (abs ((car cdr pair? null? equal?) ())) . l))
((match phd p . l)
(match* (() p) . l))
((match x . l)
(match* (() ((car cdr pair? null? equal?) ())) x . l))))
(define-syntax match*
(syntax-rules ()
((match* abs (app ...) (pat . body) ...)
(let ((v (app ...)))
(match-next abs v ((app ...) (set! (app ...))) (pat . body) ...)))
((match* abs #(vec ...) (pat . body) ...)
(let ((v #(vec ...)))
(match-next abs v (v (set! v)) (pat . body) ...)))
((match* abs atom (pat . body) ...)
(let ((v atom))
(match-next abs v (atom (set! atom)) (pat . body) ...)))
))
(define-syntax match-next
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next abs v g+s)
(error 'match "no matching pattern"))
;; named failure continuation
((match-next abs v g+s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next abs v g+s . rest))))
;; match-one analyzes the pattern for us
(match-one abs v pat g+s (match-drop-ids (begin . body)) (match-drop-ids (failure)) ())))
;; anonymous failure continuation, give it a dummy name
((match-next abs v g+s (pat . body) . rest)
(match-next abs v g+s (pat (=> failure) . body) . rest))))
(define-syntax match-one
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-one ,(syntax->datum (syntax l))))
(syntax (match-one* . l))))))
(define-syntax abs-drop
(syntax-rules ()
((_ a (k ...) v) (k ... v))))
(define-syntax match-one*
(syntax-rules ()
;; If it's a list of two or more values, check to see if the
;; second one is an ellipse and handle accordingly, otherwise go
;; to MATCH-TWO.
((match-one* abs v (p q . r) g+s sk fk i)
(match-check-ellipse
q
(match-extract-vars abs p (abs-drop (match-gen-ellipses abs v p r g+s sk fk i)) i ())
(match-two abs v (p q . r) g+s sk fk i)))
;; Go directly to MATCH-TWO.
((match-one* . x)
(match-two . x))))
(define-syntax insert-abs
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(insert-abs ,(syntax->datum (syntax l))))
(syntax (insert-abs* . l))))))
(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 ...))))
(define-syntax match-two
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-two ,(syntax->datum (syntax l))))
(syntax (match-two* . l))))))
(define-syntax match-two*
(syntax-rules (_ ___ *** <> unquote unquote-splicing quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? equal?) pp)) v () g+s (sk ...) fk i)
(if (null? v)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))
((match-two (abs ((car cdr pair? null? equal?) pp)) v (quote p) g+s (sk ...) fk i)
(if (equal? v 'p)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))
;;Stis uquote logic
((match-two (abs ((car cdr pair? null? equal?) pp)) v (unquote p) g+s (sk ...) fk i)
(if (equal? v 'p)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))
((match-two (abs ((ccar ccdr ppair? null? equal?) rr)) v (unquote-splicing p) g+s (sk ...) fk i)
(let loop ((vv v)
(pp p))
(if (pair? pp)
(if (and (ppair? vv) (equal? (ccar vv) (car pp)))
(loop (ccdr vv) (cdr pp))
(insert-abs (abs ((ccar ccdr ppair? null? equal?) rr)) fk))
(insert-abs (abs ((ccar ccdr ppair? null? equal?) rr)) (sk ... i)))))
((match-two abs v (quasiquote p) . x)
(match-quasiquote abs v p . x))
((match-two abs v (and) g+s (sk ...) fk i) (insert-abs abs (sk ... i)))
((match-two abs v (and p q ...) g+s sk fk i)
(match-one abs v p g+s (match-one v (and q ...) g+s sk fk) fk i))
((match-two abs v (or) g+s sk fk i) (insert-abs abs fk))
((match-two abs v (or p) . x)
(match-one abs v p . x))
((match-two abs v (or p ...) g+s sk fk i)
(match-extract-vars abs (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
((match-two abs v (not p) g+s (sk ...) fk i)
(match-one abs v p g+s (match-drop-ids fk) (sk ... i) i))
((match-two abs v (get! getter) (g s) (sk ...) fk i)
(let ((getter (lambda () g))) (insert-abs abs (sk ... i))))
((match-two abs v (set! setter) (g (s ...)) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (insert-abs abs (sk ... i))))
((match-two abs v (? pred . p) g+s sk fk i)
(if (pred v) (match-one abs v (and . p) g+s sk fk i) (insert-abs abs fk)))
;; stis, added $ support!
((match-two abs v ($ n) g-s sk fk i)
(if (n v)
(insert-abs abs sk)
(insert-abs abs fk)))
((match-two abs v ($ nn p ...) g+s sk fk i)
(if (nn v)
(match-$ abs (and) 0 (p ...) v sk fk i)
(insert-abs abs fk)))
;; stis, added the possibility to use set! and get to records
((match-two abs v (= 0 m p) g+s sk fk i)
(let ((w (struct-ref v m)))
(match-one abs w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
((match-two abs v (= g s p) g+s sk fk i)
(let ((w (g v))) (match-one abs w p ((g v) (s v)) sk fk i)))
((match-two abs v (= proc p) g+s . x)
(let ((w (proc v))) '() (match-one abs w p . x)))
((match-two abs v ((<> (f ...) p) . l) g+s sk fk i)
(let ((res (f ... v)))
(if (car res)
(match-one abs (car res) g+s
(match-one (cdr res) l g+s sk fk)
fk i)
(isert-abs abs fk))))
((match-two abs v (p ___ . r) g+s sk fk i)
(match-extract-vars abs p (abs-drop (match-gen-ellipses abs v p r g+s sk fk i) i ())))
((match-two (abs phd) v p g+s sk fk i)
(match-abstract () abs phd v p g+s sk fk i))))
(define-syntax match-gen-or
(syntax-rules ()
((_ abs 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 v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
(define-syntax match-gen-or-step
(syntax-rules ()
((_ abs v () g+s sk fk . x)
;; no OR clauses, call the failure continuation
(insert-abs abs fk))
((_ abs v (p) . x)
;; last (or only) OR clause, just expand normally
(match-one abs v p . x))
((_ abs v (p . q) g+s sk fk i)
;; match one and try the remaining on failure
(match-one abs v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
))
(define-syntax match-three
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-three ,(syntax->datum (syntax l))))
(syntax (match-three* . l))))))
(define-syntax match-three*
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null?) rr)) v (p) g+s sk fk i)
(if (and (pair? v) (null? (cdr v)))
(let ((w (car v)))
(match-one (abs ((car cdr pair? null?) rr)) w p ((car v) (set-car! v)) sk fk i))
fk))
((match-two abs v (p *** q) g+s sk fk i)
(match-extract-vars abs p (match-gen-search v p q g+s sk fk i) i ()))
((match-two abs v (p *** . q) g+s sk fk i)
(match-syntax-error "invalid use of ***" (p *** . q)))
((match-two (abs ((car cdr pair? null? equal?) pp)) v (p . q) g+s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-one (abs ((car cdr pair? null? equal?) pp)) 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?) pp)) fk)))
((match-two abs v #(p ...) g+s . x)
(match-vector abs v 0 () (p ...) . x))
((match-two abs v _ g+s (sk ...) fk i) (insert-abs abs (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?) pp)) v x g+s (sk ...) fk (id ...))
(let-syntax
((new-sym?
(syntax-rules (id ...)
((new-sym? x sk2 fk2) sk2)
((new-sym? y sk2 fk2) fk2))))
(new-sym? random-sym-to-match
(let ((x v))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... (id ... x))))
(if (equal? v x)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... (id ...)))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))))
))
(define-syntax match-abstract
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-abstract ,(syntax->datum (syntax l))))
(syntax (match-abstract* . l))))))
(define-syntax match-abstract*
(lambda (x)
(syntax-case x ()
((q x () phd y p . l)
(syntax (match-phd () phd x y p . l)))
((q (x ...) ((a) us ...) phd 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
(match-one (((a) us ... x ...) phd) (cdr ret) ps g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd y ((b bs ...) . ps) g+s sk fk i))))
((q (x ...) ((a aa as ...) us ...) phd 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) (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 y ((b bs ...) . ps) g+s sk fk i))))
((q (x ...) ((a) us ...) phd 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
(match-one (((a) us ... x ...) phd) (cdr ret) ps g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd y (b . ps) g+s sk fk i))))
((q (x ...) ((a aa as ...) us ...) phd 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) (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 y (b . ps) g+s sk fk i))))
((q () abs phd y p g+s sk fk i)
(syntax (match-phd () phd abs 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 ((h a) hh ...)) abs 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 ...))) v l g+s (set-phd-sk c sk) (set-phd-fk c fk) i))
(syntax (match-phd ((h a) phd ...) (c (hh ...)) abs 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 ...))))
(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 ...))))
(define-syntax match-$
(lambda (x)
(syntax-case x ()
((q abs (a ...) m (p1 p2 ...) . v)
(with-syntax ((m+1 (datum->syntax (syntax q)
(+ (syntax->datum (syntax m)) 1))))
(syntax (match-$ abs (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
((_ abs newpat m () v kt ke i)
(syntax (match-one abs v newpat () kt ke i))))))
(define-syntax match-gen-ellipses
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-gen-ellipses ,@(syntax->datum (syntax l))))
(syntax (match-gen-ellipses* . l))))))
(define-syntax match-gen-ellipses*
(syntax-rules ()
((_ abs 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)
(insert-abs abs (sk ... i))
(insert-abs abs fk)))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
(cond
((null? ls)
(let ((id (reverse id-ls)) ...) (insert-abs abs (sk ... i))))
((pair? ls)
(let ((w (car ls)))
(match-one abs w p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk i)))
(else
(insert-abs abs fk))))))
((_ abs 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-ellipses
r
(let* ((tail-len (length 'r))
(ls v)
(len (length ls)))
(if (< len tail-len)
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond
((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one abs ls r (#f #f) (sk ...) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one abs w p ((car ls) (set-car! ls))
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
i)))
(else
fk)))))))))
(define-syntax match-drop-ids
(syntax-rules ()
((_ abs expr ids ...) expr)))
(define-syntax match-gen-search
(syntax-rules ()
((match-gen-search abs v p q g+s sk fk i ((id id-ls) ...))
(letrec ((try (lambda (w fail id-ls ...)
(match-one abs w q g+s
(match-drop-ids
(let ((id (reverse id-ls)) ...)
sk))
(match-drop-ids (next w fail id-ls ...)) i)))
(next (lambda (w fail id-ls ...)
(if (not (pair? w))
(fail)
(let ((u (car w)))
(match-one
abs u p ((car w) (set-car! w))
(match-drop-ids
;; accumulate the head variables from
;; the p pattern, and loop over the tail
(let ((id-ls (cons id id-ls)) ...)
(let lp ((ls (cdr w)))
(if (pair? ls)
(try (car ls)
(lambda () (lp (cdr ls)))
id-ls ...)
(fail)))))
(fail) i))))))
;; 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 ...))))))
(define-syntax match-quasiquote
(syntax-rules (unquote unquote-splicing quasiquote)
((_ abs v (unquote p) g+s sk fk i)
(match-one abs v p g+s sk fk i))
((_ abs v ((unquote-splicing p) . rest) g+s sk fk i)
(if (pair? v)
(match-one abs v
(p . tmp)
(match-quasiquote tmp rest g+s sk fk)
fk
i)
(insert-abs abs fk)))
((_ abs v (quasiquote p) g+s sk fk i . depth)
(match-quasiquote abs v p g+s sk fk i #f . depth))
((_ abs v (unquote p) g+s sk fk i x . depth)
(match-quasiquote abs v p g+s sk fk i . depth))
((_ abs v (unquote-splicing p) g+s sk fk i x . depth)
(match-quasiquote abs v p g+s sk fk i . depth))
((_ abs v (p . q) g+s sk fk i . depth)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-quasiquote
abs w p g+s
(match-quasiquote-step x q g+s sk fk depth)
fk i . depth))
(insert-abs abs fk)))
((_ abs v #(elt ...) g+s sk fk i . depth)
(if (vector? v)
(let ((ls (vector->list v)))
(match-quasiquote abs ls (elt ...) g+s sk fk i . depth))
(insert-abs abs fk)))
((_ abs v x g+s sk fk i . depth)
(match-one abs v 'x g+s sk fk i))))
(define-syntax match-quasiquote-step
(syntax-rules ()
((match-quasiquote-step abs x q g+s sk fk depth i)
(match-quasiquote abs x q g+s sk fk i . depth))))
(define-syntax match-extract-vars
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-extract-vars ,(syntax->datum (syntax l))))
(syntax (match-extract-vars* . l))))))
;;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!)
((match-extract-vars abs (? pred . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs ($ rec . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (= proc p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (= u m p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (quote x) (k kk ...) i v)
(k abs kk ... v))
((match-extract-vars abs (unquote x) (k kk ...) i v)
(k abs kk ... v))
((match-extract-vars abs (unquote-splicing x) (k kk ...) i v)
(k abs kk ... v))
((match-extract-vars abs (quasiquote x) k i v)
(match-extract-quasiquote-vars abs x k i v (#t)))
((match-extract-vars abs (and . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (or . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (not . p) . x)
(match-extract-vars abs p . x))
;; A non-keyword pair, expand the CAR with a continuation to
;; expand the CDR.
((match-extract-vars abs (<> f p) k i v)
(match-extract-vars abs p k i v))
((match-extract-vars (abs phd) p k i v)
(abs-extract-vars () abs phd p k i v))))
(define-syntax match-extract-vars2
(syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
((match-extract-vars abs (p q . r) k i v)
(match-check-ellipse
q
(match-extract-vars abs (p . r) k i v)
(match-extract-vars abs p (match-extract-vars-step (q . r) k i v) i ())))
((match-extract-vars abs (p . q) k i v)
(match-extract-vars abs p (match-extract-vars-step q k i v) i ()))
((match-extract-vars abs #(p ...) . x)
(match-extract-vars abs (p ...) . x))
((match-extract-vars abs _ (k kk ...) i v) (k abs kk ... v))
((match-extract-vars abs ___ (k kk ...) i v) (k abs kk ... v))
((match-extract-vars abs *** (k kk ...) i v) (k abs kk ... v))
;; This is the main part, the only place where we might add a new
;; var if it's an unbound symbol.
((match-extract-vars abs p (k kk ...) (i ...) v)
(let-syntax
((new-sym?
(syntax-rules (i ...)
((new-sym? p sk fk) sk)
((new-sym? x sk fk) fk))))
(new-sym? random-sym-to-match
(k abs kk ... ((p p-ls) . v))
(k abs kk ... v))))
))
(define-syntax abs-extract-vars
(lambda (x)
(syntax-case x ()
((q . l)
(pk `(abs-extract-vars ,@(syntax->datum (syntax l))))
(syntax (abs-extract-vars* . l))))))
(define-syntax abs-extract-vars*
(lambda (x)
(syntax-case x ()
((q abs () phd p . l) (syntax (match-extract-phd () phd abs p . l)))
((q (abs ...) ((a x . xs) us ...) phd ((b bs ...) w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(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))))
((q (abs ...) ((a) us ...) phd ((b bs ...) w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (match-extract-vars
(((a) us ... abs ...) phd) (w ...) k i v)))
(syntax (abs-extract-vars
((a) abs ...) (us ...) phd ((b bs ...) w ...) k i v)))
((q (abs ...) ((a x . xs) us ...) phd (b w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(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 w ...) k i v))))
((q (abs ...) ((a) us ...) phd (b w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (match-extract-vars
(((a) us ... abs ...) phd) (w ...) k i v))
(syntax (abs-extract-vars
((a) abs ...) (us ...) phd (b w ...) k i v))))
((q () a phd p k i v)
(syntax (match-extract-phd () phd a p k i v))))))
(define-syntax match-extract-phd
(syntax-rules ()
((_ _ phd abs . l) (match-extract-vars2 (abs phd) . l))))
(define-syntax match-extract-vars-step
(syntax-rules ()
((_ abs p k i v ((v2 v2-ls) ...))
(match-extract-vars abs p k (v2 ... . i) ((v2 v2-ls) ... . v)))
))
(define-syntax match-extract-quasiquote-vars
(syntax-rules (quasiquote unquote unquote-splicing)
((match-extract-quasiquote-vars abs (quasiquote x) k i v d)
(match-extract-quasiquote-vars abs x k i v (#t . d)))
((match-extract-quasiquote-vars abs (unquote-splicing x) k i v d)
(match-extract-quasiquote-vars abs (unquote x) k i v d))
((match-extract-quasiquote-vars abs (unquote x) k i v (#t))
(match-extract-vars abs x k i v))
((match-extract-quasiquote-vars abs (unquote x) k i v (#t . d))
(match-extract-quasiquote-vars abs x k i v d))
((match-extract-quasiquote-vars abs (x . y) k i v (#t . d))
(match-extract-quasiquote-vars abs
x
(match-extract-quasiquote-vars-step y k i v d) i ()))
((match-extract-quasiquote-vars abs #(x ...) k i v (#t . d))
(match-extract-quasiquote-vars abs (x ...) k i v d))
((match-extract-quasiquote-vars abs x (k kk ...) i v (#t . d))
(k abs kk ... v))
))
(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))
))
(define-syntax match-define
(syntax-rules (abstractions)
((q abstractions abs 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) ()) () ()))))
(define-syntax sieve
(syntax-rules ()
((_ cc (w ...) ((v q) v2 ...))
(sieve cc (v w ...) (v2 ...)))
((_ cc (w ...) (v v2 ...))
(sieve cc (v w ...) (v2 ...)))
((_ (cc ...) w ())
(cc ... w))))
(define-syntax match-define-helper0
(lambda (x)
(syntax-case x ()
((q arg code v)
(with-syntax ((vtemp (map (lambda (x)
(datum->syntax
(syntax q) (gensym "temp")))
(syntax->datum (syntax v)))))
(syntax (match-define-helper v vtemp arg code)))))))
(define-syntax match-define-helper
(syntax-rules ()
((_ (v ...) (vt ...) arg code)
(begin
(begin (define v 0)
...)
(let ((vt 0) ...)
(match code
(arg (begin (set! vt v)
...)))
(begin (set! v vt)
...))))))
;;;Reading the rest from upstream
;;Utility
(define-syntax include-from-path/filtered
(lambda (x)
(define (hit? sexp reject-list)
(if (null? reject-list)
#f
(let ((h (car reject-list))
(l (cdr reject-list)))
(if (and (pair? sexp)
(eq? 'define-syntax (car sexp))
(pair? (cdr sexp))
(eq? h (cadr sexp)))
#t
(hit? sexp l)))))
(define (read-filtered reject-list file)
(with-input-from-file (%search-load-path file)
(lambda ()
(let loop ((sexp (read)) (out '()))
(cond
((eof-object? sexp) (reverse out))
((hit? sexp reject-list)
(loop (read) out))
(else
(loop (read) (cons sexp out))))))))
(syntax-case x ()
((_ reject-list file)
(with-syntax (((exp ...) (datum->syntax
x
(read-filtered
(syntax->datum #'reject-list)
(syntax->datum #'file)))))
#'(begin exp ...))))))
(include-from-path/filtered
(match-extract-vars match-one match-gen-or match-gen-or-step
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)
"ice-9/match.upstream.scm")
(define-syntax make-phd-matcher
(syntax-rules ()
((_ name pd abs)
(define-syntax name
(lambda (x)
(syntax-case x ()
((_ . l)
(with-syntax ((aabs (datum->syntax x (syntax->datum (syntax abs)))))
(syntax (match abstractions aabs phd pd . l))))))))))
