*** empty log message ***
original commit: aedfa47e449e4927abce7efcb27d0ecbe3bb8e4etokens
parent
f5f5202678
commit
a261d785d0
@ -1,22 +1,48 @@
|
|||||||
#cs
|
#cs
|
||||||
(module token mzscheme
|
(module token mzscheme
|
||||||
|
|
||||||
;; Defining tokens
|
|
||||||
|
|
||||||
(require-for-syntax "token-syntax.ss")
|
(require-for-syntax "token-syntax.ss")
|
||||||
|
|
||||||
|
;; Defining tokens
|
||||||
|
|
||||||
(provide define-tokens define-empty-tokens make-token token-name token-value token?)
|
(provide define-tokens define-empty-tokens make-token token-name token-value token?)
|
||||||
|
|
||||||
(define-struct token (name value) (make-inspector))
|
(define-struct token (name value) (make-inspector))
|
||||||
|
|
||||||
(define-syntax (define-tokens stx)
|
(define-syntaxes (define-tokens define-empty-tokens)
|
||||||
(syntax-case stx ()
|
(let ((define-tokens-helper
|
||||||
((_ name ...)
|
(lambda (stx empty?)
|
||||||
(define-tokens-helper stx #'here #f))))
|
|
||||||
|
|
||||||
(define-syntax (define-empty-tokens stx)
|
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
((_ name ...)
|
((_ name (terms ...))
|
||||||
(define-tokens-helper stx #'here #t))))
|
(andmap identifier? (syntax->list (syntax (terms ...))))
|
||||||
|
(datum->syntax-object
|
||||||
|
#'here
|
||||||
|
`(begin
|
||||||
|
(define-syntax ,(syntax name)
|
||||||
|
(make-terminals-def (quote-syntax ,(syntax (terms ...)))))
|
||||||
|
,@(map
|
||||||
|
(lambda (n)
|
||||||
|
(if (eq? (syntax-object->datum n) 'error)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"Cannot define a token named error."
|
||||||
|
stx))
|
||||||
|
`(define (,(datum->syntax-object
|
||||||
|
n
|
||||||
|
(string->symbol
|
||||||
|
(format "token-~a" (syntax-object->datum n)))
|
||||||
|
n)
|
||||||
|
,@(if empty? '() '(x)))
|
||||||
|
(make-token ',n ,(if empty? #f 'x))))
|
||||||
|
(syntax->list (syntax (terms ...)))))
|
||||||
|
stx))
|
||||||
|
((_ ...)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"must have the form (define-tokens name (symbol ...)) or (define-empty-tokens name (symbol ...))"
|
||||||
|
stx))))))
|
||||||
|
(values
|
||||||
|
(lambda (stx) (define-tokens-helper stx #f))
|
||||||
|
(lambda (stx) (define-tokens-helper stx #t)))))
|
||||||
)
|
)
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue