@@ 1,3 1,6 @@
+;;; a teeny tiny compiler:
+;;; https://web.eecs.utk.edu/~azh/blog/teenytinycompiler1.html
+
;;; lexer
(defstruct (token) text kind)
@@ 91,7 94,7 @@
do (error 'lexing-error
:text (format nil "illegal character in string: ~a" (current-char l)))
do (next-char l))
- (make-token :text (subseq (source l) start-position (1+ (current-position l)))
+ (make-token :text (subseq (source l) start-position (current-position l))
:kind :STRING))))
;; numbers
@@ 134,6 137,7 @@
(defclass parser ()
((lexer :accessor lexer :initarg :lexer)
+ (emitter :accessor emitter :initarg :emitter)
(current-token :accessor current-token :initform nil)
(peek-token :accessor peek-token :initform nil)
(symbols :accessor symbols :initform '())
@@ 165,150 169,216 @@
(defgeneric program (parser)
(:method ((p parser))
- (format t "program~%")
+ (header-line (emitter p) "#include <stdio.h>")
+ (header-line (emitter p) "int main(void) {")
+
(loop while (check-token p :NEWLINE)
do (next-token p))
+
(loop until (check-token p :EOF)
do (statement p))
+
+ (emit-line (emitter p) "return 0;")
+ (emit-line (emitter p) "}")
+
(loop for str in (labels-gotoed p)
unless (member str (labels-declared p) :test #'equal)
do (error 'parsing-error :text (format nil "GOTO bad label: ~a" str)))))
(defgeneric statement (parser)
(:method ((p parser))
- (format t "statement~%")
- (cond ((check-token p :PRINT) (progn
- (next-token p)
- (if (check-token p :STRING)
- (next-token p)
- (expression p))))
+ (cond ((check-token p :PRINT)
+ (progn
+ (next-token p)
+ (if (check-token p :STRING)
+ (progn
+ (emit-line (emitter p) (format nil "printf(\"~a\\n\");" (token-text (current-token p))))
+ (next-token p))
+ (progn
+ (emit (emitter p) (format nil "printf(\"%.2f\\n\", (float)("))
+ (expression p)
+ (emit-line (emitter p) "));")))))
- ((check-token p :IF) (progn
- (next-token p)
- (comparison p)
- (match p :THEN)
- (newline p)
- (loop until (check-token p :ENDIF)
- do (statement p))
- (match p :ENDIF)))
+ ((check-token p :IF)
+ (progn
+ (next-token p)
+ (emit (emitter p) "if(")
+ (comparison p)
+ (match p :THEN)
+ (newline p)
+ (emit-line (emitter p) "){")
+ (loop until (check-token p :ENDIF)
+ do (statement p))
+ (match p :ENDIF)
+ (emit-line (emitter p) "}")))
- ((check-token p :WHILE) (progn
- (next-token p)
- (comparison p)
- (match p :REPEAT)
- (newline p)
- (loop until (check-token p :ENDWHILE)
- do (statement p))
- (match p :ENDWHILE)))
+ ((check-token p :WHILE)
+ (progn
+ (next-token p)
+ (emit (emitter p) "while(")
+ (comparison p)
+ (match p :REPEAT)
+ (newline p)
+ (emit-line (emitter p) "){")
+ (loop until (check-token p :ENDWHILE)
+ do (statement p))
+ (match p :ENDWHILE)
+ (emit-line (emitter p) "}")))
- ((check-token p :LABEL) (progn
- (next-token p)
- (if (member (token-text (current-token p)) (labels-declared p) :test #'equal)
- (error 'parsing-error
- :text (format nil "label already exists: ~a" (current-token p))))
- (pushnew (token-text (current-token p)) (labels-declared p) :test #'equal)
- (match p :IDENTIFIER)))
+ ((check-token p :LABEL)
+ (progn
+ (next-token p)
+ (if (member (token-text (current-token p)) (labels-declared p) :test #'equal)
+ (error 'parsing-error
+ :text (format nil "label already exists: ~a" (current-token p))))
+ (pushnew (token-text (current-token p)) (labels-declared p) :test #'equal)
+ (emit-line (emitter p) (format nil "~a:" (token-text (current-token p))))
+ (match p :IDENTIFIER)))
- ((check-token p :GOTO) (progn
- (next-token p)
- (pushnew (token-text (current-token p)) (labels-gotoed p) :test #'equal)
- (match p :IDENTIFIER)))
+ ((check-token p :GOTO)
+ (progn
+ (next-token p)
+ (pushnew (token-text (current-token p)) (labels-gotoed p) :test #'equal)
+ (emit-line (emitter p) (format nil "goto ~a;" (token-text (current-token p))))
+ (match p :IDENTIFIER)))
- ((check-token p :LET) (progn
- (next-token p)
- (pushnew (token-text (current-token p)) (symbols p) :test #'equal)
- (match p :IDENTIFIER)
- (match p :EQ)
- (expression p)))
+ ((check-token p :LET)
+ (progn
+ (next-token p)
+ (unless (member (token-text (current-token p)) (symbols p) :test #'equal)
+ (header-line (emitter p) (format nil "float ~a;" (token-text (current-token p)))))
+ (pushnew (token-text (current-token p)) (symbols p) :test #'equal)
+ (emit (emitter p) (format nil "~a = " (token-text (current-token p))))
+ (match p :IDENTIFIER)
+ (match p :EQ)
+ (expression p)
+ (emit (emitter p) ";")))
- ((check-token p :INPUT) (progn
- (next-token p)
- (pushnew (token-text (current-token p)) (symbols p) :test #'equal)
- (match p :IDENTIFIER)))
+ ((check-token p :INPUT)
+ (progn
+ (next-token p)
+ (unless (member (token-text (current-token p)) (symbols p) :test #'equal)
+ (header-line (emitter p) (format nil "float ~a;" (token-text (current-token p)))))
+ (pushnew (token-text (current-token p)) (symbols p) :test #'equal)
+ (emit-line (emitter p) (format nil "if(0 == scanf(\"%f\", &~a)) {" (token-text (current-token p))))
+ (emit-line (emitter p) (format nil "~a = 0;" (token-text (current-token p))))
+ (emit-line (emitter p) "scanf(\"%*s\");")
+ (emit-line (emitter p) "}")
+ (match p :IDENTIFIER)))
- (t (error 'parsing-error
- :text (format nil "Unknown token: ~a" (current-token p)))))
+ (t (error 'parsing-error
+ :text (format nil "Unknown token: ~a" (current-token p)))))
(newline p)))
(defgeneric newline (parser)
(:method ((p parser))
- (format t "newline~%")
(match p :NEWLINE)
(loop while (check-token p :NEWLINE)
do (next-token p))))
(defgeneric comparison (parser)
(:method ((p parser))
- (format t "comparison~%")
(labels ((comparison-operator? ()
(some (lambda (kind) (check-token p kind)) '(:GT :GTEQ :LT :LTEQ :EQEQ :NOTEQ))))
(expression p)
(if (comparison-operator?)
(progn
+ (emit (emitter p) (token-text (current-token p)))
(next-token p)
(expression p))
(error 'parsing-error
:text (format nil "Expected comparison, instead: ~a" (current-token p))))
(loop while (comparison-operator?)
- do (next-token p)
+ do (emit (emitter p) (token-text (current-token p)))
+ (next-token p)
(expression p)))))
(defgeneric expression (parser)
(:method ((p parser))
- (format t "expression~%")
(term p)
(loop while (or (check-token p :PLUS)
(check-token p :MINUS))
- do (next-token p)
+ do (emit (emitter p) (token-text (current-token p)))
+ (next-token p)
(term p))))
(defgeneric term (parser)
(:method ((p parser))
- (format t "term~%")
(unary p)
(loop while (or (check-token p :ASTERISK)
(check-token p :SLASH))
- do (next-token p)
+ do (emit (emitter p) (token-text (current-token p)))
+ (next-token p)
(unary p))))
(defgeneric unary (parser)
(:method ((p parser))
- (format t "unary~%")
(loop while (or (check-token p :PLUS)
(check-token p :MINUS))
- do (next-token p))
+ do (emit (emitter p) (token-text (current-token p)))
+ (next-token p))
(primary p)))
(defgeneric primary (parser)
(:method ((p parser))
- (format t "primary~%")
- (cond ((check-token p :NUMBER) (next-token p))
+ (cond ((check-token p :NUMBER)
+ (progn
+ (emit (emitter p) (token-text (current-token p)))
+ (next-token p)))
((check-token p :IDENTIFIER)
(progn
(unless (member (token-text (current-token p)) (symbols p) :test #'equal)
(error 'parsing-error
:text (format nil "referencing variable before assignment: ~a" (current-token p))))
+ (emit (emitter p) (token-text (current-token p)))
(next-token p)))
(t (error 'parsing-error
:text (format nil "Unexpected token: ~a" (current-token p)))))))
-;;; "tests"
+;;; emitter
+
+(defclass emitter ()
+ ((header :accessor header :initform "")
+ (code :accessor code :initform "")))
+
+(defgeneric emit (emitter new-code)
+ (:method ((e emitter) new-code)
+ (setf (code e) (format nil "~a~a" (code e) new-code))))
+
+(defgeneric emit-line (emitter new-code)
+ (:method ((e emitter) new-code)
+ (setf (code e) (format nil "~a~a~%" (code e) new-code))))
+
+(defgeneric header-line (emitter new-code)
+ (:method ((e emitter) new-code)
+ (setf (header e) (format nil "~a~a~%" (header e) new-code))))
+
+;;; sample program
+
(let* ((l (make-instance 'lexer :source "
-PRINT \"How many fibonacci numbers do you want?\"
-INPUT nums
-PRINT \"\"
+# Compute average of given values.
LET a = 0
-LET b = 1
-WHILE nums > 0 REPEAT
- PRINT a
- LET c = a + b
- LET a = b
- LET b = c
- LET nums = nums - 1
+WHILE a < 1 REPEAT
+ PRINT \"Enter number of scores: \"
+ INPUT a
ENDWHILE
+LET b = 0
+LET s = 0
+PRINT \"Enter one value at a time: \"
+WHILE b < a REPEAT
+ INPUT c
+ LET s = s + c
+ LET b = b + 1
+ENDWHILE
+
+PRINT \"Average: \"
+PRINT s / a
+
"))
- (p (make-instance 'parser :lexer l)))
- (program p))
+ (e (make-instance 'emitter))
+ (p (make-instance 'parser :lexer l :emitter e)))
+ (program p)
+ (format t "~a~a~%" (header (emitter p)) (code (emitter p))))