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