Add parsing functionality for R-type expressions

1 files changed, 59 insertions, 14 deletions

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)