commit a11d38c70322ff1e99e783a4e7a776bb80b8b56f (patch)
parent 5e57cfe6bf28e2038efa9dfc775bb435f3627e0f
Author: Alex Karle <alex@alexkarle.com>
Date: Thu, 17 Nov 2022 15:55:58 -0500
Add full block environments! (ch8.5)
This implements the parser for blocks as well as the necessary
interpreter bits!
Check it out!
$ cat examples/scope.lox
var a = "global a";
var b = "global b";
var c = "global c";
{
var a = "outer a";
var b = "outer b";
{
var a = "inner a";
print a;
print b;
print c;
}
print a;
print b;
print c;
}
print a;
print b;
print c;
$ ./fisl.scm examples/scope.lox
inner a
outer b
global c
outer a
outer b
global c
global a
global b
global c
Diffstat:
3 files changed, 78 insertions(+), 29 deletions(-)
diff --git a/examples/scope.lox b/examples/scope.lox
@@ -0,0 +1,19 @@
+var a = "global a";
+var b = "global b";
+var c = "global c";
+{
+ var a = "outer a";
+ var b = "outer b";
+ {
+ var a = "inner a";
+ print a;
+ print b;
+ print c;
+ }
+ print a;
+ print b;
+ print c;
+}
+print a;
+print b;
+print c;
diff --git a/interpreter.scm b/interpreter.scm
@@ -5,8 +5,6 @@
(define interpreter-abort #f)
-(define global-env (make-env #f))
-
(define (make-env parent)
(let ((ht (make-hash-table)))
(lambda (action)
@@ -56,24 +54,24 @@
(or (and (number? x) (number? y))
(runtime-err! (format "Operands must be numbers ~A ~A ~A" x op y))))
-(define (evaluate expr)
+(define (evaluate expr env)
(cond
((literal? expr) (literal-value expr))
((grouping? expr)
- (evaluate (grouping-expression expr)))
+ (evaluate (grouping-expression expr) env))
((variable? expr)
(let ((tok (variable-name expr)))
- (env-get global-env (token-lexeme tok))))
+ (env-get env (token-lexeme tok))))
((assignment? expr)
(let ((tok (assignment-name expr)))
- (if (env-exists? global-env (token-lexeme tok))
- (let ((res (evaluate (assignment-value expr))))
- (env-set! global-env (token-lexeme tok) res)
+ (if (env-exists? env (token-lexeme tok))
+ (let ((res (evaluate (assignment-value expr) env)))
+ (env-set! env (token-lexeme tok) res)
res)
(runtime-err! (format "Unbound variable ~A at line ~A"
(token-lexeme tok) (token-line tok))))))
((unary? expr)
- (let ((right (evaluate (unary-right expr)))
+ (let ((right (evaluate (unary-right expr) env))
(op (token-type (unary-operator expr))))
(case op
((BANG) (not (truthy? right)))
@@ -82,8 +80,8 @@
(- right))
(else (runtime-err! (format "Unknown unary op ~A" op))))))
((binary? expr)
- (let ((left (evaluate (binary-left expr)))
- (right (evaluate (binary-right expr)))
+ (let ((left (evaluate (binary-left expr) env))
+ (right (evaluate (binary-right expr) env))
(op (token-type (binary-operator expr))))
(case op
((GREATER)
@@ -124,29 +122,38 @@
((eq? val #t) "true")
(else val))))
-(define (execute stmt)
+(define (execute stmt env)
(cond
((print-stmt? stmt)
- (let ((res (evaluate (print-stmt-value stmt))))
+ (let ((res (evaluate (print-stmt-value stmt) env)))
(lox-print res)
'()))
((var-stmt? stmt)
(let ((value
(if (null? (var-stmt-init stmt))
'()
- (evaluate (var-stmt-init stmt)))))
- (env-set! global-env (token-lexeme (var-stmt-name stmt)) value))
+ (evaluate (var-stmt-init stmt) env))))
+ (env-set! env (token-lexeme (var-stmt-name stmt)) value))
'())
((expr-stmt? stmt)
- (let ((res (evaluate (expr-stmt-value stmt))))
+ (let ((res (evaluate (expr-stmt-value stmt) env)))
(if in-repl (lox-print res))
'()))
+ ((block? stmt)
+ (let ((new-env (make-env env)))
+ (let loop ((stmts (block-stmts stmt)))
+ (if (null? stmts)
+ '() ; TODO: Why are we still returning null from all these?
+ (begin
+ (execute (car stmts) new-env)
+ (loop (cdr stmts)))))))
(else (runtime-err! (format "Unknown stmt ~A" stmt)))))
(define (interpret stmts)
(call/cc (lambda (cc)
(set! interpreter-abort cc)
- (let loop ((sts stmts))
- (if (not (null? sts))
- (begin (execute (car sts))
- (loop (cdr sts))))))))
+ (let ((global-env (make-env #f)))
+ (let loop ((sts stmts))
+ (if (not (null? sts))
+ (begin (execute (car sts) global-env)
+ (loop (cdr sts)))))))))
diff --git a/parser.scm b/parser.scm
@@ -41,18 +41,24 @@
(define-record print-stmt value)
(define-record expr-stmt value)
(define-record var-stmt name init)
+(define-record block stmts)
(set-record-printer! print-stmt
- (lambda (x out)
- (fprintf out "(print ~A)" (print-stmt-value x))))
+ (lambda (x out)
+ (fprintf out "(print ~A)" (print-stmt-value x))))
(set-record-printer! expr-stmt
- (lambda (x out)
- (fprintf out "(expr ~A)" (expr-stmt-value x))))
+ (lambda (x out)
+ (fprintf out "(expr ~A)" (expr-stmt-value x))))
(set-record-printer! var-stmt
- (lambda (x out)
- (fprintf out "(var ~A ~A)" (var-stmt-name x) (var-stmt-init x))))
+ (lambda (x out)
+ (fprintf out "(var ~A ~A)" (var-stmt-name x) (var-stmt-init x))))
+
+(set-record-printer! block
+ (lambda (x out)
+ (fprintf out "(block ~A)" (block-stmts x))))
+
;; helper to check if first is of types
@@ -77,9 +83,14 @@
(parse-err! tokens "expected variable name")))
(define (parse-statement tokens)
- (if (top-type? tokens '(PRINT))
- (parse-print-statement (cdr tokens))
- (parse-expression-statement tokens)))
+ (cond ((top-type? tokens '(PRINT))
+ (parse-print-statement (cdr tokens)))
+ ((top-type? tokens '(LEFT_BRACE))
+ (let-values (((stmts toks) (parse-block (cdr tokens))))
+ ;; TODO: return the block record instead of stmts? Not the
+ ;; way the book does it but seems cleaner :thinking:
+ (values (make-block stmts) toks)))
+ (else (parse-expression-statement tokens))))
;; Used for print and expr statements, which have the same formula
(define (parse-generic-stmt tokens maker)
@@ -96,6 +107,18 @@
(define (parse-expression-statement tokens)
(parse-generic-stmt tokens make-expr-stmt))
+(define (parse-block tokens)
+ (let loop ((stmts '()) (toks tokens))
+ (if (top-type? toks '(RIGHT_BRACE))
+ (values stmts (cdr toks))
+ (if (top-type? toks '(EOF))
+ (parse-err! toks "expected '}' after block")
+ (let-values (((decl rest) (parse-declaration toks)))
+ ;; TODO: can we do this with cons instead of append?
+ ;; I don't think so, given that we'd need to (cons decl (loop ...))
+ ;; but (loop) returns multiple values (sigh)
+ (loop (append stmts (list decl)) rest))))))
+
(define (parse-assignment expr toks)
(let-values (((e2 t2) (parse-equality expr toks)))
(if (top-type? t2 '(EQUAL))
