Lisp parser in lisp can parse stdlib

2 files changed, 65 insertions, 22 deletions

diff --git a/tests/lispparser.lisp b/tests/lispparser.lisp
index 7fc8aa1..61f4e47 100644
--- a/tests/lispparser.lisp
+++ b/tests/lispparser.lisp
@@ -23,6 +23,7 @@
 (define ansi-color (clr str)
     (let ((style (cond
                     (= clr 'red) "31"
+                    (= clr 'green) "32"
                     (= clr 'yellow) "33"
                     (= clr 'blue) "34"
                     (error "Unknown color in ansi-color" clr))))
@@ -52,7 +53,7 @@
 
 ; char -> bool
 (define iswordchar? (ch)
-    (or (str-elem ch "-_?+/*")
+    (or (str-elem ch "-_?+/*!=<>.")
         (or (lowercase? ch) (uppercase? ch))))
 
 ; char -> bool
@@ -103,7 +104,7 @@
                     (list (chr (16 * h1 + h2)) (substr 3 -1 str)))
             (error "Invalid string escape character " ch))))
 
-; string[input] string[string to prepend to result] -> string[parsed till bare "]
+; string[input] string[string to prepend to result] -> (string[parsed till bare "] string[rest])
 (define parse-string-contents (str yet)
     (let ((ch (substr 0 1 str))
           (rest (substr 1 -1 str)))
@@ -111,14 +112,14 @@
             (= ch "")
                 (error "Non-terminated string in source")
             (= ch "\"")
-                yet
+                (list yet rest)
             (= ch "\\")
                 (let ((pair (parse-string-escape rest)))
                     (parse-string-contents (cadr pair) (concat yet (car pair))))
             (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")
+;   ('open '()) ('close '()) ('quote '()) ('string "text") ('number 123) ('name "name")
 ; string -> (token string[rest])
 (define next-token (str)
     (let ((ch (substr 0 1 str))
@@ -134,9 +135,13 @@
                 (list (list 'open '()) rest)
             (= ch ")")
                 (list (list 'close '()) rest)
+            (= ch "'")
+                (list (list 'quote '()) rest)
             (= ch "\"")
-                (let ((text (parse-string-contents rest "")))
-                    (list (list 'string text) (substr (+ (length text) 1) -1 rest)))
+                (let ((pair (parse-string-contents rest ""))
+                      (text (car pair))
+                      (rest2 (cadr pair)))
+                    (list (list 'string text) rest2))
             (or (iswordchar? ch) (isdigit? ch))
                 (let ((restword (take-while isrestwordchar? rest))
                       (rest2 (substr (length restword) -1 rest)))
@@ -166,6 +171,8 @@
                 (ansi-color 'red "(")
             (= tag 'close)
                 (ansi-color 'red ")")
+            (= tag 'quote)
+                (ansi-color 'green "'")
             (= tag 'string)
                 (ansi-color 'yellow (concat "\"" (concat (string-escape field) "\"")))
             (= tag 'number)
@@ -195,7 +202,7 @@
 (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...))
+;   ('string "text") ('number 123) ('name "name") ('quote item) ('sexpr (list item...))
 ; tokens -> (item tokens[rest])
 (define parse-item (logged-token-fn "parse-item" (lambda (tokens)
     (if (null? tokens)
@@ -206,6 +213,9 @@
                     (parse-sexpr tokens)
                 (= tag 'close)
                     (error "Unexpected close parenthesis")
+                (= tag 'quote)
+                    (let ((pair (parse-item (cdr tokens))))
+                        (list (list 'quote (car pair)) (cadr pair)))
                 (= tag 'string)
                     (list (car tokens) (cdr tokens))
                 (= tag 'number)
@@ -252,6 +262,23 @@
             (cons 'program items))))
 
 ; ast -> string
+(define pretty-ast-compact (ast)
+    (cond
+        (= (car ast) 'program)
+            (intercalate " " (map pretty-ast-compact (cdr ast)))
+        (= (car ast) 'list)
+            (concat "(" (concat (intercalate " " (map pretty-ast-compact (cadr ast))) ")"))
+        (= (car ast) 'quote)
+            (concat "'" (pretty-ast-compact (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-compact" (car ast))))
+
+; ast -> string
 (define pretty-ast (ast)
     (let ((isnotnl? (lambda (ch) (!= ch "\n")))
           (indent (lambdarec rec (str)
@@ -262,26 +289,26 @@
                                 (concat line
                                         (concat "\n    " (rec (substr 1 -1 rest))))))))
           (indent-items (lambdarec rec (items)
-                            (cond
-                                (null? items)
-                                    ""
-                                (null? (cdr items))
+                            (if (null? items)
+                                ""
+                                (concat
                                     (indent (pretty-ast (car items)))
-                                (concat (indent (pretty-ast (car items)))
-                                        (concat "\n    " (rec (cdr items)))))))
+                                    (concat-list
+                                        (map (lambda (i) (concat "\n    " (indent (pretty-ast i))))
+                                             (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))))))))
+                            (if (null? items)
+                                ""
+                                (concat-list
+                                    (map (lambda (i) (concat "\n" (pretty-ast i)))
+                                         (cdr items)))))))
         (cond
             (= (car ast) 'program)
                 (print-program (cdr ast))
             (= (car ast) 'list)
                 (concat "(" (concat (indent-items (cadr ast)) ")"))
+            (= (car ast) 'quote)
+                (concat "'" (pretty-ast-compact (cadr ast)))
             (= (car ast) 'string)
                 (pretty-token ast)
             (= (car ast) 'number)
@@ -290,8 +317,8 @@
                 (pretty-token ast)
             (error "Unrecognised AST type in pretty-ast" (car ast)))))
 
-(let ((tokens (tokenise (read-file "tests/f.lisp"))))
+(let ((tokens (tokenise (read-file "tests/stdlib.lisp"))))
     (do
-        ; (print (pretty-token-list tokens))
+        (print (pretty-token-list tokens))
         ; (print (parse-program tokens))
         (print (pretty-ast (parse-program tokens)))))
diff --git a/tests/stdlib.lisp b/tests/stdlib.lisp
index 88af2a1..9acee4b 100644
--- a/tests/stdlib.lisp
+++ b/tests/stdlib.lisp
@@ -86,6 +86,10 @@
                             (rec (cdr l2) (cons (car l2) rest))))))
         (helper l '())))
 
+(define map (f l)
+    (if (null? l) l
+        (cons (f (car l)) (map f (cdr l)))))
+
 (define stdin (sys-stdin))
 (define stdout (sys-stdout))
 (define stderr (sys-stderr))
@@ -120,3 +124,15 @@
             (< num 0)
                 (concat "-" (number->string (- 0 num)))
             (helper num ""))))
+
+(define concat-list (l)
+    (if (null? l) ""
+        (concat (car l) (concat-list (cdr l)))))
+
+(define intercalate (sep l)
+    (cond
+        (null? l)
+            ""
+        (null? (cdr l))
+            (car l)
+        (concat (concat (car l) sep) (intercalate sep (cdr l)))))