(module grammar-examples mzscheme
(provide (rename exp? eopl-section-5.5-exp?) (rename scheme? r4rs-scheme?) grammar?
lambda-calculus?)
(require "grammar.ss")
(define exp?
(grammar expression
(variable
(predicate
(lambda (x)
(and (symbol? x)
(not (memq x '(quote if lambda let set!)))))))
(literal (predicate number?))
(datum (predicate (lambda (x) #t)))
(declaration (lst variable expression))
(procedure-call
(predicate (lambda (x) (and (pair? x)
(not (and (symbol? (car x)) (not (variable x))))
(not (boolean? ((plus expression) x)))))))
(expression
(report-if-bad 'expression
(alt variable literal procedure-call
(lst 'quote datum)
(lst 'lambda (lst (star variable)) expression)
(lst 'if expression expression expression)
(lst 'set! variable expression)
(lst 'let (lst (star declaration)) expression))))))
(define grammar?
(grammar grammar-expression
(datum (predicate (lambda (x) #t)))
(expression datum)
(grammar-expression
(report-if-bad 'grammar-expression
(lst 'grammar start (plus production))))
(start variable)
(variable (predicate symbol?))
(production (report-if-bad 'production (lst variable (star element))))
(element (alt terminal non-terminal))
(terminal (lst 'quote datum))
(non-terminal
(report-if-bad 'non-terminal
(alt variable
(lst 'alt (star element))
(lst 'seq (star element))
(lst 'lst (star element))
(lst 'star element)
(lst 'plus element)
(lst 'opt element)
(lst 'dot element element)
(lst 'predicate expression)
(lst 'cfa expression)
(lst 'report-if-bad datum non-terminal))))))
(define scheme?
(grammar <command-or-definition>
(<expression-keyword>
(alt 'quote 'lambda 'if 'set! 'begin 'cond 'and 'or 'case 'let 'let*
'letrec 'do 'delay 'quasiquote))
(<variable>
(predicate
(lambda (x)
(and (symbol? x)
(not (<expression-keyword> (list x)))))))
(<number> (predicate number?))
(<boolean> (predicate boolean?))
(<character> (predicate char?))
(<string> (predicate string?)) (<datum> (alt <simple-datum> <compound-datum>))
(<simple-datum>
(alt <symbol>
(predicate
(lambda (x)
(or (boolean? x) (number? x) (char? x) (string? x))))))
(<symbol> (predicate symbol?))
(<compound-datum> (alt <list> <vector>))
(<list> (alt (lst (star <datum>)) (dot (plus <datum>) <datum>)))
(<vector> (predicate
(lambda (x)
(and (vector? x)
((star <datum>) (vector->list x))))))
(<expression> (alt <variable> <literal> <procedure-call> <lambda-expression>
<conditional> <assignment> <derived-expression>))
(<literal> (alt <quotation> <self-evaluating>))
(<self-evaluating> (alt <boolean> <number> <character> <string>))
(<quotation> (lst 'quote <datum>))
(<procedure-call> (predicate (lambda (x) (and (pair? x)
(not (and (symbol? (car x)) (not (<variable> x))))
((seq <operator> (star <operand>))
x)))))
(<operator> <expression>)
(<operand> <expression>)
(<lambda-expression> (lst 'lambda <formals> <body>))
(<formals> (alt (lst (star <variable>)) <variable>
(dot (plus <variable>) <variable>)))
(<body> (star <definition>) <sequence>)
(<sequence> (star <command>) <expression>)
(<command> <expression>)
(<conditional> (lst 'if <test> <consequent> <alternate>))
(<test> <expression>)
(<consequent> <expression>)
(<alternate> (alt <expression> <empty>)) (<empty> (seq))
(<assignment> (lst 'set! <variable> <expression>))
(<derived-expression>
(alt
(lst 'cond (plus <cond-clause>))
(lst 'cond (star <cond-clause>) (lst 'else <sequence>))
(lst 'case <expression> (plus <case-clause>))
(lst 'case <expression> (star <case-clause>) (lst 'else <sequence>))
(lst 'and (star <test>))
(lst 'or (star <test>))
(lst 'let (lst (star <binding-spec>)) <body>)
(lst 'let <variable> (lst (star <binding-spec>)) <body>)
(lst 'let* (lst (star <binding-spec>)) <body>)
(lst 'letrec (lst (star <binding-spec>)) <body>)
(lst 'begin <sequence>)
(lst 'do (lst (star <iteration-spec>))
(lst <test> <sequence>)
(star <command>))
(lst 'delay <expression>)
<quasiquotation>))
(<cond-clause> (alt (lst <test> <sequence>)
(lst <test>)
(lst <test> '=> <recipient>)))
(<recipient> <expression>)
(<case-clause> (lst (lst (star <datum>)) <sequence>))
(<binding-spec> (lst <variable> <expression>))
(<iteration-spec> (alt (lst <variable> <init> <step>)
(lst <variable> <init>)))
(<init> <expression>)
(<step> <expression>)
(<quasiquotation> (lst 'quasiquote <template>))
(<template> (alt <simple-datum> <list-template> <vector-template> <unquotation>))
(<list-template> (alt (lst (star <template-or-splice>))
(dot (plus <template-or-splice>) <template>)))
(<vector-template> (predicate
(lambda (x)
(and (vector? x)
((star <template-or-splice>) (vector->list x))))))
(<unquotation> (lst 'unquote <template>))
(<template-or-splice> (alt <template> <splice-unquotation>))
(<splice-unquotation> (lst 'unquote-splicing <template>))
(<command-or-definition> (alt <command> <definition>))
(<definition>
(report-if-bad 'definition
(alt (lst 'define <variable> <expression>)
(lst 'define (lst <variable> <def-formals>) <body>)
(lst 'begin (star <definition>)))))
(<def-formals> (alt (star <variable>)
(dot (plus <variable>) <variable>)))))
(define-grammar lambda-calculus?
(grammar <expression>
(<expression> (alt <variable> <application> <abstraction>))
(<application> (lst <expression> <expression>))
(<abstraction> (lst 'lambda (lst <variable>) <expression>))
(<variable> (predicate
(λ (x) (and (symbol? x) (not (eq? x 'lambda))))))))
)