@@ 76,10 76,10 @@
("BACKBURNER" (make-token :text str :kind :operation :value :halve))
("PARADIGM SHIFT" (make-token :text str :kind :operation :value :random))
("ALIGN" (make-token :text str :kind :operation :value :assignment))
- ("WITH" (make-token :text str :kind :operation :value :designator))
+ ("WITH" (make-token :text str :kind :designator))
("SYNERGIZE" (make-token :text str :kind :operation :value :add))
("INTEGRATE" (make-token :text str :kind :operation :value :add))
- ("AND" (make-token :text str :kind :operation :value :NOOP))
+ ("AND" (make-token :text str :kind :NOOP))
("DIFFERENTIATE" (make-token :text str :kind :operation :value :subtract))
("CROWDSOURCE" (make-token :text str :kind :operation :value :input))
("DELIVER" (make-token :text str :kind :operation :value :output))
@@ 139,27 139,33 @@
(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 '())
(labels-declared :accessor labels-declared :initform '())
(labels-gotoed :accessor labels-gotoed :initform '())))
-(defmethod initialize-instance :after ((p parser) &rest args) ; how do you suppress unused arguments warnings?
+(defmethod initialize-instance :after ((p parser) &rest args) ; FIXME suppress unused arguments warning
(next-token p)
(next-token p))
-(defgeneric check-token (parser kind)
- (:method ((p parser) kind)
- (eq kind (token-kind (current-token p)))))
+(defgeneric check-token-kind (parser kind)
+ (:method ((p parser) type)
+ (eq type (token-kind (current-token p)))))
-(defgeneric check-peek (parser kind)
+(defgeneric check-token (parser value)
+ (:method ((p parser) value)
+ (eq value (token-value (current-token p)))))
+
+(defgeneric verify (parser kind)
(:method ((p parser) kind)
- (eq kind (token-kind (peek-token p)))))
+ (unless (check-token-kind p kind)
+ (error 'parsing-error :text (format nil "Expected ~a, got ~a" kind (current-token p))))))
(defgeneric match (parser kind)
(:method ((p parser) kind)
- (if (check-token p kind)
+ (if (check-token-kind p kind)
(next-token p)
(error 'parsing-error :text (format nil "Expected ~a, got ~a" kind (current-token p))))))
@@ 171,12 177,13 @@
(defgeneric program (parser)
(:method ((p parser))
(header-line (emitter p) "#include <stdio.h>")
+ (header-line (emitter p) "#include <stdlib.h>")
(header-line (emitter p) "int main(void) {")
- (loop while (check-token p :NEWLINE)
+ (loop while (check-token-kind p :NEWLINE)
do (next-token p))
- (loop until (check-token p :EOF)
+ (loop until (check-token-kind p :EOF)
do (statement p))
(emit-line (emitter p) "return 0;")
@@ 186,155 193,187 @@
unless (member str (labels-declared p) :test #'equal)
do (error 'parsing-error :text (format nil "GOTO bad label: ~a" str)))))
+(defgeneric check-register (parser)
+ (:method ((p parser))
+ (let ((register (token-value (current-token p))))
+ (unless (member register (symbols p) :test #'equal)
+ (pushnew register (symbols p))
+ (header-line (emitter p) (format nil "int ~a;" register))))))
+
(defgeneric statement (parser)
(:method ((p parser))
- (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) "));")))))
+ (cond ((check-token p :INCREMENT)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p)
+ (format nil "~a += 1;" (token-value (current-token p))))
+ (next-token p))
+
+ ((check-token p :ASSIGNMENT)
+ (next-token p)
+ (if (check-token-kind p :CONSTANT)
+ ;; NUMBER = REGISTER
+ (let* ((number-str (constant-expression p)))
+ (match p :DESIGNATOR)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p) (format nil "~a = ~a;" (token-value (current-token p)) number-str))
+ (next-token p))
+
+ (let ((lhs (token-value (current-token p)))
+ (rhs nil))
+ (verify p :REGISTER)
+ (check-register p)
+ (next-token p)
+ (match p :DESIGNATOR)
+ ;; REGISTER = NUMBER
+ (if (check-token-kind p :CONSTANT)
+ (setf rhs (constant-expression p))
+
+ ;; REGISTER = REGISTER
+ (progn
+ (verify p :REGISTER)
+ (check-register p)
+ (setf rhs (token-value (current-token p)))
+ (next-token p)))
+ (emit-line (emitter p) (format nil "~a = ~a;" lhs rhs)))))
- ((check-token p :IF)
- (progn
+ ((check-token p :DECREMENT)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p)
+ (format nil "~a -= 1;" (token-value (current-token p))))
+ (next-token p))
+
+ ((check-token p :NEGATE)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p)
+ (format nil "~a *= -1;" (token-value (current-token p))))
+ (next-token p))
+
+ ((check-token p :DOUBLE)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p)
+ (format nil "~a *= 2;" (token-value (current-token p))))
+ (next-token p))
+
+ ((check-token p :HALVE)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p)
+ (format nil "~a /= 2;" (token-value (current-token p))))
+ (next-token p))
+
+ ((check-token p :ADD)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (let ((lhs (token-value (current-token p)))
+ (rhs nil))
(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) "}")))
+ (match p :NOOP)
+ (verify p :REGISTER)
+ (check-register p)
+ (setf rhs (token-value (current-token p)))
+ (emit-line (emitter p) (format nil "~a = ~a + ~a;" lhs lhs rhs))
+ (next-token p)))
- ((check-token p :WHILE)
- (progn
+ ((check-token p :SUBTRACT)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (let ((lhs (token-value (current-token p)))
+ (rhs nil))
(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) "}")))
+ (match p :NOOP)
+ (verify p :REGISTER)
+ (check-register p)
+ (setf rhs (token-value (current-token p)))
+ (emit-line (emitter p) (format nil "~a = ~a - ~a;" lhs lhs rhs))
+ (next-token p)))
+
+ ((check-token p :RANDOM)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p)
+ (format nil "~a = rand() % 10;" (token-value (current-token p))))
+ (next-token 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)
- (emit-line (emitter p) (format nil "~a:" (token-text (current-token p))))
- (match p :IDENTIFIER)))
+ (next-token p)
+ (verify p :NOOP)
+ (next-token p)
+ (verify p :STRING)
+ (emit-line (emitter p)
+ (format nil "~a:" (labelify (current-token p))))
+ (next-token p))
- ((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 :JUMP)
+ (next-token p)
+ (verify p :STRING)
+ (emit-line (emitter p)
+ (format nil "goto ~a;" (labelify (current-token p))))
+ (next-token p))
+
+ ((check-token p :JNEG)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit (emitter p)
+ (format nil "if(~a < 0) " (token-value (current-token p))))
+ (next-token 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 :JZ)
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit (emitter p)
+ (format nil "if(~a == 0) " (token-value (current-token p))))
+ (next-token p))
- ((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)))
+ ((check-token p :TARGET)
+ (next-token p)
+ (verify p :STRING)
+ (emit-line (emitter p)
+ (format nil "goto ~a;" (labelify (current-token p))))
+ (next-token p))
- (t (error 'parsing-error
- :text (format nil "Unknown token: ~a" (current-token p)))))
+ ((check-token p :OUTPUT)
+ (emit (emitter p) "printf(\"%c\", ")
+ (next-token p)
+ (verify p :REGISTER)
+ (check-register p)
+ (emit-line (emitter p) (format nil "~a);" (token-value (current-token p))))
+ (next-token p))
+
+ (t (emit-line (emitter p) (format nil "// FIXME ~a" (current-token p))) (next-token p)))
(newline p)))
+(defun labelify (token)
+ (remove-if-not #'alpha-char-p (token-text token)))
+
(defgeneric newline (parser)
(:method ((p parser))
- (match p :NEWLINE)
- (loop while (check-token p :NEWLINE)
+ ;; (match p :NEWLINE) ; FIXME why are strings swallowing newlines??
+ (loop while (check-token-kind p :NEWLINE)
do (next-token p))))
-(defgeneric comparison (parser)
- (:method ((p parser))
- (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 (emit (emitter p) (token-text (current-token p)))
- (next-token p)
- (expression p)))))
-
-(defgeneric expression (parser)
- (:method ((p parser))
- (term p)
- (loop while (or (check-token p :PLUS)
- (check-token p :MINUS))
- do (emit (emitter p) (token-text (current-token p)))
- (next-token p)
- (term p))))
-
-(defgeneric term (parser)
+(defgeneric constant-expression (parser)
(:method ((p parser))
- (unary p)
- (loop while (or (check-token p :ASTERISK)
- (check-token p :SLASH))
- do (emit (emitter p) (token-text (current-token p)))
- (next-token p)
- (unary p))))
-
-(defgeneric unary (parser)
- (:method ((p parser))
- (loop while (or (check-token p :PLUS)
- (check-token p :MINUS))
- do (emit (emitter p) (token-text (current-token p)))
- (next-token p))
- (primary p)))
-
-(defgeneric primary (parser)
- (:method ((p parser))
- (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)))))))
+ (let ((numbers (loop while (or (check-token-kind p :CONSTANT)
+ (check-token-kind p :NOOP))
+ if (check-token-kind p :CONSTANT)
+ collect (token-value (current-token p))
+ do (next-token p))))
+ (format nil "~{~a~}" numbers))))
;;; emitter
@@ 356,13 395,3 @@
;;; testing
-(let* ((l (make-instance 'lexer :source "
-Engineering, Marketing, and HR
-Executive Management stakeholder engagement
-align R&D Engineering and HR with stakeholder engagement
-")))
- (let ((ct nil) (list nil))
- (loop until (and ct (eq (token-kind ct) :EOF))
- do (setf ct (get-token l))
- (push ct list)
- (format t "~a~%" (if (token-value ct) (token-value ct) (token-kind ct))))))