fisl

commit 153b8624339bcd3859746e062303cf174e2ae939 (patch)
parent 4230b1824fa484286a13bb55068b63ad3656b0bd
Author: Alex Karle <alex@alexkarle.com>
Date:   Tue, 25 Oct 2022 23:52:42 -0400

parser: Add first brittle pass at recursive descent

Again, to a fault I tried NOT to use set! (which means passing
a lot of state in between the functions...). The ugly bit here
means storing both the overall expression AND the resulting tokens
in the return value (since in the act of parsing an expression,
we may consume an unknown number of tokens).

It seems to work though!

$ ./fisl.scm
> (1 + 1) * 2 != 5
(!= (* (group (+ 1 1)) 2) 5)

Look at that beautiful s-expression :)

Diffstat:
A
examples/ch6.lox
 | 
2
++
M
fisl.scm
 | 
3
+--
M
parser.scm
 | 
81
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----
M
scanner.scm
 | 
7
++++++-

4 files changed, 86 insertions(+), 7 deletions(-)
diff --git a/examples/ch6.lox b/examples/ch6.lox
@@ -0,0 +1,2 @@
+// Just an example of the types parsed in ch6!
+-!((1 + 1) * 2 != 5)
diff --git a/fisl.scm b/fisl.scm
@@ -12,8 +12,7 @@
         util)
 
 (define (run code fname)
-  (parse)
-    (map print (scan code fname)))
+  (print (parse (scan code fname))))
 
 (define (run-prompt)
   (display "> ")
diff --git a/parser.scm b/parser.scm
@@ -1,12 +1,16 @@
 (module parser (parse)
 
   (import scheme
+          scanner
           (chicken base)
           (chicken format))
 
   (define-record binary left operator right)
   (set-record-printer! binary
-    (lambda (x out) (fprintf out "(~S ~S ~S)" (binary-operator x) (binary-left x) (binary-right x))))
+    (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
@@ -18,8 +22,77 @@
 
   (define-record unary operator right)
   (set-record-printer! unary
-    (lambda (x out) (fprintf out "(~S ~S)" (unary-operator x) (unary-right x))))
+    (lambda (x out) (fprintf out "(~A ~S)"
+                             (token-lexeme (unary-operator x))
+                             (unary-right x))))
 
-  (define (parse)
-    (print (make-binary (make-unary "-" (make-literal 123)) "*" (make-grouping (make-literal 42)))))
+  (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)
+    (car (expression '() tokens)))
 )
diff --git a/scanner.scm b/scanner.scm
@@ -1,6 +1,11 @@
 (load "util.scm")
 
-(module scanner (scan)
+(module scanner (scan
+                  make-token
+                  token-type
+                  token-literal
+                  token-lexeme
+                  token-line)
 
   (import scheme
           util