ANVSDT

#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)))