Add parsing functionality for R-type expressions

5 files changed, 125 insertions, 25 deletions

diff --git a/src/main.lisp b/src/main.lisp
index f6e5754..8a36a66 100644
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -47,8 +47,14 @@ _/_/                                  _/_/  "
       (t (let ((tokens (lex:file->tokens file)))
            (if tokens
                (progn (pprint tokens)
-                      (terpri))
+                      (terpri)
+                      (format t "---~%"))
                (error "The file does not exist, or it could not be opened.~%"))
+           (if parse?
+               (let ((tokens (parse:tokens->ast tokens)))
+                 (progn (pprint tokens)
+                        (terpri)
+                        (format t "---~%"))))
            (format t "Nitimur in Vetitum~%"))))))
 
 
diff --git a/src/package.lisp b/src/package.lisp
index 3364856..7a14bd2 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -1,4 +1,4 @@
-helper(defpackage #:rva
+(defpackage #:rva
   (:use #:cl)
   (:export #:main))
 
@@ -22,5 +22,7 @@ helper(defpackage #:rva
   (:use #:cl)
   (:export #:parser-error
            #:tokens->ast
+           #:to-register
            ;; exported for testing only
-           #:extract-label))
+           #:extract-label
+           #:extract-r-type))
diff --git a/src/parse.lisp b/src/parse.lisp
index 3052583..bd50a23 100644
--- a/src/parse.lisp
+++ b/src/parse.lisp
@@ -1,4 +1,14 @@
-helper(in-package #:parse)
+(in-package #:parse)
+
+(defparameter reg-loc
+  '(("zr" . 0) ("lk" . 1)
+    ("sp" . 2) ("cc" . 3)
+    ("vl" . 4) ("fp" . 5))
+  "A symbol table mapping register aliases to identifiers. If you want to add
+a new alias, do it here.")
+
+(defparameter label-loc '()
+  "A symbol table mapping label names to line indices.")
 
 (define-condition parser-error (error)
   ((message :initarg :message
@@ -8,6 +18,19 @@ helper(in-package #:parse)
              (format stream "~A" (message condition))))
   (:documentation "Dedicated error for an invalid parse."))
 
+(defun to-register (tokens)
+  "Attempts to parse a register from the start of TOKENS. If it is badly formed,
+throws a PARSER-ERROR."
+  (or (and (equal (car tokens) 'LEX::DOLLAR)
+           (cadr tokens)
+           (let ((r (cadr tokens)))
+             (cond ((stringp r) (cdr (assoc r reg-loc :test #'string=)))
+                   ((numberp r) (and (<= 0 r 23) r)))))
+      (error 'parser-error
+             :message
+             (format nil "PARSE failed--Expected register, got ~a.~%"
+                     (subseq tokens 0 (min 2 (length tokens)))))))
+
 (defun tokens->ast (program)
   "Given PROGRAM, which is a list of lists of symbols,
 filters out the labels and parses."
@@ -26,30 +49,52 @@ Note that this function is intended to be called using mapcar,
 so that labels can be added to a map and otherwise removed from
 processing."
     (trivia:match line
-      ((list (and id (type string))
-             (satisfies (lambda (x) (equal x 'lex::colon))))
-       (progn (push (cons (read-from-string id) i) util:label-loc) nil))
+      ((list (type string) 'lex::colon)
+       (progn (push (cons (read-from-string (car line)) i) label-loc) nil))
       (_ (progn (incf i) line)))))
 
 (defun extract-instruction (line i)
   "Given instruction LINE, determines the expected type format and passes
 LINE and the index I to the the respective function."
-  ;; TODO add pseudo-ops (i.e., nop, mov, ...)
-  (let* ((type-map '((r-type . extract-r-type)
-                     (i-type . extract-i-type)
-                     (j-type . extract-j-type)))
-         (keyword (car line))
-         (type-fn (cdr (assoc keyword type-map))))
+  (let* ((mnemonic (intern (string-upcase (car line)) :util))
+         ;; TODO add pseudo-ops (i.e., nop, leave, ret...)
+         ;; should probably be their own extract function
+         (type-fn (cond
+                    ((member mnemonic util:type-r) #'extract-r-type)
+                    ((member mnemonic util:type-i) #'extract-i-type)
+                    ((member mnemonic util:type-j) #'extract-j-type))))
     (if type-fn
         (funcall type-fn line i)
         (error 'parser-error
-               (format nil "PARSE failed--~a is not a known keyword.~%" (keyword))))))
+               :message
+               (format nil "PARSE failed--~a is not a known keyword.~%" mnemonic)))))
 
 (defun extract-r-type (line i)
-  'r)
+  (let ((mnemonic (intern (string-upcase (car line)) :util)))
+    (defun die ()
+      (error 'parser-error
+             :message
+             (format nil "PARSE failed---Incorrect number of operands for ~a" mnemonic)))
+    (defun eat-registers (registers-so-far lst)
+      (if (not (null lst))
+          (eat-registers (cons (to-register lst) registers-so-far)
+                         (cddr lst))
+          (reverse registers-so-far)))
+    (let* ((registers (eat-registers '() (cdr line)))
+           ;; handle special cases
+           (registers (cond ((member mnemonic '(util::CMP util::CEV))
+                             (if (= 2 (length registers))
+                                 (cons 0 registers)
+                                 (die)))
+                            ((member mnemonic '(util::NOT))
+                             (if (= 2 (length registers))
+                                 (append registers (list 0))
+                                 (die)))
+                            (t (if (= 3 (length registers)) registers (die))))))
+      (list :op mnemonic :d (car registers) :s1 (cadr registers) :s2 (caddr registers)))))
 
 (defun extract-i-type (line i)
-  'i)
+  line)
 
 (defun extract-j-type (line i)
-  'j)
+  line)
diff --git a/src/util.lisp b/src/util.lisp
index 5edee4a..027a770 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -16,12 +16,9 @@
   "R-type instructions.")
 
 (defparameter type-i
-  '(LOAD LOADV ADDI SUBI SFTRI SFTLI ANDI ORI XORI STORE STOREV)
+  '(LOAD LOADV ADDI SUBI SFTRI SFTLI ANDI ORI XORI STORE STOREV MOV)
   "I-type instructions.")
 
 (defparameter type-j
   '(JMP JRL JAL BEQ BGT BUF BOF PUSH POP)
   "J-type instructions.")
-
-(defparameter label-loc '()
-  "A symbol table mapping label names to line indices.")
diff --git a/t/parse.lisp b/t/parse.lisp
index bd1310f..7187292 100644
--- a/t/parse.lisp
+++ b/t/parse.lisp
@@ -1,5 +1,11 @@
 (in-package #:rva-tests)
 
+(defmacro expect-parse-error (body)
+  `(handler-case
+       (progn ,body
+              (fail))
+     (parse::parser-error ())))
+
 (def-suite parse-tests
   :description "Test functions exported from the parser."
   :in all-tests)
@@ -20,7 +26,51 @@
                    (parse:extract-label lst)))))
 
 (test extract-line-invalid-type
-      (handler-case
-          (progn (parse:tokens->ast '(("foo" LEX::DOLLAR)))
-                 (fail))
-        (lex:parser-error ())))
+      (expect-parse-error (parse:tokens->ast '(("foo" lex::dollar)))))
+
+(test to-register-nil
+      (expect-parse-error (parse:to-register '())))
+
+(test to-register-singleton
+      (expect-parse-error (parse:to-register '(lex::dollar))))
+
+(test to-register-zero
+      (is (= 0 (parse:to-register '(lex::dollar 0)))))
+
+(test to-register-one
+      (is (= 1 (parse:to-register '(lex::dollar 1)))))
+
+(test to-register-twenty-three
+      (is (= 23 (parse:to-register '(lex::dollar 23)))))
+
+(test to-register-zero-named
+      (is (= 0 (parse:to-register '(lex::dollar "zr")))))
+
+(test to-register-twenty-four
+      (expect-parse-error (parse:to-register '(lex::dollar 24))))
+
+(test to-register-negative-one
+      (expect-parse-error (parse:to-register '(lex::dollar -1))))
+
+(test extract-r-type-no-registers
+      (expect-parse-error (parse:extract-r-type '("add") 0)))
+
+(test extract-r-type-two-registers
+      (expect-parse-error (parse:extract-r-type '("add" lex::dollar 2 lex::dollar 3) 0)))
+
+(test extract-r-type-cmp-three-registers
+      (expect-parse-error (parse:extract-r-type '("cmp" lex::dollar 2
+                                                  lex::dollar 3 lex::dollar 4) 0)))
+
+(test extract-r-type-simple-add
+      (is (equal '(:op util::ADD :d 2 :s1 3 :s2 4)
+                 (parse:extract-r-type '("add" lex::dollar 2
+                                         lex::dollar 3 lex::dollar 4) 0))))
+
+(test extract-r-type-simple-not
+      (is (equal '(:op util::NOT :d 2 :s1 3 :s2 0)
+                 (parse:extract-r-type '("not" lex::dollar 2 lex::dollar 3) 0))))
+
+(test extract-r-type-simple-cmp
+      (is (equal '(:op util::CMP :d 0 :s1 2 :s2 3)
+                 (parse:extract-r-type '("cmp" lex::dollar 2 lex::dollar 3) 0))))