Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 116 lines (96 sloc) 3.81 KB
(define make-leaf (lambda (val) (cons val '()))) (define make-unary-node (lambda (parent child) (cons parent (cons child '())))) (define make-binary-node (lambda (parent left-child right-child) (cons parent (cons left-child (cons right-child '()))))) (define root first) (define left-child (lambda (tree) (first (rest tree)))) (define right-child (lambda (tree) (first (rest (rest tree))))) (define parse-number (lambda (token) (cond [(eq? (type token) 'number-token) (make-leaf (value token))] [else (error "unexpected token " (type token))]))) (define parse-factor (lambda (token) (cond [(eq? (type token) 'number-token) (parse-number token)] [(eq? (type token) 'left-p-token) (let ((tree (parse-arithexpr (get-next-token)))) (cond [(eq? (type (get-next-token)) 'right-p-token) tree] [else (error "missing right parenthesis")]))] [(eq? (type token) 'identifier-token) (parse-identifier token)] [else (error "unexpected token " token)]))) (define parse-identifier (lambda (token) (cond [(eq? (type token) 'identifier-token) (make-leaf (value token))] [else (error "unexpected token " (type token))]))) (define parse-term (lambda (token) (let ((first-factor (parse-factor token))) (parse-suffix (get-next-token) first-factor factor-op? parse-factor)))) (define parse-suffix (lambda (operator left-tree opt-f parse-what?) (cond [(opt-f operator) (let ((new-left-tree (make-binary-node (type operator) left-tree (parse-what? (get-next-token))))) (parse-suffix (get-next-token) new-left-tree opt-f parse-what?))] [else (begin (save-token operator) left-tree)]))) (define factor-op? (lambda (token) ;; returns #t iff token is a mult-token or a div-token (or (eq? (type token) 'mult-token) (eq? (type token) 'div-token)))) (define term-op? (lambda (token) ;; returns #t iff token is a plus-token or a minus-token (or (eq? (type token) 'plus-token) (eq? (type token) 'minus-token)))) (define check-for-assign (lambda (xtype) (cond [(eq? xtype 'assign-token) xtype] [else (error "expected assign-token")]))) (define parse-arithexpr (lambda (token) (let ((first-term (parse-term token))) (parse-suffix (get-next-token) first-term term-op? parse-term)))) (define parse-statement (lambda (token) (cond [(eq? (type token) 'in-token) (make-unary-node (type token) (parse-identifier (get-next-token)))] [(eq? (type token) 'out-token) (make-unary-node (type token) (parse-arithexpr (get-next-token)))] [(eq? (type token) 'identifier-token) (let ((token2 (get-next-token))) (cond [(eq? (type token2) 'assign-token) (make-binary-node (check-for-assign (type token2)) (value token) (parse-arithexpr (get-next-token)))] [else (error "this parser does not accept un-attached arithmetic expressions")]))] [else (error "unexpected token " token)]))) (define parse-statement-list (lambda (token) (let ((statement (parse-statement token))) (parse-statement-suffix (get-next-token) statement)))) (define parse-statement-suffix (lambda (token statement) (cond [(eq? (type token) 'semicolon-token) (make-binary-node (type token) statement (parse-statement-list (get-next-token)))] [else (begin (save-token token) statement)]))) (define parse-program (lambda () (begin (init-parser) (let ((program (parse-statement-list (get-next-token)))) (cond [(eq? (type (get-next-token)) 'end-token) program] [else (error "expected '.'")])))))