Working (basic) lisp parser in lisp

1 files changed, 134 insertions, 14 deletions

diff --git a/tests/lispparser.lisp b/tests/lispparser.lisp
index 533e92f..7fc8aa1 100644
--- a/tests/lispparser.lisp
+++ b/tests/lispparser.lisp
@@ -24,7 +24,7 @@
     (let ((style (cond
                     (= clr 'red) "31"
                     (= clr 'yellow) "33"
-                    (= clr 'blue) "34;1"
+                    (= clr 'blue) "34"
                     (error "Unknown color in ansi-color" clr))))
         (concat (concat "\x1B[" (concat style "m")) (concat str "\x1B[0m"))))
 
@@ -118,6 +118,7 @@
             (parse-string-contents rest (concat yet ch)))))
 
 ; deftype token = ('tag <field>), where the type of <field> depends on the tag
+;   ('open '()) ('close '()) ('string "text") ('number 123) ('name "name")
 ; string -> (token string[rest])
 (define next-token (str)
     (let ((ch (substr 0 1 str))
@@ -145,6 +146,17 @@
                         (list (list 'name (concat ch restword)) rest2)))
             (error "Invalid token" ch))))
 
+; string -> (list token...)
+(define tokenise (str)
+    (let ((helper (lambdarec rec (str2 rev-prefix)
+                        (let ((pair (next-token str2)))
+                            (if (null? pair)
+                                (reverse rev-prefix)
+                                (let ((token (car pair))
+                                      (rest (cadr pair)))
+                                    (rec rest (cons token rev-prefix))))))))
+     (helper str '())))
+
 ; token -> string
 (define pretty-token (token)
     (let ((tag (car token))
@@ -162,16 +174,124 @@
                 field
             (error "Invalid token tag in pretty-token" tag))))
 
-(define go (lambdarec rec (str)
-    (let ((pair (next-token str)))
-        (if (null? pair)
-            '()
-            (let ((token (car pair))
-                  (rest (cadr pair)))
-                (do
-                    (sys-put-string stdout (pretty-token token))
-                    (sys-put-string stdout " ")
-                    (rec rest)))))))
-
-(go (read-file "tests/f.lisp"))
-(print)
+; tokens -> string
+(define pretty-token-list (tokens)
+    (if (null? tokens)
+        ""
+        (concat (pretty-token (car tokens))
+                (concat " " (pretty-token-list (cdr tokens))))))
+
+; (define logged-token-fn (name fn)
+;     (lambda (x)
+;         (do
+;             (print name (pretty-token-list x))
+;             (let ((res (fn x)))
+;                 (do
+;                     (print "->" name (car res) (pretty-token-list (cadr res)))
+;                     res)))))
+
+(define logged-token-fn (name fn) fn)
+
+(declare parse-sexpr)
+
+; deftype item = ('tag <field>), where the type of <field> depends on the tag
+;   ('string "text") ('number 123) ('name "name") ('sexpr (list item...))
+; tokens -> (item tokens[rest])
+(define parse-item (logged-token-fn "parse-item" (lambda (tokens)
+    (if (null? tokens)
+        (error "Expected value, not end-of-file")
+        (let ((tag (car (car tokens))))
+            (cond
+                (= tag 'open)
+                    (parse-sexpr tokens)
+                (= tag 'close)
+                    (error "Unexpected close parenthesis")
+                (= tag 'string)
+                    (list (car tokens) (cdr tokens))
+                (= tag 'number)
+                    (list (car tokens) (cdr tokens))
+                (= tag 'name)
+                    (list (car tokens) (cdr tokens))
+                (error "Invalid token tag?")))))))
+
+; tokens -> (list[items] tokens[rest])
+(define parse-items (logged-token-fn "parse-items" (lambda (tokens)
+    (cond
+        (null? tokens)
+            (list '() '())
+        (= (car (car tokens)) 'close)
+            (list '() tokens)
+        (let ((item-pair (parse-item tokens)))
+            (if (null? item-pair)
+                (error "??? () from parse-item?")
+                (let ((items-pair (parse-items (cadr item-pair))))
+                    (list (cons (car item-pair) (car items-pair)) (cadr items-pair)))))))))
+
+; tokens -> (list[items] tokens[rest])
+(define parse-sexpr (logged-token-fn "parse-sexpr" (lambda (tokens)
+    (if (null? tokens)
+        '()
+        (if (!= (car (car tokens)) 'open)
+            (error "Expected s-expression")
+            (let ((items-pair (parse-items (cdr tokens)))
+                  (items (car items-pair))
+                  (rest (cadr items-pair)))
+                (if (null? rest)
+                    (error "Missing close parenthesis at end of file")
+                    (if (!= (car (car rest)) 'close)
+                        (error "Expected close parenthesis to end sexpr")
+                        (list (list 'list items) (cdr rest))))))))))
+
+; tokens -> list[items]
+(define parse-program (tokens)
+    (let ((pair (parse-items tokens))
+          (items (car pair))
+          (rest (cadr pair)))
+        (if (not (null? rest))
+            (error "??? Unrecognised extra tokens at end of file")
+            (cons 'program items))))
+
+; ast -> string
+(define pretty-ast (ast)
+    (let ((isnotnl? (lambda (ch) (!= ch "\n")))
+          (indent (lambdarec rec (str)
+                        (let ((line (take-while isnotnl? str))
+                              (rest (drop-while isnotnl? str)))
+                            (if (= rest "")
+                                line
+                                (concat line
+                                        (concat "\n    " (rec (substr 1 -1 rest))))))))
+          (indent-items (lambdarec rec (items)
+                            (cond
+                                (null? items)
+                                    ""
+                                (null? (cdr items))
+                                    (indent (pretty-ast (car items)))
+                                (concat (indent (pretty-ast (car items)))
+                                        (concat "\n    " (rec (cdr items)))))))
+          (print-program (lambdarec rec (items)
+                            (cond
+                                (null? items)
+                                    ""
+                                (null? (cdr items))
+                                    (pretty-ast (car items))
+                                (concat (pretty-ast (car items))
+                                        (concat "\n" (rec (cdr items))))))))
+        (cond
+            (= (car ast) 'program)
+                (print-program (cdr ast))
+            (= (car ast) 'list)
+                (concat "(" (concat (indent-items (cadr ast)) ")"))
+            (= (car ast) 'string)
+                (pretty-token ast)
+            (= (car ast) 'number)
+                (pretty-token ast)
+            (= (car ast) 'name)
+                (pretty-token ast)
+            (error "Unrecognised AST type in pretty-ast" (car ast)))))
+
+(let ((tokens (tokenise (read-file "tests/f.lisp"))))
+    (do
+        ; (print (pretty-token-list tokens))
+        ; (print (parse-program tokens))
+        (print (pretty-ast (parse-program tokens)))))