commit c1dea8b40dc6efc6a7aea56f1bc9f2b3f6a64254 (patch)
parent 8f0650f25245b34f87c91135f6a11b3b6ab18480
Author: Alex Karle <alex@alexkarle.com>
Date: Tue, 1 Nov 2022 21:49:18 -0400
refactor: Drop use of CHICKEN modules (for now)
I've been toying around with Emacs and running an interactive repl
that I can C-x C-e to update functions I just changed (without having
to respawn the full process, etc.
This is a bit easier when not using CHICKEN modules (effectively
exporting everything for interaction with in the repl!).
I may go back at some point (hiding implementation is good), but for
now this is nice!
Diffstat:
| M | fisl.scm | | | 18 | +++++++----------- |
| M | interpreter.scm | | | 173 | ++++++++++++++++++++++++++++++++++++++----------------------------------------- |
| M | parser.scm | | | 253 | ++++++++++++++++++++++++++++++++++++------------------------------------------- |
| M | scanner.scm | | | 236 | ++++++++++++++++++++++++++++++++++++++----------------------------------------- |
| M | util.scm | | | 27 | ++++++++++++--------------- |
5 files changed, 329 insertions(+), 378 deletions(-)
diff --git a/fisl.scm b/fisl.scm
@@ -1,24 +1,20 @@
#!/usr/local/bin/chicken-csi -ss
;; fisl -- fisl is scheme lox
-(load "scanner.scm")
-(load "util.scm")
-(load "parser.scm")
-(load "interpreter.scm")
-
(import (chicken io)
(chicken base)
- (chicken format)
- scanner
- parser
- interpreter
- util)
+ (chicken format))
+
+(include "util.scm")
+(include "scanner.scm")
+(include "parser.scm")
+(include "interpreter.scm")
(define (run code fname)
(let ((tokens (scan code fname)))
(if tokens
(let ((stmts (parse tokens fname)))
(if stmts
- (print (interpret stmts)))))))
+ (interpret stmts))))))
(define (run-prompt)
(display "> ")
diff --git a/interpreter.scm b/interpreter.scm
@@ -1,99 +1,92 @@
-(module interpreter (interpret)
+;; interpreter.scm -- evaluates parsed statements
+(import (chicken format))
- (import scheme
- util
- scanner
- parser
- (chicken base)
- (chicken format))
+(define interpreter-abort #f)
- (define abort #f)
+(define (runtime-err! msg)
+ (err! msg)
+ (interpreter-abort #f))
- (define (runtime-err! msg)
- (err! msg)
- (abort #f))
+(define (truthy? x)
+ (not (or (null? x) (eq? x #f))))
- (define (truthy? x)
- (not (or (null? x) (eq? x #f))))
+(define (lox-equal? a b)
+ (cond
+ ((and (null? a) (null? b)) #t)
+ ((null? a) #f)
+ (else (equal? a b))))
- (define (lox-equal? a b)
- (cond
- ((and (null? a) (null? b)) #t)
- ((null? a) #f)
- (else (equal? a b))))
+(define (assert-num op x)
+ ;; TODO: use call/cc to not abort the process
+ (or (number? x) (runtime-err! (format "Operand must be a number ~A ~A" op x))))
- (define (assert-num op x)
- ; TODO: use call/cc to not abort the process
- (or (number? x) (runtime-err! (format "Operand must be a number ~A ~A" op x))))
+(define (assert-nums op x y)
+ ;; TODO: use call/cc to not abort the process
+ (or (and (number? x) (number? y))
+ (runtime-err! (format "Operands must be numbers ~A ~A ~A" x op y))))
- (define (assert-nums op x y)
- ; TODO: use call/cc to not abort the process
- (or (and (number? x) (number? y))
- (runtime-err! (format "Operands must be numbers ~A ~A ~A" x op y))))
+(define (evaluate expr)
+ ;; TODO: put these on the types themselves? like methods
+ (cond
+ ((literal? expr) (literal-value expr))
+ ((grouping? expr)
+ (evaluate (grouping-expression expr)))
+ ((unary? expr)
+ (let ((right (evaluate (unary-right expr)))
+ (op (token-type (unary-operator expr))))
+ (case op
+ ((BANG) (not (truthy? right)))
+ ((MINUS)
+ (assert-num op right)
+ (- right))
+ (else (runtime-err! (format "Unknown unary op ~A" op))))))
+ ((binary? expr)
+ (let ((left (evaluate (binary-left expr)))
+ (right (evaluate (binary-right expr)))
+ (op (token-type (binary-operator expr))))
+ (case op
+ ((GREATER)
+ (assert-nums op left right)
+ (> left right))
+ ((GREATER_EQUAL)
+ (assert-nums op left right)
+ (>= left right))
+ ((LESS)
+ (assert-nums op left right)
+ (< left right))
+ ((LESS_EQUAL)
+ (assert-nums op left right)
+ (<= left right))
+ ((BANG_EQUAL) (not (lox-equal? left right)))
+ ((EQUAL_EQUAL) (lox-equal? left right))
+ ((MINUS)
+ (assert-nums op left right)
+ (- left right))
+ ((PLUS)
+ (cond
+ ((and (string? left) (string? right)) (string-append left right))
+ ((and (number? left) (number? right)) (+ left right))
+ (else (runtime-err! (format "Bad types for plus ~A" expr)))))
+ ((SLASH)
+ (assert-nums op left right)
+ (/ left right))
+ ((STAR)
+ (assert-nums op left right)
+ (* left right))
+ (else (runtime-err! (format "Unknown bin op ~A" op))))))
+ (else (runtime-err! (format "Unknown expr type ~A" expr)))))
- (define (evaluate expr)
- ; TODO: put these on the types themselves? like methods
- (cond
- ((literal? expr) (literal-value expr))
- ((grouping? expr)
- (evaluate (grouping-expression expr)))
- ((unary? expr)
- (let ((right (evaluate (unary-right expr)))
- (op (token-type (unary-operator expr))))
- (case op
- ((BANG) (not (truthy? right)))
- ((MINUS)
- (assert-num op right)
- (- right))
- (else (runtime-err! (format "Unknown unary op ~A" op))))))
- ((binary? expr)
- (let ((left (evaluate (binary-left expr)))
- (right (evaluate (binary-right expr)))
- (op (token-type (binary-operator expr))))
- (case op
- ((GREATER)
- (assert-nums op left right)
- (> left right))
- ((GREATER_EQUAL)
- (assert-nums op left right)
- (>= left right))
- ((LESS)
- (assert-nums op left right)
- (< left right))
- ((LESS_EQUAL)
- (assert-nums op left right)
- (<= left right))
- ((BANG_EQUAL) (not (lox-equal? left right)))
- ((EQUAL_EQUAL) (lox-equal? left right))
- ((MINUS)
- (assert-nums op left right)
- (- left right))
- ((PLUS)
- (cond
- ((and (string? left) (string? right)) (string-append left right))
- ((and (number? left) (number? right)) (+ left right))
- (else (runtime-err! (format "Bad types for plus ~A" expr)))))
- ((SLASH)
- (assert-nums op left right)
- (/ left right))
- ((STAR)
- (assert-nums op left right)
- (* left right))
- (else (runtime-err! (format "Unknown bin op ~A" op))))))
- (else (runtime-err! (format "Unknown expr type ~A" expr)))))
+(define (execute stmt)
+ (cond
+ ((print-stmt? stmt)
+ (print (evaluate (print-stmt-value stmt)))
+ '())
+ (else (runtime-err! (format "Unknown stmt ~A" stmt)))))
- (define (execute stmt)
- (cond
- ((print-stmt? stmt)
- (print (evaluate (print-stmt-value stmt)))
- '())
- (else (runtime-err! (format "Unknown stmt ~A" stmt)))))
-
- (define (interpret stmts)
- (call/cc (lambda (cc)
- (set! abort cc)
- (let loop ((sts stmts))
- (if (not (null? sts))
- (begin (execute (car sts))
- (loop (cdr sts))))))))
-)
+(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))))))))
diff --git a/parser.scm b/parser.scm
@@ -1,68 +1,46 @@
-(module parser (parse
- ; TODO: figure out a better way to export these :(
- ; maybe ditch records?
- print-stmt?
- print-stmt-value
- expr-stmt?
- expr-stmt-value
- binary?
- binary-left
- binary-right
- binary-operator
- grouping?
- grouping-expression
- literal?
- literal-value
- unary?
- unary-operator
- unary-right)
-
- (import scheme
- scanner
- util
- (chicken base)
- (chicken format))
-
- (define abort #f)
-
- (define-record binary left operator right)
- (set-record-printer! binary
- (lambda (x out) (fprintf out "(~A ~S ~S)"
- (token-lexeme (binary-operator x))
- (binary-left x)
- (binary-right x))))
-
- (define-record grouping expression)
- (set-record-printer! grouping
- (lambda (x out) (fprintf out "(group ~S)" (grouping-expression x))))
-
- (define-record literal value)
- (set-record-printer! literal
- (lambda (x out) (fprintf out "~S" (literal-value x))))
-
- (define-record unary operator right)
- (set-record-printer! unary
- (lambda (x out) (fprintf out "(~A ~S)"
- (token-lexeme (unary-operator x))
- (unary-right x))))
-
- (define-record print-stmt value)
- (set-record-printer! print-stmt
- (lambda (x out)
- (fprintf out "(print ~A)" (print-stmt-value x))))
-
- (define-record expr-stmt value)
- (set-record-printer! expr-stmt
- (lambda (x out)
- (fprintf out "(expr ~A)" (expr-stmt-value x))))
-
- (define (top-type? tokens types)
- (memq (token-type (car tokens)) types))
-
- (define (parse tokens fname)
-
- (define (panic tok msg)
- (if (eq? (token-type tok) 'EOF)
+;; parser.scm -- parser routines
+(import (chicken format))
+
+(define parser-abort #f)
+
+(define-record binary left operator right)
+(set-record-printer! binary
+ (lambda (x out) (fprintf out "(~A ~S ~S)"
+ (token-lexeme (binary-operator x))
+ (binary-left x)
+ (binary-right x))))
+
+(define-record grouping expression)
+(set-record-printer! grouping
+ (lambda (x out) (fprintf out "(group ~S)" (grouping-expression x))))
+
+(define-record literal value)
+(set-record-printer! literal
+ (lambda (x out) (fprintf out "~S" (literal-value x))))
+
+(define-record unary operator right)
+(set-record-printer! unary
+ (lambda (x out) (fprintf out "(~A ~S)"
+ (token-lexeme (unary-operator x))
+ (unary-right x))))
+
+(define-record print-stmt value)
+(set-record-printer! print-stmt
+ (lambda (x out)
+ (fprintf out "(print ~A)" (print-stmt-value x))))
+
+(define-record expr-stmt value)
+(set-record-printer! expr-stmt
+ (lambda (x out)
+ (fprintf out "(expr ~A)" (expr-stmt-value x))))
+
+(define (top-type? tokens types)
+ (memq (token-type (car tokens)) types))
+
+(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
@@ -70,96 +48,95 @@
"Error at"
(token-lexeme tok)
msg)))
- ; TODO: synchronize instead of abort
- (abort #f))
-
- (define (statement tokens)
- (if (top-type? tokens '(PRINT))
- (print-statement (cdr tokens))
- (expression-statement tokens)))
-
- (define (print-statement tokens)
- (let ((ret (expression '() tokens)))
- (let ((expr (car ret)) (toks (cdr ret)))
- (if (top-type? toks '(SEMICOLON))
- (cons (make-print-stmt expr) (cdr toks))
- (panic (car toks) "expected ;")))))
-
- (define (expression-statement tokens)
- (let ((ret (expression '() tokens)))
- (let ((expr (car ret)) (toks (cdr ret)))
- (if (top-type? toks '(SEMICOLON))
- (cons (make-expr-stmt expr) (cdr toks))
- (panic (car toks) "expected ;")))))
-
- (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))
+ ; TODO: synchronize instead of abort
+ (parser-abort #f))
+
+ (define (statement tokens)
+ (if (top-type? tokens '(PRINT))
+ (print-statement (cdr tokens))
+ (expression-statement tokens)))
+
+ (define (print-statement tokens)
+ (let ((ret (expression '() tokens)))
+ (let ((expr (car ret)) (toks (cdr ret)))
+ (if (top-type? toks '(SEMICOLON))
+ (cons (make-print-stmt expr) (cdr toks))
+ (panic (car toks) "expected ;")))))
+
+ (define (expression-statement tokens)
+ (let ((ret (expression '() tokens)))
+ (let ((expr (car ret)) (toks (cdr ret)))
+ (if (top-type? toks '(SEMICOLON))
+ (cons (make-expr-stmt expr) (cdr toks))
+ (panic (car toks) "expected ;")))))
+
+ (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))
+ (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))
+ (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))
+ (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))
+ (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!
- (call/cc (lambda (cc)
- (set! abort cc)
- (let loop ((toks tokens))
- (if (not (top-type? toks '(EOF)))
- (let ((ret (statement toks)))
- (cons (car ret) (loop (cdr ret))))
- '())))))
-)
+ (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!
+ (call/cc (lambda (cc)
+ (set! parser-abort cc)
+ (let loop ((toks tokens))
+ (if (not (top-type? toks '(EOF)))
+ (let ((ret (statement toks)))
+ (cons (car ret) (loop (cdr ret))))
+ '())))))
diff --git a/scanner.scm b/scanner.scm
@@ -1,140 +1,128 @@
-(load "util.scm")
+;; scanner.scm -- tokenizes input
+(import (chicken format))
-(module scanner (scan
- make-token
- token-type
- token-literal
- token-lexeme
- token-line)
+;; Auto-generates the scaffolding getters and setters
+;; make-token, token-type, set-token-type!, etc
+(define-record token type lexeme literal line)
+(set-record-printer! token (lambda (t out)
+ (fprintf out "#,(token type:~S lex:~S lit:~S ln:~S)"
+ (token-type t) (token-lexeme t) (token-literal t) (token-line t))))
- (import scheme
- util
- (chicken base)
- (chicken format))
+(define (digit? c)
+ (and c (char<=? #\0 c) (char>=? #\9 c)))
- ; Auto-generates the scaffolding getters and setters
- ; make-token, token-type, set-token-type!, etc
- (define-record token type lexeme literal line)
- (set-record-printer! token (lambda (t out)
- (fprintf out "#,(token type:~S lex:~S lit:~S ln:~S)"
- (token-type t) (token-lexeme t) (token-literal t) (token-line t))))
+(define (alpha? c)
+ (and c
+ (or
+ (eq? c #\_)
+ (and (char<=? #\a c) (char>=? #\z c))
+ (and (char<=? #\A c) (char>=? #\Z c)))))
- (define (digit? c)
- (and c (char<=? #\0 c) (char>=? #\9 c)))
+(define (get-keyword k)
+ (let ((kpair (assoc k '(("and" AND)
+ ("class" CLASS)
+ ("else" ELSE)
+ ("false" FALSE)
+ ("for" FOR)
+ ("fun" FUN)
+ ("if" IF)
+ ("nil" NIL)
+ ("or" OR)
+ ("print" PRINT)
+ ("return" RETURN)
+ ("super" SUPER)
+ ("this" THIS)
+ ("true" TRUE)
+ ("var" VAR)
+ ("while" WHILE)))))
+ (if kpair (cadr kpair) #f)))
- (define (alpha? c)
- (and c
- (or
- (eq? c #\_)
- (and (char<=? #\a c) (char>=? #\z c))
- (and (char<=? #\A c) (char>=? #\Z c)))))
+(define (alnum? c)
+ (and c (or (alpha? c) (digit? c))))
- (define (get-keyword k)
- (let ((kpair (assoc k '(("and" AND)
- ("class" CLASS)
- ("else" ELSE)
- ("false" FALSE)
- ("for" FOR)
- ("fun" FUN)
- ("if" IF)
- ("nil" NIL)
- ("or" OR)
- ("print" PRINT)
- ("return" RETURN)
- ("super" SUPER)
- ("this" THIS)
- ("true" TRUE)
- ("var" VAR)
- ("while" WHILE)))))
- (if kpair (cadr kpair) #f)))
-
- (define (alnum? c)
- (and c (or (alpha? c) (digit? c))))
-
- (define (scan src fname)
- (define (peek i)
- ; safe string-ref
- (if (< i (string-length src))
+(define (scan src fname)
+ (define (peek i)
+ ; safe string-ref
+ (if (< i (string-length src))
(string-ref src i)
#f))
- (define (get-tokens s i line in)
- ; Gets all tokens after 'start', tracks state in i (current char), line, in
- (define (tok-range type s2 i2)
- ; Helper to make a token, cons it to our list, and recurse with fresh state
- (let ((text (substring src s2 (add1 i2))))
- (let ((tok (cond
- ((eq? type 'STRING) (make-token type text (substring src (add1 s2) i2) line))
- ((eq? type 'NUMBER) (make-token type text (string->number text) line))
- ((eq? type 'IDENTIFIER)
- (let ((k (get-keyword text)))
- (if k
- (make-token k text #f line)
- (make-token 'IDENTIFIER text #f line))))
- (else (make-token type text #f line)))))
- (cons tok (get-tokens (add1 i2) (add1 i2) line #f)))))
+ (define (get-tokens s i line in)
+ ; Gets all tokens after 'start', tracks state in i (current char), line, in
+ (define (tok-range type s2 i2)
+ ; Helper to make a token, cons it to our list, and recurse with fresh state
+ (let ((text (substring src s2 (add1 i2))))
+ (let ((tok (cond
+ ((eq? type 'STRING) (make-token type text (substring src (add1 s2) i2) line))
+ ((eq? type 'NUMBER) (make-token type text (string->number text) line))
+ ((eq? type 'IDENTIFIER)
+ (let ((k (get-keyword text)))
+ (if k
+ (make-token k text #f line)
+ (make-token 'IDENTIFIER text #f line))))
+ (else (make-token type text #f line)))))
+ (cons tok (get-tokens (add1 i2) (add1 i2) line #f)))))
- (define (tok type)
- ; helper to tokenize current span
- (tok-range type s i))
+ (define (tok type)
+ ; helper to tokenize current span
+ (tok-range type s i))
- (define (skip . line2)
- ; Helper to skip this character range
- (get-tokens (add1 i) (add1 i) (optional line2 line) in))
+ (define (skip . line2)
+ ; Helper to skip this character range
+ (get-tokens (add1 i) (add1 i) (optional line2 line) in))
- (define (advance . line2)
- ; Helper to iterate; keeps start but increments range
- (get-tokens s (add1 i) (optional line2 line) in))
+ (define (advance . line2)
+ ; Helper to iterate; keeps start but increments range
+ (get-tokens s (add1 i) (optional line2 line) in))
- (let ((c (peek i)) (n (peek (add1 i))))
- (if (and (not in) (not c))
+ (let ((c (peek i)) (n (peek (add1 i))))
+ (if (and (not in) (not c))
(list (make-token 'EOF "" #f line))
(cond
- ((eq? in 'comment) (if (or (not c) (eq? #\newline c))
- (get-tokens (add1 i) (add1 i) (add1 line) #f)
- (advance)))
- ((eq? in 'string)
- (cond
- ((not c) (err! (format "~A:~A:unterminated string" fname line)))
- ((eq? #\" c) (tok 'STRING))
- ((eq? #\newline c) (advance (add1 line)))
- (else (advance))))
- ((eq? in 'number)
- (cond
- ((digit? c) (advance))
- ((eq? #\. c) (get-tokens s (add1 i) line 'decimal))
- (else (tok-range 'NUMBER s (sub1 i)))))
- ((eq? in 'decimal)
- (cond
- ((digit? c) (advance))
- (else (tok-range 'NUMBER s (sub1 i)))))
- ((eq? in 'alpha)
- (cond
- ((alnum? c) (advance))
- (else (tok-range 'IDENTIFIER s (sub1 i)))))
- (else (cond
- ((eq? #\( c) (tok 'LEFT_PAREN))
- ((eq? #\) c) (tok 'RIGHT_PAREN))
- ((eq? #\{ c) (tok 'LEFT_BRACE))
- ((eq? #\} c) (tok 'RIGHT_BRACE))
- ((eq? #\, c) (tok 'COMMA))
- ((eq? #\. c) (tok 'DOT))
- ((eq? #\- c) (tok 'MINUS))
- ((eq? #\+ c) (tok 'PLUS))
- ((eq? #\; c) (tok 'SEMICOLON))
- ((eq? #\* c) (tok 'STAR))
- ((eq? #\! c) (if (eq? #\= n) (tok-range 'BANG_EQUAL s (add1 i)) (tok 'BANG)))
- ((eq? #\= c) (if (eq? #\= n) (tok-range 'EQUAL_EQUAL s (add1 i) ) (tok 'EQUAL)))
- ((eq? #\< c) (if (eq? #\= n) (tok-range 'LESS_EQUAL s (add1 i) ) (tok 'LESS)))
- ((eq? #\> c) (if (eq? #\= n) (tok-range 'GREATER_EQUAL s (add1 i) ) (tok 'GREATER)))
- ((eq? #\/ c) (if (eq? #\/ n) (get-tokens s (add1 i) line 'comment) (tok 'SLASH)))
- ((eq? #\" c) (get-tokens s (add1 i) line 'string))
- ((digit? c) (get-tokens s (add1 i) line 'number))
- ((alpha? c) (get-tokens s (add1 i) line 'alpha))
- ((eq? #\space c) (skip))
- ((eq? #\tab c) (skip))
- ((eq? #\newline c) (skip (add1 line)))
- (else (err! (format "~A:~A:unexpected character: ~A" fname line c)) (skip))))))))
+ ((eq? in 'comment) (if (or (not c) (eq? #\newline c))
+ (get-tokens (add1 i) (add1 i) (add1 line) #f)
+ (advance)))
+ ((eq? in 'string)
+ (cond
+ ((not c) (err! (format "~A:~A:unterminated string" fname line)))
+ ((eq? #\" c) (tok 'STRING))
+ ((eq? #\newline c) (advance (add1 line)))
+ (else (advance))))
+ ((eq? in 'number)
+ (cond
+ ((digit? c) (advance))
+ ((eq? #\. c) (get-tokens s (add1 i) line 'decimal))
+ (else (tok-range 'NUMBER s (sub1 i)))))
+ ((eq? in 'decimal)
+ (cond
+ ((digit? c) (advance))
+ (else (tok-range 'NUMBER s (sub1 i)))))
+ ((eq? in 'alpha)
+ (cond
+ ((alnum? c) (advance))
+ (else (tok-range 'IDENTIFIER s (sub1 i)))))
+ (else (cond
+ ((eq? #\( c) (tok 'LEFT_PAREN))
+ ((eq? #\) c) (tok 'RIGHT_PAREN))
+ ((eq? #\{ c) (tok 'LEFT_BRACE))
+ ((eq? #\} c) (tok 'RIGHT_BRACE))
+ ((eq? #\, c) (tok 'COMMA))
+ ((eq? #\. c) (tok 'DOT))
+ ((eq? #\- c) (tok 'MINUS))
+ ((eq? #\+ c) (tok 'PLUS))
+ ((eq? #\; c) (tok 'SEMICOLON))
+ ((eq? #\* c) (tok 'STAR))
+ ((eq? #\! c) (if (eq? #\= n) (tok-range 'BANG_EQUAL s (add1 i)) (tok 'BANG)))
+ ((eq? #\= c) (if (eq? #\= n) (tok-range 'EQUAL_EQUAL s (add1 i) ) (tok 'EQUAL)))
+ ((eq? #\< c) (if (eq? #\= n) (tok-range 'LESS_EQUAL s (add1 i) ) (tok 'LESS)))
+ ((eq? #\> c) (if (eq? #\= n) (tok-range 'GREATER_EQUAL s (add1 i) ) (tok 'GREATER)))
+ ((eq? #\/ c) (if (eq? #\/ n) (get-tokens s (add1 i) line 'comment) (tok 'SLASH)))
+ ((eq? #\" c) (get-tokens s (add1 i) line 'string))
+ ((digit? c) (get-tokens s (add1 i) line 'number))
+ ((alpha? c) (get-tokens s (add1 i) line 'alpha))
+ ((eq? #\space c) (skip))
+ ((eq? #\tab c) (skip))
+ ((eq? #\newline c) (skip (add1 line)))
+ (else (err! (format "~A:~A:unexpected character: ~A" fname line c)) (skip))))))))
- (get-tokens 0 0 1 #f))
- ) ; end of module
+ (get-tokens 0 0 1 #f))
diff --git a/util.scm b/util.scm
@@ -1,19 +1,16 @@
-(module util (die err! had-err clear-err!)
- (import scheme
- (chicken base)
- (chicken io)
- (chicken format))
+;; util.scm -- shared utils (no deps!)
+(import (chicken format)
+ (chicken io))
- (define had-err #f)
+(define had-err #f)
- (define (err! str)
- (set! had-err #t)
- (fprintf (current-error-port) "~A\n" str))
+(define (err! str)
+ (set! had-err #t)
+ (fprintf (current-error-port) "~A\n" str))
- (define (clear-err!)
- (set! had-err #f))
+(define (clear-err!)
+ (set! had-err #f))
- (define (die str)
- (err! str)
- (exit 1))
- ) ; end of module
+(define (die str)
+ (err! str)
+ (exit 1))
