diff --git a/and.rkt b/and.rkt new file mode 100644 index 0000000..c8c58f4 --- /dev/null +++ b/and.rkt @@ -0,0 +1,17 @@ +#lang racket + +(provide preexpanded-and) + +(require syntax/parse + (for-template racket/base)) + +(define (preexpanded-and stx) + (syntax-parse stx + [(clause) + #'clause] + [(#t . rest) + (preexpanded-and #`rest)] + [(clause . rest) + #`(if clause + #,(preexpanded-and #`rest) + #f)])) \ No newline at end of file diff --git a/syntax-case.rkt b/syntax-case.rkt new file mode 100644 index 0000000..b7a255b --- /dev/null +++ b/syntax-case.rkt @@ -0,0 +1,65 @@ +#lang racket + +(provide preexpanded-syntax-case/no-bind) + +(require (for-syntax preexpanded/and + racket/pretty + syntax/stx + syntax/parse + syntax/parse/experimental/template) + syntax/stx) + +(begin-for-syntax + (define-syntax-class (pat part) + #:attributes (test) + (pattern (~literal _) + #:with test #'#t) + (pattern () + #:with test #`(null? #,part)) + (pattern ((~literal ~literal) identifier:id) + #:when (syntax-pattern-variable? + (syntax-local-value #'identifier + (λ _ #f))) + #:with test #`(free-identifier=? #,part (quote-syntax identifier))) + (pattern ((~literal ~literal) identifier:id) + #:with test #`(free-identifier=? #,part (quote-syntax identifier))) + (pattern ((~literal ~datum) identifier:id) + #:with test #`(eq? (syntax-e #,part) 'identifier)) + (pattern k:keyword + #:with test #`(eq? (syntax-e #,part) 'k)) + (pattern ((~var sub (pat #'car-part)) . (~var rest (pat #'cdr-part))) + ;; TODO: optimize the #t case. + #:with test (preexpanded-and + #`((stx-pair? #,part) + (let-values ([(car-part) (stx-car #,part)] + [(cdr-part) (stx-cdr #,part)]) + #,(preexpanded-and + #'(sub.test rest.test)))))))) + + +(begin-for-syntax + (define-splicing-syntax-class (clause-maybe-dotted whole) + (pattern (~seq [(~var pat (pat whole)) body] + (~optional (~seq (patvar ...) + (~and ddd (~literal ...))))) + #:with test #'pat.test + ;#:with (patvar ...) #`#,(attribute pat.patvar) + #:with expanded + (if (attribute ddd) + #'(map (lambda (patvar ...) + (with-syntax ([patvar patvar] ...) + #'[test body])) + (syntax->list #'(patvar (... ...))) + ...) + #'(list #'[test body]))))) + +(define-syntax (preexpanded-syntax-case/no-bind stx) + (syntax-parse stx + [(_ name stx2 (~var clause (clause-maybe-dotted #'whole)) ...) + ((λ (x) + ;(pretty-write (syntax->datum x)) + x) + #'#`(let-values ([(whole) stx2]) + (cond #,@clause.expanded + ... + [else (raise-syntax-error 'name "Invalid syntax" whole)])))])) \ No newline at end of file diff --git a/test/test-syntax-case.rkt b/test/test-syntax-case.rkt new file mode 100644 index 0000000..8c1ee88 --- /dev/null +++ b/test/test-syntax-case.rkt @@ -0,0 +1,30 @@ +#lang racket + +(require (for-syntax preexpanded/syntax-case)) + +(define-syntax (define-a*-b stx) + (syntax-case stx () + [(_ name [foo val] ...) + #`(define-syntax (name stx2) + #,(preexpanded-syntax-case/no-bind define-a*-b stx2 + [(_ #:a (~literal foo)) #'val] + (foo val) + ... + [(_ #:b) #'2]))])) + +(define-a*-b myab [a 10] [b 20] [c 30]) +(myab #:a a) +(myab #:a b) +(myab #:a c) +;(myab #:a d) ;; Invalid syntax, as expected +;(myab #:a) ;; Invalid syntax, as expected +;(myab #:a a e) ;; Invalid syntax, as expected +(myab #:b) + +#;(preexpanded-syntax-case/no-bind mymacro #'(mymacro #:a +) + [(_ #:a (~literal +)) 1] + [(_ #:b) 2]) + +#;(preexpanded-syntax-case/no-bind mymacro #'(mymacro #:b foo) + [(_ #:a (~literal +)) 1] + [(_ #:b (~datum foo)) 2])