Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #lang racket
- (require (for-syntax syntax/stx))
- ;;; A note for R[56]RS portability:
- ;; The macro and the example code is written in Racket,
- ;;+which is known to not adhere to either R5RS and R6RS.
- ;; It *is* portable, but some function are named
- ;;+differently from R6RS, most notably ``syntax->datum''
- ;;+(syntax-object->datum, in R6RS) and ``datum->syntax''.
- ;;
- ;; Also, the form (define-syntax (id stx) ...) is not standard,
- ;;+but widely accepted. For maximum standard-compliance, it should be
- ;;+(define-syntax id (lambda (stx) ...)).
- ;; The same applies to (λ ...) -> (lambda ...).
- ;;
- ;; (raise-syntax-error 'symbol "string" #'stx) should be the same of
- ;;+(raise (make-syntax-violation 'symbol #'stx)), but I'm not sure.
- ;;
- ;; (stx-null? x) is defined as:
- ;;
- ;; (define (stx-null? p)
- ;; (or (null? p)
- ;; (and (syntax? p)
- ;; (null? (syntax->datum p)))))
- ;;
- ;; As for R5RS, the syntax-case's syntax used by SRFI 72 and SRFI 93 is
- ;;+different from R6RS and Racket's, as SRFI 72 doesn't require the
- ;;+#'/#` reader macros/extensions, and both just override
- ;;+(unquote ...) and (unquote-splicing ...), instead of providing
- ;;+(unquote-syntax ...)/#, and (unquote-syntax-splicing ...)/#,@.
- ;; It could be ported, but you'd lose the ability to expand , and ,@
- ;;+as expected in a macro.
- (define-syntax (define-macro stx)
- (define (parse-kw stx)
- (syntax-case stx (keyword: capture:)
- ((keyword: (l ...) r ...)
- (cons (cons 'keyword #'(l ...)) (parse-kw #'(r ...))))
- ((capture: (v ...) r ...)
- (cons (cons 'capture #'(v ...)) (parse-kw #'(r ...))))
- ((keyword: l r ...)
- (cons (cons 'capture #'(l)) (parse-kw #'(r ...))))
- ((capture: v r ...)
- (cons (cons 'capture #'(v)) (parse-kw #'(r ...))))
- ((r ...)
- (cons (cons 'body #'(r ...)) '()))))
- (define (parse-kws m stx)
- (syntax-case stx (capture: nil)
- (((nil capture: (l ...) b ...) r ...)
- (if (stx-null? #'(r ...)) (cons #'(nil capture: (l ...) b ...) '())
- (raise-syntax-error 'define-macro "bad syntax (nil case must be last)" #'(nil capture: (l ...) b ...))))
- (((nil capture: l b ...) r ...)
- (if (stx-null? #'(r ...)) (cons #'(nil capture: (l) b ...) '())
- (raise-syntax-error 'define-macro "bad syntax (nil case must be last)" #'(nil capture: l b ...))))
- (((nil b ...) r ...)
- (if (stx-null? #'(r ...)) (cons #'(nil capture: () b ...) '())
- (raise-syntax-error 'define-macro "bad syntax (nil case must be last)" #'(nil b ...))))
- (((a capture: (l ...) b ...) r ...)
- (cons #'(a capture: (l ...) b ...) (parse-kws m #'(r ...))))
- (((a capture: l b ...) r ...)
- (cons #'(a capture: (l) b ...) (parse-kws m #'(r ...))))
- (((a b ...) r ...)
- (cons #'(a capture: () b ...) (parse-kws m #'(r ...))))
- (() (cons #`(nil capture: () (raise-syntax-error '#,m "bad syntax" '(#,m))) '()))))
- (syntax-case stx (macro-case keyword: capture: nil)
- ((define-macro m (a ...) keyword: (l ...) capture: (v ...) b ...)
- #`(define-syntax (m stx)
- (syntax-case stx (l ...)
- ((m a ...)
- #,(if (stx-null? #'(v ...)) #'(begin #`b ...)
- #'(with-syntax ((v (datum->syntax stx 'v)) ...)
- #`b ...))))))
- ((define-macro m keyword: (l ...) capture: (g ...) (macro-case ((a ...) capture: (c ...) r ...) ... (nil capture: (nc ...) nr ...)))
- #`(define-syntax (m stx)
- (syntax-case stx (l ...)
- ((m)
- (with-syntax ((g (datum->syntax stx 'g)) ...)
- (with-syntax ((nc (datum->syntax stx 'nc)) ...)
- #`nr ...)))
- ((m a ...)
- (with-syntax ((g (datum->syntax stx 'g)) ...)
- (with-syntax ((c (datum->syntax stx 'c)) ...)
- #`r ...))) ...)))
- ((define-macro m keyword: (l ...) capture (g ...) (macro-case (a r ...) ...))
- #`(define-macro m
- keyword: (l ...)
- capture: (g ...)
- (macro-case
- #,@(parse-kws #'m #'((a r ...) ...)))))
- ((define-macro (m a ...) r ...)
- #'(define-macro m (a ...) r ...))
- ((define-macro m (macro-case r ...))
- #'(define-macro m
- keyword: ()
- capture: ()
- (macro-case r ...)))
- ((define-macro m (a ...) r ...)
- (let* ((kw (parse-kw #'(r ...)))
- (key (assoc 'keyword kw))
- (cap (assoc 'capture kw))
- (body (assoc 'body kw)))
- #`(define-macro m (a ...)
- keyword: #,(if key (cdr key) '())
- capture: #,(if cap (cdr cap) '())
- #,@(if body (cdr body) (raise-syntax-error 'define-macro "bad syntax (empty body)" #'m)))))
- ((define-macro m r ...)
- (let* ((kw (parse-kw #'(r ...)))
- (key (assoc 'keyword kw))
- (cap (assoc 'capture kw))
- (body (assoc 'body kw)))
- #`(define-macro m
- keyword: #,(if key (cdr key) '())
- capture: #,(if cap (cdr cap) '())
- #,@(if body (cdr body) (raise-syntax-error 'define-macro "bad syntax (empty body)" #'m)))))))
- ;; Example code.
- (define-macro (aif p t f)
- ; could be declared also as:
- ; (define-macro aif (p t f) ...)
- capture: it ; the symbol it is unhygienic.
- ; want to capture more symbols?
- ; use `capture: (sym ...)'
- ; in fact, that gets translated to capture: (it)
- (let ((it p))
- (if it t f)))
- (aif (+ 2 2) it 5) ; 4
- (define-macro or
- (macro-case
- ; can accept more patterns, too!
- ((#t t ...) #t)
- ((#f t ...) (or t ...))
- ((t) t)
- ((t r ...) (let ((x t)) (if x x (or r ...))))
- (nil #f))) ; this matches (or)
- (or #t 3) ; (#t t ...) => #t
- (or) ; nil case => #f
- (define-macro aif2
- capture: it ; `it' will be captured for each pattern in macro-case
- (macro-case
- ((p) (if p #t #f)) ; if you don't use a captured symbol,
- ; the macro will remain completely hygienic.
- ((p t f) (let ((it p)) ; it used, unhygienic.
- (if it t f)))
- ((p t)
- capture: result
- ; you can declare per-pattern captures
- (let ((result p))
- (if result t #f)))
- ((r p t f)
- ; the classic hygienic aif, you name `it'.
- (let ((r p))
- (if r t f)))
- (nil ; the nil case must be specified as last
- #t)))
- (define it 3)
- (aif2 result (/ 4 2) (+ result it) #f) ; 5
- (aif2 (+ it 3) it #f) ; 6
- (aif2 3 it) ; => 3 ((aif2 p t) captures result, it remains unchanged.)
- (define-macro assert1 (p => e)
- keyword: => ; same as capture, but you can't have
- ; per-pattern literal keywords.
- ; more kws with keyword: (kw ...)
- (let ((r p))
- (unless (equal? r e)
- (error 'assert "assertion failed: ~a returned ~a instead of ~a" 'p r e))))
- (define-macro assert
- keyword: (=> !)
- ; works with the `macro-case' definition too.
- (macro-case
- ((p => e)
- (assert p => e ! "~a returned ~a instead of ~a" test result expected))
- ((p => e ! msg fmt ...)
- capture: (test expected result)
- (let ((test 'p)
- (expected e)
- (result p))
- (unless (equal? result expected)
- (error 'assert (string-append "assertion failed: " msg) fmt ...))))
- (nil (begin))))
- ;(assert1 (+ 2 2) => 5) ; uncomment to assert wheter 2+2 is 5 or not
- ;(assert (+ 2 2) => 5 ! "~a is not ~a!" test expected) ; => assert: assertion failed: (+ 2 2) is not 5!
- ;;; Evaluate expressions at expansion-time
- ;; define-macro's body is really wrapped in
- ;;+a (quasiquote-syntax ...), you can just
- ;;+unquote an expression and it will be evaluated.
- (define-macro compile-time-plus (x y)
- (+ 2 ; the macro will calculate (+ x y) at compile time, then add 2 to it at runtime.
- #,(+ (syntax->datum #'x) ; remember that the macro always receives syntax objects
- (syntax->datum #'y))))
- (compile-time-plus 3 4) ; => (+ 2 7) => 9
- ;;; Bonus code:
- ;; (constant? stx)
- ;; Returns #t if stx is a constant expression that is `eval-syntax'-able at phase 1.
- (define-for-syntax (constant? x)
- ;; Is a constant expression?
- (cond ((identifier? x) (let ((x (identifier-binding x 1)))
- (if (eq? x 'lexical) #f
- (eq? #t x))))
- ((stx-list? x) (andmap constant? (syntax->list x)))
- (else #t)))
- ;; (const? stx)
- ;; Returns #t if stx is a constant value. Procedure applications and
- ;;+identifiers, even if bound at phase 1, are #f.
- ;; Lists of const?s are const?
- (define-for-syntax (const? x)
- ;; Is a constant value?
- (cond ((identifier? x) #f)
- ((stx-list? x) (andmap const? (stx->list x)))
- (else #t)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement