commit 772bd98385430c73c77b6c7e199b37dc638afd1d (patch) parent 153b8624339bcd3859746e062303cf174e2ae939 Author: Alex Karle <alex@alexkarle.com> Date: Thu, 27 Oct 2022 22:09:48 -0400 parser: Add panic function This diff mostly whitespace! Diffstat:
| M | fisl.scm | | | 2 | +- |
| M | parser.scm | | | 143 | +++++++++++++++++++++++++++++++++++++++++++------------------------------------ |
2 files changed, 79 insertions(+), 66 deletions(-)
diff --git a/fisl.scm b/fisl.scm @@ -12,7 +12,7 @@ util) (define (run code fname) - (print (parse (scan code fname)))) + (print (parse (scan code fname) fname))) (define (run-prompt) (display "> ") diff --git a/parser.scm b/parser.scm @@ -2,6 +2,7 @@ (import scheme scanner + util (chicken base) (chicken format)) @@ -26,73 +27,85 @@ (token-lexeme (unary-operator x)) (unary-right x)))) - (define (expression expr toks) - (equality expr toks)) - (define (top-type? tokens types) (memq (token-type (car tokens)) types)) - (define (equality expr toks) - ; (print (format "equality ~S ~S" expr toks)) - (let ((ret (comparison expr toks))) - (let loop ((e (car ret)) (ts (cdr ret))) - (if (top-type? ts '(BANG_EQUAL EQUAL_EQUAL)) - (let ((ret2 (comparison e (cdr ts)))) - (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) - (cons e ts))))) - - (define (comparison expr toks) - ; (print (format "comparison ~S ~S" expr toks)) - (let ((ret (term expr toks))) - (let loop ((e (car ret)) (ts (cdr ret))) - (if (top-type? ts '(GREATER GREATER_EQUAL LESS LESS_EQUAL)) - (let ((ret2 (term e (cdr ts)))) - (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) - (cons e ts))))) - - (define (term expr toks) - ; (print (format "term ~S ~S" expr toks)) - (let ((ret (factor expr toks))) - (let loop ((e (car ret)) (ts (cdr ret))) - (if (top-type? ts '(MINUS PLUS)) - (let ((ret2 (factor e (cdr ts)))) - (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) - (cons e ts))))) - - (define (factor expr toks) - ; (print (format "factor ~S ~S" expr toks)) - (let ((ret (unary expr toks))) - (let loop ((e (car ret)) (ts (cdr ret))) - (if (top-type? ts '(SLASH STAR)) - (let ((ret2 (unary e (cdr ts)))) - (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) - (cons e ts))))) - - (define (unary expr toks) - ; (print (format "unary ~S ~S" expr toks)) - (if (top-type? toks '(BANG MINUS)) - (let ((ret (unary expr (cdr toks)))) - (cons (make-unary (car toks) (car ret)) (cdr ret))) - (primary expr toks))) - - (define (primary expr toks) - ; (print (format "primary ~S ~S" expr toks)) - (cond - ((top-type? toks '(FALSE)) (cons (make-literal #f) (cdr toks))) - ((top-type? toks '(TRUE)) (cons (make-literal #t) (cdr toks))) - ; XXX: nil vs false? - ((top-type? toks '(NIL)) (cons (make-literal '()) (cdr toks))) - ((top-type? toks '(NUMBER STRING)) - (cons (make-literal (token-literal (car toks))) (cdr toks))) - ((top-type? toks '(LEFT_PAREN)) - (let ((ret (expression expr (cdr toks)))) - (if (eq? (token-type (cadr ret)) 'RIGHT_PAREN) - (cons (make-grouping (car ret)) (cddr ret)) - ; TODO: handle? - (error "Unbalanced parens!")))) - (else (error (format "Unknown literal ~S" (car toks)))))) - - - (define (parse tokens) + (define (parse tokens fname) + + (define (panic tok msg) + (if (eq? (token-type tok) 'EOF) + (err! (format "~A:~A:~A ~A" fname (token-line tok) "Error at end." msg)) + (err! (format "~A:~A:~A ~A. ~A" + fname + (token-line tok) + "Error at" + (token-lexeme tok) + msg))) + ; TODO: synchronize instead of exit + (exit 1)) + + (define (expression expr toks) + (equality expr toks)) + + (define (equality expr toks) + ; (print (format "equality ~S ~S" expr toks)) + (let ((ret (comparison expr toks))) + (let loop ((e (car ret)) (ts (cdr ret))) + (if (top-type? ts '(BANG_EQUAL EQUAL_EQUAL)) + (let ((ret2 (comparison e (cdr ts)))) + (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) + (cons e ts))))) + + (define (comparison expr toks) + ; (print (format "comparison ~S ~S" expr toks)) + (let ((ret (term expr toks))) + (let loop ((e (car ret)) (ts (cdr ret))) + (if (top-type? ts '(GREATER GREATER_EQUAL LESS LESS_EQUAL)) + (let ((ret2 (term e (cdr ts)))) + (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) + (cons e ts))))) + + (define (term expr toks) + ; (print (format "term ~S ~S" expr toks)) + (let ((ret (factor expr toks))) + (let loop ((e (car ret)) (ts (cdr ret))) + (if (top-type? ts '(MINUS PLUS)) + (let ((ret2 (factor e (cdr ts)))) + (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) + (cons e ts))))) + + (define (factor expr toks) + ; (print (format "factor ~S ~S" expr toks)) + (let ((ret (unary expr toks))) + (let loop ((e (car ret)) (ts (cdr ret))) + (if (top-type? ts '(SLASH STAR)) + (let ((ret2 (unary e (cdr ts)))) + (loop (make-binary e (car ts) (car ret2)) (cdr ret2))) + (cons e ts))))) + + (define (unary expr toks) + ; (print (format "unary ~S ~S" expr toks)) + (if (top-type? toks '(BANG MINUS)) + (let ((ret (unary expr (cdr toks)))) + (cons (make-unary (car toks) (car ret)) (cdr ret))) + (primary expr toks))) + + (define (primary expr toks) + ; (print (format "primary ~S ~S" expr toks)) + (cond + ((top-type? toks '(FALSE)) (cons (make-literal #f) (cdr toks))) + ((top-type? toks '(TRUE)) (cons (make-literal #t) (cdr toks))) + ; XXX: nil vs false? + ((top-type? toks '(NIL)) (cons (make-literal '()) (cdr toks))) + ((top-type? toks '(NUMBER STRING)) + (cons (make-literal (token-literal (car toks))) (cdr toks))) + ((top-type? toks '(LEFT_PAREN)) + (let ((ret (expression expr (cdr toks)))) + (if (eq? (token-type (cadr ret)) 'RIGHT_PAREN) + (cons (make-grouping (car ret)) (cddr ret)) + (panic (cadr ret) "Expected ')'")))) + (else (panic (car toks) "Unknown token")))) + + ;; Actual body of parse! (car (expression '() tokens))) )