mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-19 05:39:17 +02:00
261 lines
11 KiB
Scheme
261 lines
11 KiB
Scheme
(import
|
|
(scheme base)
|
|
(scheme write)
|
|
)
|
|
(define-syntax match-check-ellipsis
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(if (compare '... (cadr expr))
|
|
(car (cddr expr))
|
|
(cadr (cddr expr))))))
|
|
(define-syntax match-check-identifier
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(if (symbol? (cadr expr)) ;; TODO: good enough?
|
|
(car (cddr expr))
|
|
(cadr (cddr expr))))))
|
|
(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 ellipsis and handle accordingly, otherwise go
|
|
;; to MATCH-TWO.
|
|
((match-one v (p q . r) g+s sk fk i)
|
|
(match-check-ellipsis
|
|
q
|
|
(match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ())
|
|
(match-two v (p q . r) g+s sk fk i)))
|
|
;; Go directly to MATCH-TWO.
|
|
((match-one . x)
|
|
(match-two . x))))
|
|
(define-syntax match-two
|
|
(syntax-rules (_ ___ ..1 *** quote quasiquote ? $ struct @ object = and or not set! get!)
|
|
((match-two v () g+s (sk ...) fk i)
|
|
(if (null? v) (sk ... i) fk))
|
|
((match-two v (quote p) g+s (sk ...) fk i)
|
|
(if (equal? v 'p) (sk ... i) fk))
|
|
((match-two v (quasiquote p) . x)
|
|
(match-quasiquote v p . x))
|
|
((match-two v (and) g+s (sk ...) fk i) (sk ... i))
|
|
((match-two v (and p q ...) g+s sk fk i)
|
|
(match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
|
|
((match-two v (or) g+s sk fk i) fk)
|
|
((match-two v (or p) . x)
|
|
(match-one v p . x))
|
|
((match-two v (or p ...) g+s sk fk i)
|
|
(match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
|
|
((match-two v (not p) g+s (sk ...) fk i)
|
|
(match-one v p g+s (match-drop-ids fk) (sk ... i) i))
|
|
((match-two v (get! getter) (g s) (sk ...) fk i)
|
|
(let ((getter (lambda () g))) (sk ... i)))
|
|
((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
|
|
(let ((setter (lambda (x) (s ... x)))) (sk ... 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))
|
|
((match-two v (= proc p) . x)
|
|
(let ((w (proc v))) (match-one w p . x)))
|
|
((match-two v (p ___ . r) g+s sk fk i)
|
|
(match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ()))
|
|
((match-two v (p) g+s sk fk i)
|
|
(if (and (pair? v) (null? (cdr v)))
|
|
(let ((w (car v)))
|
|
(match-one w p ((car v) (set-car! v)) sk fk i))
|
|
fk))
|
|
((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-two v (p *** . q) g+s sk fk i)
|
|
(match-syntax-error "invalid use of ***" (p *** . q)))
|
|
((match-two v (p ..1) g+s sk fk i)
|
|
(if (pair? v)
|
|
(match-one v (p ___) g+s sk fk i)
|
|
fk))
|
|
((match-two v ($ rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-refs v rec 0 (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (struct rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-refs v rec 0 (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (@ rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-named-refs v rec (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (object rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-named-refs v rec (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (p . q) g+s sk fk i)
|
|
(if (pair? v)
|
|
(let ((w (car v)) (x (cdr v)))
|
|
(match-one w p ((car v) (set-car! v))
|
|
(match-one x q ((cdr v) (set-cdr! v)) sk fk)
|
|
fk
|
|
i))
|
|
fk))
|
|
((match-two v #(p ...) g+s . x)
|
|
(match-vector v 0 () (p ...) . x))
|
|
((match-two v _ g+s (sk ...) fk i) (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 v x g+s (sk ...) fk (id ...))
|
|
;; This extra match-check-identifier is optional in general, but
|
|
;; can serve as a fast path, and is needed to distinguish
|
|
;; keywords in Chicken.
|
|
(match-check-identifier
|
|
x
|
|
(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)) (sk ... (id ... x)))
|
|
(if (equal? v x) (sk ... (id ...)) fk)))
|
|
(if (equal? v x) (sk ... (id ...)) fk)))
|
|
))
|
|
#;(define-syntax match-two
|
|
(syntax-rules (_ ___ ..1 *** quote quasiquote ? $ struct @ object = my-and or not set! get!)
|
|
((match-two v () g+s (sk ...) fk i)
|
|
(if (null? v) (sk ... i) fk))
|
|
((match-two v (quote p) g+s (sk ...) fk i)
|
|
(if (equal? v 'p) (sk ... i) fk))
|
|
((match-two v (quasiquote p) . x)
|
|
(match-quasiquote v p . x))
|
|
((match-two v (my-and) g+s (sk ...) fk i) (sk ... i))
|
|
((match-two v (my-and p q ...) g+s sk fk i)
|
|
(match-one v p g+s (match-one v (my-and q ...) g+s sk fk) fk i))
|
|
((match-two v (or) g+s sk fk i) fk)
|
|
((match-two v (or p) . x)
|
|
(match-one v p . x))
|
|
((match-two v (or p ...) g+s sk fk i)
|
|
(match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
|
|
((match-two v (not p) g+s (sk ...) fk i)
|
|
(match-one v p g+s (match-drop-ids fk) (sk ... i) i))
|
|
((match-two v (get! getter) (g s) (sk ...) fk i)
|
|
(let ((getter (lambda () g))) (sk ... i)))
|
|
((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
|
|
(let ((setter (lambda (x) (s ... x)))) (sk ... i)))
|
|
((match-two v (? pred . p) g+s sk fk i)
|
|
(if (pred v) (match-one v (my-and . p) g+s sk fk i) fk))
|
|
((match-two v (= proc p) . x)
|
|
(let ((w (proc v))) (match-one w p . x)))
|
|
((match-two v (p ___ . r) g+s sk fk i)
|
|
(match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ()))
|
|
((match-two v (p) g+s sk fk i)
|
|
(if (and (pair? v) (null? (cdr v)))
|
|
(let ((w (car v)))
|
|
(match-one w p ((car v) (set-car! v)) sk fk i))
|
|
fk))
|
|
((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-two v (p *** . q) g+s sk fk i)
|
|
(match-syntax-error "invalid use of ***" (p *** . q)))
|
|
((match-two v (p ..1) g+s sk fk i)
|
|
(if (pair? v)
|
|
(match-one v (p ___) g+s sk fk i)
|
|
fk))
|
|
((match-two v ($ rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-refs v rec 0 (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (struct rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-refs v rec 0 (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (@ rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-named-refs v rec (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (object rec p ...) g+s sk fk i)
|
|
(if (is-a? v rec)
|
|
(match-record-named-refs v rec (p ...) g+s sk fk i)
|
|
fk))
|
|
((match-two v (p . q) g+s sk fk i)
|
|
(if (pair? v)
|
|
(let ((w (car v)) (x (cdr v)))
|
|
(match-one w p ((car v) (set-car! v))
|
|
(match-one x q ((cdr v) (set-cdr! v)) sk fk)
|
|
fk
|
|
i))
|
|
fk))
|
|
((match-two v #(p ...) g+s . x)
|
|
(match-vector v 0 () (p ...) . x))
|
|
((match-two v _ g+s (sk ...) fk i) (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 v x g+s (sk ...) fk (id ...))
|
|
;; This extra match-check-identifier is optional in general, but
|
|
;; can serve as a fast path, and is needed to distinguish
|
|
;; keywords in Chicken.
|
|
(match-check-identifier
|
|
x
|
|
(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)) (sk ... (id ... x)))
|
|
(if (equal? v x) (sk ... (id ...)) fk)))
|
|
(if (equal? v x) (sk ... (id ...)) fk)))
|
|
))
|
|
;; Takes two values and just expands into the first.
|
|
(define-syntax match-drop-ids
|
|
(syntax-rules ()
|
|
((_ expr ids ...) expr)))
|
|
|
|
(define-syntax match-gen-or-step
|
|
(syntax-rules ()
|
|
((_ v () g+s sk fk . x)
|
|
;; no OR clauses, call the failure continuation
|
|
fk)
|
|
((_ v (p) . x)
|
|
;; last (or only) OR clause, just expand normally
|
|
(match-one v p . x))
|
|
((_ v (p . q) g+s sk fk i)
|
|
;; match one and try the remaining on failure
|
|
(let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
|
|
(match-one v p g+s sk (fk2) i)))
|
|
))
|
|
|
|
(display
|
|
(let ((v 1))
|
|
(let ((failure (lambda () (match-next v (1 (set! 1)) (else #f)))))
|
|
(let ((sk2 (lambda (x) (begin (x)))))
|
|
(match-gen-or-step v (2) (1 (set! 1)) (match-drop-ids (sk2 x)) (failure) ()))))
|
|
;; Works fine with my-and, but change back to and (and above in match-two) and it is broken
|
|
;(match-two 1 (my-and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ())
|
|
;; With my-and the initial expansions are:
|
|
;/* (expand (match-two 1 (my-and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()))*/
|
|
;/* (expand (match-one$2095 1 x (1 (set! 1)) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin)) (begin) ()))*/
|
|
;/* (expand (match-two$2096 1 x (1 (set! 1)) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin)) (begin) ()))*/
|
|
;/* (expand (match-check-identifier$2105 x (let-syntax ((new-sym?$2100 (syntax-rules$2104 () ((new-sym?$2100 x sk2$2102 fk2$2101) sk2$2102) ((new-sym?$2100 y$2103 sk2$2102 fk2$2101) fk2$2101)))) (new-sym?$2100 random-sym-to-match$2099 (let$2098 ((x 1)) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin) (x))) (if (equal? 1 x) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()) (begin)))) (if (equal? 1 x) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()) (begin))))*/
|
|
|
|
;; Alternatively, with and the initial expansions are:
|
|
; (match-two 1 (and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ())
|
|
;/* (expand (match-two 1 (and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()))*/
|
|
;/* (expand (if (pair? 1) (let$2108 ((w$2107 (car 1)) (x$2105 (cdr 1))) (match-one$2106 w$2107 and ((car 1) (set-car! 1)) (match-one$2106 x$2105 (x) ((cdr 1) (set-cdr! 1)) (match-drop-ids (begin x)) (begin)) (begin) ())) (begin)))*/
|
|
;/* (expand (pair? 1))*/
|
|
;/* (expand 1)*/
|
|
;/* (expand pair?)*/
|
|
|
|
;;
|
|
;; All of this seems like it may be a problem with ER macro (compare?)
|
|
;; Consider this comparison of and:
|
|
;; (Cyc-er-compare? and and$2094)
|
|
;; (find-original-sym and #f)
|
|
;; (find-original-sym and$2094 #f)
|
|
;; (compare and and$2094 and and$2094 #f)
|
|
;;
|
|
;; vs the comparison of my-and (which immediately kicks us into the proper macro expansion):
|
|
;;
|
|
;; (Cyc-er-compare? my-and my-and$2094)
|
|
;; (find-original-sym my-and #f)
|
|
;; (find-original-sym my-and$2094 my-and)
|
|
;; (find-original-sym my-and #f)
|
|
;; (compare my-and my-and$2094 my-and my-and #t)
|
|
)
|