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
102
103
104
105
106
107
|
(in-package :cl-forth)
(defparameter *operations* (make-hash-table))
(eval-always
(defun normalize-op-list (lst)
(cons 'list
(mapcar (lambda (el) (cond ((stringp el) el)
((listp el) `(format nil ,@el))))
lst))))
(defmacro defop (op-name (&key (indent 4) args) &body asm-strings)
`(setf (gethash ',op-name *operations*)
(lambda (out-stream ,@args)
(format out-stream
,(format nil "~~{~a~~a~~%~~}"
(make-string indent :initial-element
#\Space))
,(normalize-op-list asm-strings)))))
(defop push (:args (a))
("push ~d" a))
(defop + ()
"pop rax"
"pop rbx"
"add rax, rbx"
"push rax")
(defop - ()
"pop rax"
"pop rbx"
"sub rbx, rax"
"push rbx")
(defop |.| ()
"pop rdi"
"call dump")
(defop = ()
"mov rcx, 0"
"mov rdx, 1"
"pop rax"
"pop rbx"
"cmp rax, rbx"
"cmove rcx, rdx"
"push rcx")
(defop exit (:args (exit-code))
"mov rax, 60"
("mov rdi, ~a" exit-code)
"syscall")
(defop ise (:args (label-num))
"pop rax"
"test rax, rax"
("jz et_~a" label-num))
(defop yoksa (:args (yap-num ise-num) :indent 0)
(" jmp et_~a" yap-num)
("et_~a:" ise-num))
(defop yap (:args (label-num) :indent 0)
("et_~a:" label-num))
(defun gen-code (op str)
(let ((op-fn (gethash (car op) *operations*)))
(if (null op-fn)
(error "~s is not a valid op" op)
(apply op-fn str (cdr op)))))
(defun gen-dump (str)
(format str "~{~a~%~}"
'("dump:"
" mov r9, -3689348814741910323"
" sub rsp, 40"
" mov BYTE [rsp+31], 10"
" lea rcx, [rsp+30]"
".L2:"
" mov rax, rdi"
" lea r8, [rsp+32]"
" mul r9"
" mov rax, rdi"
" sub r8, rcx"
" shr rdx, 3"
" lea rsi, [rdx+rdx*4]"
" add rsi, rsi"
" sub rax, rsi"
" add eax, 48"
" mov BYTE [rcx], al"
" mov rax, rdi"
" mov rdi, rdx"
" mov rdx, rcx"
" sub rcx, 1"
" cmp rax, 9"
" ja .L2"
" lea rax, [rsp+32]"
" mov edi, 1"
" sub rdx, rax"
" xor eax, eax"
" lea rsi, [rsp+32+rdx]"
" mov rdx, r8"
" mov rax, 1"
" syscall"
" add rsp, 40"
" ret")))
|
