110 lines
3.1 KiB
Scheme
110 lines
3.1 KiB
Scheme
|
|
(module define mzscheme
|
|
(require (lib "stx.ss" "syntax"))
|
|
|
|
(provide normalize-definition)
|
|
|
|
;; This code was shamefully copied from MzScheme's startup.ss!
|
|
|
|
(define normalize-definition
|
|
(case-lambda
|
|
[(stx lambda-stx check-context?)
|
|
(when (and check-context?
|
|
(memq (syntax-local-context) '(expression)))
|
|
(raise-syntax-error
|
|
#f
|
|
"not allowed in an expression context"
|
|
stx))
|
|
(syntax-case stx ()
|
|
[(_ id expr)
|
|
(identifier? #'id)
|
|
(values #'id #'expr)]
|
|
[(_ id . rest)
|
|
(identifier? #'id)
|
|
(raise-syntax-error
|
|
#f
|
|
(syntax-case stx ()
|
|
[(_ id expr ...)
|
|
"bad syntax (multiple expressions after identifier)"]
|
|
[(_ id)
|
|
"bad syntax (zero expressions after identifier)"]
|
|
[(_ id . rest)
|
|
"bad syntax (illegal use of `.')"])
|
|
stx)]
|
|
[(_ something . rest)
|
|
(not (stx-pair? #'something))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
stx
|
|
#'something)]
|
|
[(_ proto . body)
|
|
(let-values ([(id mk-rhs)
|
|
(letrec ([simple-proto
|
|
;; check the args and set up a proc-maker; we return
|
|
;; a proc maker instead of a final proc to enable
|
|
;; left-to-right checking of the function protos
|
|
(lambda (proto)
|
|
(let-values ([(args mk-rhs)
|
|
(syntax-case proto ()
|
|
[(id arg ...)
|
|
(values (syntax->list #'(arg ...))
|
|
(lambda (body)
|
|
(quasisyntax/loc stx (#,lambda-stx (arg ...)
|
|
. #,body))))]
|
|
[(id arg ... . rest)
|
|
(values (syntax->list #'(arg ... rest))
|
|
(lambda (body)
|
|
(quasisyntax/loc stx
|
|
(#,lambda-stx (arg ... . rest)
|
|
. #,body))))])])
|
|
(for-each (lambda (a)
|
|
(unless (identifier? a)
|
|
(raise-syntax-error
|
|
#f
|
|
"not an identifier for procedure argument"
|
|
stx
|
|
a)))
|
|
args)
|
|
(let ([dup (check-duplicate-identifier args)])
|
|
(when dup
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate argument identifier"
|
|
stx
|
|
dup)))
|
|
mk-rhs))]
|
|
[general-proto
|
|
;; proto is guaranteed to be a stx-pair
|
|
(lambda (proto)
|
|
(syntax-case proto ()
|
|
[(id . rest)
|
|
(identifier? #'id)
|
|
(values #'id
|
|
(simple-proto proto))]
|
|
[((something . more) . rest)
|
|
(let-values ([(id mk-rhs) (general-proto #'(something . more))])
|
|
(let ([mk-inner (simple-proto proto)])
|
|
(values id
|
|
(lambda (body)
|
|
(mk-rhs (list (mk-inner body)))))))]
|
|
[(other . rest)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (not an identifier for procedure name, and not a nested procedure form)"
|
|
stx
|
|
#'other)]))])
|
|
(general-proto #'proto))])
|
|
(unless (stx-list? #'body)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (illegal use of `.' for procedure body)"
|
|
stx))
|
|
(when (stx-null? #'body)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (no expressions for procedure body)"
|
|
stx))
|
|
(values id (mk-rhs #'body)))])]
|
|
[(stx lambda-stx) (normalize-definition stx lambda-stx #t)])))
|