#lang racket
(require parser-tools/lex
parser-tools/yacc
"form-1.rkt"
"lex.rkt")
(provide current-source-name program-parser)
(print-only-errors true)
(define current-source-name (make-parameter #f))
(define (make-srcloc start-pos end-pos)
(list (current-source-name)
(position-line start-pos)
(position-col start-pos)
(position-offset start-pos)
(- (position-offset end-pos) (position-offset start-pos))))
(define-syntax (b-syn stx)
(syntax-case stx ()
[(_ ctxt v start end)
(with-syntax
([start-pos-syn (datum->syntax #'start
(string->symbol
(format "$~a-start-pos"
(syntax->datum #'start))))]
[end-pos-syn (datum->syntax #'end
(string->symbol
(format "$~a-end-pos"
(syntax->datum #'end))))])
#'(datum->syntax #f
v
(list (current-source-name)
(position-line start-pos-syn)
(position-col start-pos-syn)
(position-offset start-pos-syn)
(- (position-offset end-pos-syn) (position-offset start-pos-syn)))))]))
(define program-parser
(parser
(start program)
(end EOF)
(tokens value-tokens keyword-tokens op-tokens)
(src-pos) (debug "parse.rkt.debug")
(suppress) (error
(lambda (tok-ok? tok-name tok-val start-pos end-pos)
(raise-syntax-error 'pyret/bsl
(if tok-ok?
(format "unexpected token: ~S" tok-name)
(format "invalid token: ~S" tok-name))
(datum->syntax false tok-val (make-srcloc start-pos end-pos)))))
(precs
(nonassoc SEMI)
(nonassoc RETURN)
(left IF) (right =)
(left OR)
(left AND)
(right NOT)
(left == IS < > LESS-EQUAL GREATER-EQUAL)
(left +)
(left / *)
(left %)
(right **)
(left -) )
(grammar
(program
[(def-or-expr) $1]
[(def-or-expr def-or-expr program)
(stx-begin (cons $1 (cons $2 (list $3))))]
[() (stx-eof)])
(def-or-expr
[(definition) $1]
[(expr) $1])
(definition
[(binding) $1]
[(structdef) $1]
[(fundef) $1]
[(procdef) $1])
(binding
[(IDENTIFIER = expr)
(stx-binding (stx-id (b-syn false $1 1 1))
(b-syn false '= 2 2)
$3)])
(structdef
[(STRUCT IDENTIFIER args) (stx-struct (b-syn false 'struct 1 1)
(stx-id (b-syn false $2 2 2))
$3)])
(fundef
[(FUN IDENTIFIER args COLON expr)
(stx-fun (b-syn false 'fun 1 1)
(stx-id (b-syn false $2 2 2))
$3
(b-syn false ': 4 4)
$5)]
[(FUN IDENTIFIER args COLON let-expr)
(stx-fun (b-syn false 'fun 1 1)
(stx-id (b-syn false $2 2 2))
$3
(b-syn false ': 4 4)
$5)]
[(FUN IDENTIFIER args COLON where-expr)
(stx-fun (b-syn false 'fun 1 1)
(stx-id (b-syn false $2 2 2))
$3
(b-syn false ': 4 4)
$5)])
(procdef [(DEF IDENTIFIER args COLON expr)
(stx-def (b-syn false 'def 1 1)
(stx-id (b-syn false $2 2 2))
$3
(b-syn false ': 4 4)
$5)])
(args
[(OP CP) empty]
[(OP expr expr-list CP)
(cons $2 $3)])
(expr-list
[() empty]
[(COMMA expr expr-list)
(cons $2 $3)])
(let-expr
[(LET local-defs IN COLON expr)
(stx-let (b-syn false 'let 1 1)
$2
(b-syn false 'in 3 3)
(b-syn false ': 4 4)
$5)])
(local-defs
[(binding) `(,$1)]
[(binding COMMA local-defs)
(cons $1 $3)])
(where-expr
[(expr WHERE local-defs)
(stx-where $1
(b-syn false 'where 2 2)
$3)])
(application-expr
[(IDENTIFIER args)
(stx-app (stx-id (b-syn false $1 1 1))
$2)])
(negation-expr
[(- expr)
(stx-neg (b-syn false '- 1 1) $2)])
(arithmetic-expr
[(negation-expr) $1]
[(expr ** expr)
(stx-binop (b-syn false 'expt 2 2) $1 $3)]
[(expr + expr)
(stx-binop (b-syn false '+ 2 2) $1 $3)]
[(expr - expr) (prec +)
(stx-binop (b-syn false '- 2 2) $1 $3)]
[(expr * expr)
(stx-binop (b-syn false '* 2 2) $1 $3)]
[(expr / expr)
(stx-binop (b-syn false '/ 2 2) $1 $3)]
[(expr % expr)
(stx-binop (b-syn false 'modulo 2 2) $1 $3)])
(boolean-expr
[(expr == expr)
(stx-binop (b-syn false '= 2 2) $1 $3)]
[(expr IS expr)
(stx-binop (b-syn false '= 2 2) $1 $3)]
[(expr < expr)
(stx-binop (b-syn false '< 2 2) $1 $3)]
[(expr > expr)
(stx-binop (b-syn false '> 2 2) $1 $3)]
[(expr LESS-EQUAL expr)
(stx-binop (b-syn false '<= 2 2) $1 $3)]
[(expr GREATER-EQUAL expr)
(stx-binop (b-syn false '>= 2 2) $1 $3)]
[(expr AND expr)
(stx-binop (b-syn false 'and 2 2) $1 $3)]
[(expr OR expr)
(stx-binop (b-syn false 'or 2 2) $1 $3)]
[(NOT expr)
(stx-not (b-syn false 'not 1 1) $2)])
(conditional-expr
[(IF expr COLON expr ELSE COLON expr) (prec IF)
(stx-if-else (stx-if (b-syn false 'if 1 1)
$2
(b-syn false ': 3 3)
$4)
(stx-else (b-syn false 'else 5 5)
(b-syn false ': 6 6)
$7))]
[(IF expr COLON expr elif+ ELSE COLON expr) (prec IF)
(stx-cond (stx-if (b-syn false 'if 1 1)
$2
(b-syn false ': 3 3)
$4)
$5
(stx-else (b-syn false 'else 6 6)
(b-syn false ': 7 7)
$8))])
(elif
[(ELIF expr COLON expr)
(stx-elif (b-syn false 'elif 1 1)
$2
(b-syn false ': 3 3)
$4)])
(elif*
[( ) empty]
[(elif elif*)
(cons $1 $2)])
(elif+
[(elif elif*)
(cons $1 $2)])
(expr-comma*
[( ) empty]
[( expr ) `(,$1)]
[( expr COMMA expr-comma* )
(cons $1 $3)])
(listmaker
[(OB expr-comma* CB)
(stx-lst $2)])
(struct-access
[(IDENTIFIER PERIOD IDENTIFIER)
(stx-app (stx-id (b-syn false $1 1 1))
(list (stx-app (stx-id (b-syn false 'quote 3 3))
(list (stx-id (b-syn false $3 3 3))))))])
(expr
[(IDENTIFIER) (stx-id (b-syn false $1 1 1))]
[(NUMBER) (stx-num (b-syn false $1 1 1))]
[(STRING) (stx-str (b-syn false $1 1 1))]
[(CHAR) (stx-char (b-syn false $1 1 1))]
[(RETURN expr) (stx-return (b-syn false 'return 1 1) $2)]
[(struct-access) $1]
[(OP expr CP) $2] [(arithmetic-expr) $1]
[(boolean-expr) $1]
[(application-expr) $1]
[(conditional-expr) $1]
[(listmaker) $1]
[(TRUE) (stx-bool (b-syn false #t 1 1))]
[(FALSE) (stx-bool (b-syn false #f 1 1))]))))
(define (test-parser string)
(let ([p (open-input-string string)])
(port-count-lines! p)
(let ([val (program-parser (lambda () (expression-lexer p)))])
(close-input-port p)
val)))