1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
(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
:initform nil
:reader message))
(:report (lambda (condition stream)
(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."
;; TODO add directives
(let ((program (remove nil (mapcar #'extract-label program)))
(i 0))
(mapcar (lambda (l) (extract-instruction l i)) program)))
(let ((i 0))
(defun extract-label (line)
"Given a series of tokens LINE, determines if LINE is
in the form STRING {colon}. If it is, then it is treated as a
label, and pushed onto the stack with the line index.
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."
(if (and (equal 2 (length line))
(stringp (car line))
(equal 'lex::colon (cadr line)))
(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."
(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
:message
(format nil "PARSE failed--~a is not a known keyword.~%" mnemonic)))))
(defun extract-r-type (line i)
(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)
line)
(defun extract-j-type (line i)
line)
|
