103 lines
5.1 KiB
Racket
103 lines
5.1 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
syntax/kerncase
|
|
syntax/context))
|
|
|
|
(provide finish-syntax-set)
|
|
|
|
;; Used in the expansion of `define-syntax-set' from "etc.rkt"
|
|
(define-syntax (finish-syntax-set stx)
|
|
(syntax-case stx ()
|
|
[(_ stx)
|
|
(let ([stx (syntax stx)])
|
|
(syntax-case stx ()
|
|
[(_ (id ...) defn ...)
|
|
;; The ids have already been checked --------------------
|
|
(let ([ids (syntax->list (syntax (id ...)))])
|
|
(let ([internal-ids (map (lambda (id)
|
|
(datum->syntax
|
|
id
|
|
(string->symbol (format "~a/proc" (syntax-e id)))
|
|
id))
|
|
ids)]
|
|
[expand-context (generate-expand-context)])
|
|
;; Check defns (requires expand) ---------
|
|
(let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))])
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (defn)
|
|
(let ([defn (local-expand
|
|
defn
|
|
expand-context
|
|
(kernel-form-identifier-list))])
|
|
(syntax-case defn (define-values define-syntaxes begin)
|
|
[(define-values (id ...) expr)
|
|
(andmap identifier? (syntax->list (syntax (id ...))))
|
|
(list defn)]
|
|
[(define-values . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad definition"
|
|
stx
|
|
defn)]
|
|
[(define-syntaxes (id ...) expr)
|
|
(andmap identifier? (syntax->list (syntax (id ...))))
|
|
(list defn)]
|
|
[(define-syntaxes . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad definition"
|
|
stx
|
|
defn)]
|
|
[(begin defn ...)
|
|
(loop (syntax->list (syntax (defn ...))))]
|
|
[(begin . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad `begin'"
|
|
stx
|
|
defn)]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
"not a definition"
|
|
stx
|
|
defn)])))
|
|
defns)))]
|
|
|
|
[def-ids (apply append (map (lambda (defn)
|
|
(syntax-case defn ()
|
|
[(_ (id ...) expr)
|
|
(syntax->list (syntax (id ...)))]))
|
|
defns))]
|
|
[val-ids (apply append (map (lambda (defn)
|
|
(syntax-case defn (define-values)
|
|
[(define-values (id ...) expr)
|
|
(syntax->list (syntax (id ...)))]
|
|
[_else null]))
|
|
defns))])
|
|
(let ([dup (check-duplicate-identifier def-ids)])
|
|
(when dup
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate defined identifier"
|
|
stx
|
|
dup)))
|
|
;; Check that declared are defined ---------
|
|
(for-each (lambda (id)
|
|
(unless (check-duplicate-identifier (cons id val-ids))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected identifier is not defined"
|
|
stx
|
|
id)))
|
|
internal-ids)
|
|
;; Produce result ------------------------------
|
|
(with-syntax ([(defn ...) defns]
|
|
[(internal-id ...) internal-ids])
|
|
(syntax/loc stx
|
|
(let ()
|
|
defn ...
|
|
(values internal-id ...)))))))]))]))
|