This week only. Pastebin PRO Accounts Christmas Special! Don't miss out!Want more features on Pastebin? Sign Up, it's FREE!
Guest

ANVSDT

By: a guest on Jan 19th, 2011  |  syntax: Lisp  |  size: 8.57 KB  |  views: 294  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. #lang racket
  2. (require (for-syntax syntax/stx))
  3.  
  4. ;;; A note for R[56]RS portability:
  5. ;; The macro and the example code is written in Racket,
  6. ;;+which is known to not adhere to either R5RS and R6RS.
  7. ;; It *is* portable, but some function are named
  8. ;;+differently from R6RS, most notably ``syntax->datum''
  9. ;;+(syntax-object->datum, in R6RS) and ``datum->syntax''.
  10. ;;
  11. ;; Also, the form (define-syntax (id stx) ...) is not standard,
  12. ;;+but widely accepted. For maximum standard-compliance, it should be
  13. ;;+(define-syntax id (lambda (stx) ...)).
  14. ;; The same applies to (λ ...) -> (lambda ...).
  15. ;;
  16. ;; (raise-syntax-error 'symbol "string" #'stx) should be the same of
  17. ;;+(raise (make-syntax-violation 'symbol #'stx)), but I'm not sure.
  18. ;;
  19. ;; (stx-null? x) is defined as:
  20. ;;
  21. ;; (define (stx-null? p)
  22. ;;   (or (null? p)
  23. ;;       (and (syntax? p)
  24. ;;            (null? (syntax->datum p)))))
  25. ;;
  26. ;; As for R5RS, the syntax-case's syntax used by SRFI 72 and SRFI 93 is
  27. ;;+different from R6RS and Racket's, as SRFI 72 doesn't require the
  28. ;;+#'/#` reader macros/extensions, and both just override
  29. ;;+(unquote ...) and (unquote-splicing ...), instead of providing
  30. ;;+(unquote-syntax ...)/#, and (unquote-syntax-splicing ...)/#,@.
  31. ;; It could be ported, but you'd lose the ability to expand , and ,@
  32. ;;+as expected in a macro.
  33.  
  34. (define-syntax (define-macro stx)
  35.   (define (parse-kw stx)
  36.     (syntax-case stx (keyword: capture:)
  37.       ((keyword: (l ...) r ...)
  38.        (cons (cons 'keyword #'(l ...)) (parse-kw #'(r ...))))
  39.       ((capture: (v ...) r ...)
  40.        (cons (cons 'capture #'(v ...)) (parse-kw #'(r ...))))
  41.       ((keyword: l r ...)
  42.        (cons (cons 'capture #'(l)) (parse-kw #'(r ...))))
  43.       ((capture: v r ...)
  44.        (cons (cons 'capture #'(v)) (parse-kw #'(r ...))))
  45.       ((r ...)
  46.        (cons (cons 'body #'(r ...)) '()))))
  47.   (define (parse-kws m stx)
  48.     (syntax-case stx (capture: nil)
  49.       (((nil capture: (l ...) b ...) r ...)
  50.        (if (stx-null? #'(r ...)) (cons #'(nil capture: (l ...) b ...) '())
  51.            (raise-syntax-error 'define-macro "bad syntax (nil case must be last)" #'(nil capture: (l ...) b ...))))
  52.       (((nil capture: l b ...) r ...)
  53.        (if (stx-null? #'(r ...)) (cons #'(nil capture: (l) b ...) '())
  54.            (raise-syntax-error 'define-macro "bad syntax (nil case must be last)" #'(nil capture: l b ...))))
  55.       (((nil b ...) r ...)
  56.        (if (stx-null? #'(r ...)) (cons #'(nil capture: () b ...) '())
  57.            (raise-syntax-error 'define-macro "bad syntax (nil case must be last)" #'(nil b ...))))
  58.       (((a capture: (l ...) b ...) r ...)
  59.        (cons #'(a capture: (l ...) b ...) (parse-kws m #'(r ...))))
  60.       (((a capture: l b ...) r ...)
  61.        (cons #'(a capture: (l) b ...) (parse-kws m #'(r ...))))
  62.       (((a b ...) r ...)
  63.        (cons #'(a capture: () b ...) (parse-kws m #'(r ...))))
  64.       (() (cons #`(nil capture: () (raise-syntax-error '#,m "bad syntax" '(#,m))) '()))))
  65.   (syntax-case stx (macro-case keyword: capture: nil)
  66.     ((define-macro m (a ...) keyword: (l ...) capture: (v ...) b ...)
  67.      #`(define-syntax (m stx)
  68.          (syntax-case stx (l ...)
  69.            ((m a ...)
  70.             #,(if (stx-null? #'(v ...)) #'(begin #`b ...)
  71.                   #'(with-syntax ((v (datum->syntax stx 'v)) ...)
  72.                       #`b ...))))))
  73.     ((define-macro m keyword: (l ...) capture: (g ...) (macro-case ((a ...) capture: (c ...) r ...) ... (nil capture: (nc ...) nr ...)))
  74.      #`(define-syntax (m stx)
  75.          (syntax-case stx (l ...)
  76.            ((m)
  77.             (with-syntax ((g (datum->syntax stx 'g)) ...)
  78.               (with-syntax ((nc (datum->syntax stx 'nc)) ...)
  79.                 #`nr ...)))
  80.            ((m a ...)
  81.             (with-syntax ((g (datum->syntax stx 'g)) ...)
  82.               (with-syntax ((c (datum->syntax stx 'c)) ...)
  83.                 #`r ...))) ...)))
  84.     ((define-macro m keyword: (l ...) capture (g ...) (macro-case (a r ...) ...))
  85.      #`(define-macro m
  86.          keyword: (l ...)
  87.          capture: (g ...)
  88.          (macro-case
  89.           #,@(parse-kws #'m #'((a r ...) ...)))))
  90.     ((define-macro (m a ...) r ...)
  91.      #'(define-macro m (a ...) r ...))
  92.     ((define-macro m (macro-case r ...))
  93.      #'(define-macro m
  94.          keyword: ()
  95.          capture: ()
  96.          (macro-case r ...)))
  97.     ((define-macro m (a ...) r ...)
  98.      (let* ((kw (parse-kw #'(r ...)))
  99.             (key (assoc 'keyword kw))
  100.             (cap (assoc 'capture kw))
  101.             (body (assoc 'body kw)))
  102.        #`(define-macro m (a ...)
  103.            keyword: #,(if key (cdr key) '())
  104.            capture: #,(if cap (cdr cap) '())
  105.            #,@(if body (cdr body) (raise-syntax-error 'define-macro "bad syntax (empty body)" #'m)))))
  106.     ((define-macro m r ...)
  107.      (let* ((kw (parse-kw #'(r ...)))
  108.             (key (assoc 'keyword kw))
  109.             (cap (assoc 'capture kw))
  110.             (body (assoc 'body kw)))
  111.        #`(define-macro m
  112.            keyword: #,(if key (cdr key) '())
  113.            capture: #,(if cap (cdr cap) '())
  114.            #,@(if body (cdr body) (raise-syntax-error 'define-macro "bad syntax (empty body)" #'m)))))))
  115.  
  116. ;; Example code.
  117.  
  118. (define-macro (aif p t f)
  119.   ; could be declared also as:
  120.   ; (define-macro aif (p t f) ...)
  121.   capture: it ; the symbol it is unhygienic.
  122.   ; want to capture more symbols?
  123.   ; use `capture: (sym ...)'
  124.   ; in fact, that gets translated to capture: (it)
  125.   (let ((it p))
  126.     (if it t f)))
  127.  
  128. (aif (+ 2 2) it 5) ; 4
  129.  
  130. (define-macro or
  131.   (macro-case
  132.    ; can accept more patterns, too!
  133.    ((#t t ...) #t)
  134.    ((#f t ...) (or t ...))
  135.    ((t) t)
  136.    ((t r ...) (let ((x t)) (if x x (or r ...))))
  137.    (nil #f))) ; this matches (or)
  138.  
  139. (or #t 3) ; (#t t ...) => #t
  140. (or) ; nil case => #f
  141.  
  142. (define-macro aif2
  143.   capture: it ; `it' will be captured for each pattern in macro-case
  144.   (macro-case
  145.    ((p) (if p #t #f)) ; if you don't use a captured symbol,
  146.                       ; the macro will remain completely hygienic.
  147.    ((p t f) (let ((it p)) ; it used, unhygienic.
  148.             (if it t f)))
  149.    ((p t)
  150.     capture: result
  151.     ; you can declare per-pattern captures
  152.     (let ((result p))
  153.       (if result t #f)))
  154.    ((r p t f)
  155.     ; the classic hygienic aif, you name `it'.
  156.     (let ((r p))
  157.       (if r t f)))
  158.    (nil ; the nil case must be specified as last
  159.     #t)))
  160.  
  161. (define it 3)
  162. (aif2 result (/ 4 2) (+ result it) #f) ; 5
  163. (aif2 (+ it 3) it #f) ; 6
  164. (aif2 3 it) ; => 3 ((aif2 p t) captures result, it remains unchanged.)
  165.  
  166. (define-macro assert1 (p => e)
  167.   keyword: => ; same as capture, but you can't have
  168.               ; per-pattern literal keywords.
  169.   ; more kws with keyword: (kw ...)
  170.   (let ((r p))
  171.     (unless (equal? r e)
  172.       (error 'assert "assertion failed: ~a returned ~a instead of ~a" 'p r e))))
  173.  
  174. (define-macro assert
  175.   keyword: (=> !)
  176.   ; works with the `macro-case' definition too.
  177.   (macro-case
  178.    ((p => e)
  179.     (assert p => e ! "~a returned ~a instead of ~a" test result expected))
  180.    ((p => e ! msg fmt ...)
  181.     capture: (test expected result)
  182.     (let ((test 'p)
  183.           (expected e)
  184.           (result p))
  185.       (unless (equal? result expected)
  186.         (error 'assert (string-append "assertion failed: " msg) fmt ...))))
  187.    (nil (begin))))
  188.  
  189. ;(assert1 (+ 2 2) => 5) ; uncomment to assert wheter 2+2 is 5 or not
  190. ;(assert (+ 2 2) => 5 ! "~a is not ~a!" test expected) ; => assert: assertion failed: (+ 2 2) is not 5!
  191.  
  192. ;;; Evaluate expressions at expansion-time
  193. ;; define-macro's body is really wrapped in
  194. ;;+a (quasiquote-syntax ...), you can just
  195. ;;+unquote an expression and it will be evaluated.
  196. (define-macro compile-time-plus (x y)
  197.   (+ 2 ; the macro will calculate (+ x y) at compile time, then add 2 to it at runtime.
  198.      #,(+ (syntax->datum #'x)   ; remember that the macro always receives syntax objects
  199.           (syntax->datum #'y))))
  200.  
  201. (compile-time-plus 3 4) ; => (+ 2 7) => 9
  202.  
  203. ;;; Bonus code:
  204.  
  205. ;; (constant? stx)
  206. ;; Returns #t if stx is a constant expression that is `eval-syntax'-able at phase 1.
  207. (define-for-syntax (constant? x)
  208.   ;; Is a constant expression?
  209.   (cond ((identifier? x) (let ((x (identifier-binding x 1)))
  210.                            (if (eq? x 'lexical) #f
  211.                                (eq? #t x))))
  212.         ((stx-list? x) (andmap constant? (syntax->list x)))
  213.         (else #t)))
  214.  
  215. ;; (const? stx)
  216. ;; Returns #t if stx is a constant value. Procedure applications and
  217. ;;+identifiers, even if bound at phase 1, are #f.
  218. ;; Lists of const?s are const?
  219. (define-for-syntax (const? x)
  220.     ;; Is a constant value?
  221.     (cond ((identifier? x) #f)
  222.           ((stx-list? x) (andmap const? (stx->list x)))
  223.           (else #t)))
clone this paste RAW Paste Data