interpreter.scm (5889B) [raw]
1 ;; interpreter.scm -- evaluates parsed statements 2 (import 3 srfi-69 ; hash-tables 4 (chicken format)) 5 6 (define interpreter-abort #f) 7 8 (define (make-env parent) 9 (let ((ht (make-hash-table))) 10 (lambda (action) 11 (cond ((eq? action 'get) 12 (lambda (el) 13 (if (hash-table-exists? ht el) 14 (hash-table-ref ht el) 15 (if parent 16 (env-get parent el) 17 (runtime-err! (format "Unbound variable ~A" el)))))) 18 ((eq? action 'def) 19 ;; var block, sets in current env 20 (lambda (el val) 21 (hash-table-set! ht el val))) 22 ((eq? action 'set) 23 (lambda (el val) 24 (if (hash-table-exists? ht el) 25 (hash-table-set! ht el val) 26 (if parent 27 (env-set! parent el val) 28 (runtime-err! (format "Unable to set unbound variable ~A" el)))))) 29 ((eq? action 'exists) 30 (lambda (el) 31 (if (hash-table-exists? ht el) 32 #t 33 (and parent (env-exists? parent el))))) 34 (else (error (format "Unknown action for env -- ~A" action))))))) 35 36 (define (env-get env key) 37 ((env 'get) key)) 38 39 (define (env-set! env key val) 40 ((env 'set) key val)) 41 42 (define (env-def! env key val) 43 ((env 'def) key val)) 44 45 (define (env-exists? env key) 46 ((env 'exists) key)) 47 48 (define (runtime-err! msg) 49 (err! msg) 50 (interpreter-abort #f)) 51 52 (define (truthy? x) 53 (not (or (null? x) (eq? x #f)))) 54 55 (define (lox-equal? a b) 56 (cond 57 ((and (null? a) (null? b)) #t) 58 ((null? a) #f) 59 (else (equal? a b)))) 60 61 (define (assert-num op x) 62 (or (number? x) (runtime-err! (format "Operand must be a number ~A ~A" op x)))) 63 64 (define (assert-nums op x y) 65 (or (and (number? x) (number? y)) 66 (runtime-err! (format "Operands must be numbers ~A ~A ~A" x op y)))) 67 68 (define (evaluate expr env) 69 (cond 70 ((literal? expr) (literal-value expr)) 71 ((grouping? expr) 72 (evaluate (grouping-expression expr) env)) 73 ((variable? expr) 74 (let ((tok (variable-name expr))) 75 (env-get env (token-lexeme tok)))) 76 ((assignment? expr) 77 (let ((tok (assignment-name expr))) 78 (if (env-exists? env (token-lexeme tok)) 79 (let ((res (evaluate (assignment-value expr) env))) 80 (env-set! env (token-lexeme tok) res) 81 res) 82 (runtime-err! (format "Unbound variable ~A at line ~A" 83 (token-lexeme tok) (token-line tok)))))) 84 ((unary? expr) 85 (let ((right (evaluate (unary-right expr) env)) 86 (op (token-type (unary-operator expr)))) 87 (case op 88 ((BANG) (not (truthy? right))) 89 ((MINUS) 90 (assert-num op right) 91 (- right)) 92 (else (runtime-err! (format "Unknown unary op ~A" op)))))) 93 ((logical? expr) 94 (let ((left (evaluate (logical-left expr) env)) 95 (op (token-type (logical-operator expr)))) 96 (case op 97 ((OR) 98 (if (truthy? left) 99 left 100 (evaluate (logical-right expr) env))) 101 ((AND) 102 (if (truthy? left) 103 (evaluate (logical-right expr) env) 104 left))))) 105 ((binary? expr) 106 (let ((left (evaluate (binary-left expr) env)) 107 (right (evaluate (binary-right expr) env)) 108 (op (token-type (binary-operator expr)))) 109 (case op 110 ((GREATER) 111 (assert-nums op left right) 112 (> left right)) 113 ((GREATER_EQUAL) 114 (assert-nums op left right) 115 (>= left right)) 116 ((LESS) 117 (assert-nums op left right) 118 (< left right)) 119 ((LESS_EQUAL) 120 (assert-nums op left right) 121 (<= left right)) 122 ((BANG_EQUAL) (not (lox-equal? left right))) 123 ((EQUAL_EQUAL) (lox-equal? left right)) 124 ((MINUS) 125 (assert-nums op left right) 126 (- left right)) 127 ((PLUS) 128 (cond 129 ((and (string? left) (string? right)) (string-append left right)) 130 ((and (number? left) (number? right)) (+ left right)) 131 (else (runtime-err! (format "Bad types for plus ~A" expr))))) 132 ((SLASH) 133 (assert-nums op left right) 134 (/ left right)) 135 ((STAR) 136 (assert-nums op left right) 137 (* left right)) 138 (else (runtime-err! (format "Unknown bin op ~A" op)))))) 139 (else (runtime-err! (format "Unknown expr type ~A" expr))))) 140 141 (define (lox-print val) 142 (print (cond 143 ((null? val) "nil") 144 ((eq? val #f) "false") 145 ((eq? val #t) "true") 146 (else val)))) 147 148 (define (execute stmt env) 149 (cond 150 ((print-stmt? stmt) 151 (let ((res (evaluate (print-stmt-value stmt) env))) 152 (lox-print res) 153 '())) 154 ((var-stmt? stmt) 155 (let ((value 156 (if (null? (var-stmt-init stmt)) 157 '() 158 (evaluate (var-stmt-init stmt) env)))) 159 (env-def! env (token-lexeme (var-stmt-name stmt)) value)) 160 '()) 161 ((expr-stmt? stmt) 162 (let ((res (evaluate (expr-stmt-value stmt) env))) 163 (if in-repl (lox-print res)) 164 '())) 165 ((block? stmt) 166 (let ((new-env (make-env env))) 167 (let loop ((stmts (block-stmts stmt))) 168 (if (null? stmts) 169 '() ; TODO: Why are we still returning null from all these? 170 (begin 171 (execute (car stmts) new-env) 172 (loop (cdr stmts))))))) 173 ((if-stmt? stmt) 174 (if (truthy? (evaluate (if-stmt-cond-expr stmt) env)) 175 (execute (if-stmt-then-stmt stmt) env) 176 (if (not (null? (if-stmt-else-stmt stmt))) 177 (execute (if-stmt-else-stmt stmt) env) 178 '()))) 179 ((while-stmt? stmt) 180 (let loop () 181 (if (truthy? (evaluate (while-stmt-cond-expr stmt) env)) 182 (begin 183 (execute (while-stmt-body-stmt stmt) env) 184 (loop)) 185 '()))) 186 (else (runtime-err! (format "Unknown stmt ~A" stmt))))) 187 188 ;; Save the global-env outside interpret so that it persists in the REPL 189 (define global-env (make-env #f)) 190 191 (define (interpret stmts) 192 (call/cc (lambda (cc) 193 (set! interpreter-abort cc) 194 (let loop ((sts stmts)) 195 (if (not (null? sts)) 196 (begin (execute (car sts) global-env) 197 (loop (cdr sts))))))))