73 lines
1.7 KiB
Racket
73 lines
1.7 KiB
Racket
|
|
(module defmacro mzscheme
|
|
(require-for-syntax syntax/stx
|
|
"private/dmhelp.rkt")
|
|
|
|
(provide define-macro
|
|
defmacro)
|
|
|
|
(define-syntax define-macro
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ (name . args) proc0 proc ...)
|
|
(begin
|
|
(unless (identifier? (syntax name))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier for the macro name"
|
|
stx
|
|
(syntax name)))
|
|
(let loop ([args (syntax args)])
|
|
(cond
|
|
[(stx-null? args) 'ok]
|
|
[(identifier? args) 'ok]
|
|
[(stx-pair? args)
|
|
(unless (identifier? (stx-car args))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier for a macro argument"
|
|
stx
|
|
(stx-car args)))
|
|
(loop (stx-cdr args))]
|
|
[else (raise-syntax-error
|
|
#f
|
|
"not a valid argument sequence after the macro name"
|
|
stx)]))
|
|
(syntax
|
|
(define-macro name (lambda args proc0 proc ...))))]
|
|
[(_ name proc)
|
|
(begin
|
|
(unless (identifier? (syntax name))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier for the macro name"
|
|
stx
|
|
(syntax name)))
|
|
(syntax
|
|
(define-syntax name
|
|
(let ([p proc])
|
|
(unless (procedure? p)
|
|
(raise-type-error
|
|
'define-macro
|
|
"procedure (arity 1)"
|
|
p))
|
|
(lambda (stx)
|
|
(let ([l (syntax->list stx)])
|
|
(unless (and l (procedure-arity-includes? p (sub1 (length l))))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad form"
|
|
stx))
|
|
(let ([ht (make-hash-table)])
|
|
(datum->syntax-object
|
|
stx
|
|
(dm-subst
|
|
ht
|
|
(apply p (cdr (dm-syntax->datum stx ht))))
|
|
stx))))))))])))
|
|
|
|
(define-syntax defmacro
|
|
(syntax-rules ()
|
|
[(_ name formals body1 body ...)
|
|
(define-macro (name . formals) body1 body ...)])))
|