From 902439a9facc1f70e8f6b6574673785aa5379786 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Tue, 26 Nov 2019 17:28:28 +0100 Subject: Working (basic) lisp parser in lisp --- tests/lispparser.lisp | 148 +++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 134 insertions(+), 14 deletions(-) (limited to 'tests') 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 ), where the type of 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 ), where the type of 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))))) -- cgit v1.2.3-54-g00ecf