From 153b8624339bcd3859746e062303cf174e2ae939 Mon Sep 17 00:00:00 2001
From: Alex Karle <alex@alexkarle.com>
Date: Tue, 25 Oct 2022 23:52:42 -0400
Subject: [PATCH] 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 :)
---
 examples/ch6.lox |  2 ++
 fisl.scm         |  3 +--
 parser.scm       | 81 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----
 scanner.scm      |  7 ++++++-
 4 files changed, 86 insertions(+), 7 deletions(-)
 create mode 100644 examples/ch6.lox

diff --git a/examples/ch6.lox b/examples/ch6.lox
new file mode 100644
index 0000000..50cb3ba
--- /dev/null
+++ 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
index 3094da1..cf18336 100755
--- 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
index d0b8ee1..6688a0e 100644
--- 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
index d0732d1..d2efed4 100644
--- 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
--
libgit2 1.1.1