287 lines
10 KiB
Scheme
287 lines
10 KiB
Scheme
(module unit-syntax mzscheme
|
|
(require syntax/stx)
|
|
(require-for-template "unit-keywords.ss")
|
|
|
|
(provide (all-defined))
|
|
|
|
(define error-syntax (make-parameter #f))
|
|
(define raise-stx-err
|
|
(case-lambda
|
|
((msg) (raise-syntax-error #f msg (error-syntax)))
|
|
((msg stx) (raise-syntax-error #f msg (error-syntax) stx))))
|
|
|
|
;; check-id: syntax-object -> identifier
|
|
(define (check-id id)
|
|
(unless (identifier? id)
|
|
(raise-stx-err "not an identifier" id))
|
|
id)
|
|
|
|
;; checked-syntax->list : syntax-object -> (listof syntax-object)
|
|
(define (checked-syntax->list s)
|
|
(define l (syntax->list s))
|
|
(unless (or (stx-pair? s) (stx-null? s))
|
|
(raise-stx-err "bad syntax (not a list)" s))
|
|
(unless l
|
|
(raise-stx-err "bad syntax (illegal use of `.')" s))
|
|
l)
|
|
|
|
;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
|
|
(define (check-tagged check)
|
|
(λ (o)
|
|
(syntax-case o (tag)
|
|
((tag . s)
|
|
(syntax-case #'s ()
|
|
((sym spec)
|
|
(begin
|
|
(unless (symbol? (syntax-e #'sym))
|
|
(raise-stx-err "tag must be a symbol" #'sym))
|
|
(cons (syntax-e #'sym) (check #'spec))))
|
|
(_ (raise-stx-err "expected (tag <identifier> <syntax>)" #'s))))
|
|
(_
|
|
(cons #f (check o))))))
|
|
|
|
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
|
|
;; ensures that clause matches (a : b) or (a : (tag t b))
|
|
(define (check-tagged-:-clause clause)
|
|
(checked-syntax->list clause)
|
|
(syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
|
((a : b)
|
|
(identifier? #'a)
|
|
(let ([p ((check-tagged check-id) #'b)])
|
|
(cons (car p) (cons #'a (cdr p)))))
|
|
(_ (raise-stx-err
|
|
"expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))"
|
|
clause))))
|
|
|
|
(define check-tagged-id (check-tagged check-id))
|
|
|
|
;; check-spec-syntax : syntax-object boolean (syntax-object -> boolean) ->
|
|
;; ensures that s matches spec.
|
|
;; tag-spec ::= spec
|
|
;; | (tag symbol spec)
|
|
;; spec ::= prim-spec
|
|
;; | (prefix identifier spec)
|
|
;; | (rename spec (identifier identifier) ...)
|
|
;; | (only spec identifier ...) only if import? is true
|
|
;; | (except spec identifier ...) only if import? is true
|
|
(define (check-tagged-spec-syntax s import? prim-spec?)
|
|
((check-tagged (λ (s) (check-spec-syntax s import? prim-spec?))) s))
|
|
|
|
(define (check-spec-syntax s import? prim-spec?)
|
|
(unless (prim-spec? s)
|
|
(let ((ie (if import? 'import 'export)))
|
|
(unless (stx-pair? s)
|
|
(raise-stx-err (format "bad ~a spec" ie) s))
|
|
(checked-syntax->list s)
|
|
(syntax-case s (prefix rename)
|
|
((key . x)
|
|
(or (module-identifier=? #'key #'only)
|
|
(module-identifier=? #'key #'except))
|
|
(begin
|
|
(unless import?
|
|
(raise-stx-err
|
|
"bad export-spec keyword"
|
|
#'key))
|
|
(syntax-case #'x ()
|
|
(()
|
|
(raise-stx-err (format "missing ~a-spec argument" ie)
|
|
s))
|
|
((s y ...)
|
|
(begin
|
|
(for-each check-id (syntax->list #'(y ...)))
|
|
(check-spec-syntax #'s import? prim-spec?))))))
|
|
((prefix)
|
|
(raise-stx-err (format "missing prefix identifier and ~a spec" ie)
|
|
s))
|
|
((prefix x)
|
|
(begin
|
|
(check-id #'x)
|
|
(raise-stx-err (format "missing ~a spec" ie) s)))
|
|
((prefix x y)
|
|
(begin
|
|
(check-id #'x)
|
|
(check-spec-syntax #'y import? prim-spec?)))
|
|
((prefix . _)
|
|
(raise-stx-err "too many arguments" s))
|
|
((rename)
|
|
(raise-stx-err (format "missing ~a spec" ie) s))
|
|
((rename sub-s clause ...)
|
|
(begin
|
|
(for-each
|
|
(lambda (c)
|
|
(syntax-case c ()
|
|
((a b)
|
|
(begin
|
|
(check-id #'a)
|
|
(check-id #'b)))
|
|
((a . b)
|
|
(begin
|
|
(checked-syntax->list c)
|
|
(raise-stx-err "bad rename clause" c)))
|
|
(_
|
|
(raise-stx-err "bad rename clause" c))))
|
|
(syntax->list #'(clause ...)))
|
|
(check-spec-syntax #'sub-s import? prim-spec?)))
|
|
((k . x)
|
|
(raise-stx-err (format "bad ~a-spec keyword" ie) #'k))))))
|
|
|
|
;; check-unit-syntax : syntax-object -> syntax-object
|
|
;; ensures that stx matches ((import i ...) (export e ...) b ...)
|
|
;; or ((import i ...) (export e ...) (init-depend id ...) b ...)
|
|
;; and returns syntax that matches the latter
|
|
(define (check-unit-syntax stx)
|
|
(syntax-case stx (import export init-depend)
|
|
(((import . isig) (export . esig) (init-depend . id) . body)
|
|
(begin
|
|
(checked-syntax->list (stx-car stx))
|
|
(checked-syntax->list (stx-car (stx-cdr stx)))
|
|
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
|
(checked-syntax->list #'body)
|
|
stx))
|
|
(((import . isig) (export . esig) . body)
|
|
(begin
|
|
(checked-syntax->list (stx-car stx))
|
|
(checked-syntax->list (stx-car (stx-cdr stx)))
|
|
(checked-syntax->list #'body)
|
|
(syntax/loc stx
|
|
((import . isig) (export . esig) (init-depend) . body))))
|
|
(()
|
|
(raise-stx-err "missing import and export clauses"))
|
|
(((import . isig))
|
|
(raise-stx-err "missing export clause"))
|
|
(((import . isig) e . rest)
|
|
(raise-stx-err "export clause must start with keyword \"export\"" #'e))
|
|
((i . rest)
|
|
(raise-stx-err "import clause must start with keyword \"import\"" #'i))))
|
|
|
|
|
|
;; check-unit-body-syntax : syntax-object -> syntax-object
|
|
;; ensures that stx matches (exp (import i ...) (export e ...))
|
|
;; or (exp (import i ...) (export e ...) (init-depend id ...))
|
|
;; and returns syntax that matches the latter
|
|
(define (check-unit-body-syntax stx)
|
|
(checked-syntax->list stx)
|
|
(syntax-case stx (import export init-depend)
|
|
((exp (import . isig) (export . esig) (init-depend . id))
|
|
(begin
|
|
(checked-syntax->list (stx-car (stx-cdr stx)))
|
|
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
|
(checked-syntax->list (stx-car (stx-cdr (stx-cdr (stx-cdr stx)))))
|
|
stx))
|
|
((exp (import . isig) (export . esig))
|
|
(begin
|
|
(checked-syntax->list (stx-car (stx-cdr stx)))
|
|
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
|
(syntax/loc stx
|
|
(exp (import . isig) (export . esig) (init-depend)))))
|
|
(()
|
|
(raise-stx-err "missing expression, import and export clauses"))
|
|
((exp)
|
|
(raise-stx-err "missing import and export clauses"))
|
|
((exp (import . isig))
|
|
(raise-stx-err "missing export clause"))
|
|
((exp i e id extra . rest)
|
|
(raise-stx-err "too many clauses" stx))
|
|
((exp (import . isig) (export . esig) id)
|
|
(raise-stx-err "init-depend clause must start with keyword \"init-depend\"" #'id))
|
|
((exp (import . isig) e . rest)
|
|
(raise-stx-err "export clause must start with keyword \"export\"" #'e))
|
|
((exp i . rest)
|
|
(raise-stx-err "import clause must start with keyword \"import\"" #'i))))
|
|
|
|
|
|
|
|
|
|
;; check-link-line-syntax : syntax-object ->
|
|
;; ensures that l matches ((x ...) u y ...)
|
|
(define (check-link-line-syntax l)
|
|
(unless (stx-pair? l)
|
|
(raise-stx-err "bad linking line" l))
|
|
(checked-syntax->list l)
|
|
(syntax-case l ()
|
|
(((x ...) u y ...) (void))
|
|
(((x ...))
|
|
(raise-stx-err "missing unit expression" l))
|
|
((x . y)
|
|
(begin
|
|
(unless (stx-pair? #'x)
|
|
(raise-stx-err "bad export list" #'x))
|
|
(checked-syntax->list #'x)))))
|
|
|
|
;; check-compound-syntax : syntax-object -> syntax-object
|
|
;; ensures that clauses has exactly one clause matching each of
|
|
;; (import i ...), (export e ...), and (link i ...), in any order.
|
|
;; returns #'((i ...) (e ...) (l ...))
|
|
(define (check-compound-syntax c)
|
|
(define clauses (checked-syntax->list c))
|
|
(define im #f)
|
|
(define ex #f)
|
|
(define li #f)
|
|
(for-each
|
|
(lambda (clause)
|
|
(syntax-case clause (import export link)
|
|
((import i ...)
|
|
(begin
|
|
(when im
|
|
(raise-stx-err "multiple import clauses" clause))
|
|
(set! im (syntax->list #'(i ...)))))
|
|
((export e ...)
|
|
(begin
|
|
(when ex
|
|
(raise-stx-err "multiple export clauses" clause))
|
|
(set! ex (syntax->list #'(e ...)))))
|
|
((link l ...)
|
|
(begin
|
|
(when li
|
|
(raise-stx-err "duplicate link clauses" clause))
|
|
(set! li (syntax->list #'(l ...)))))
|
|
((x . y)
|
|
(begin
|
|
(checked-syntax->list clause)
|
|
(raise-stx-err "bad compound-unit clause keyword" #'x)))
|
|
(_
|
|
(raise-stx-err "expected import, export, or link clause" clause))))
|
|
clauses)
|
|
(unless im
|
|
(raise-stx-err "missing import clause"))
|
|
(unless ex
|
|
(raise-stx-err "missing export clause"))
|
|
(unless li
|
|
(raise-stx-err "missing link clause" ))
|
|
#`(#,im #,ex #,li))
|
|
|
|
;; check-def-syntax : syntax-object ->
|
|
;; d must be a syntax-pair
|
|
;; ensures that d matches (_ (x ...) e)
|
|
(define (check-def-syntax d)
|
|
(unless (syntax->list d)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (illegal use of `.')"
|
|
d))
|
|
(syntax-case d ()
|
|
((_ params expr)
|
|
(let ((l (syntax->list #'params)))
|
|
(unless l
|
|
(raise-syntax-error
|
|
#f
|
|
"bad variable list"
|
|
d #'params))
|
|
(for-each
|
|
(lambda (x)
|
|
(unless (identifier? x)
|
|
(raise-syntax-error
|
|
#f
|
|
"not an identifier"
|
|
d x)))
|
|
l)))
|
|
(_
|
|
(raise-syntax-error
|
|
#f
|
|
(format "bad syntax (has ~a parts after keyword)"
|
|
(sub1 (length (syntax->list d))))
|
|
d))))
|
|
)
|
|
|
|
;(load "test-unit-syntax.ss")
|