mRnea
004c2b5628
note that (eq 'baz:foo bar:foo) is not true so some stuff that works in the repl fails in executable
184 lines
4.4 KiB
Common Lisp
184 lines
4.4 KiB
Common Lisp
(in-package :cl-forth)
|
|
|
|
(defparameter *operations* (make-hash-table :test 'equal))
|
|
|
|
(eval-always
|
|
(defun normalize-op-list (asm-list)
|
|
(cons 'list
|
|
(mapcar (lambda (el) (cond ((stringp el) el)
|
|
((listp el) `(format nil ,@el))))
|
|
asm-list)))
|
|
|
|
(defun defop-format (str space-num asm-list)
|
|
(format str
|
|
(format nil "~~{~a~~a~~%~~}"
|
|
(make-string space-num :initial-element #\Space))
|
|
asm-list))
|
|
|
|
(defun replace-write (out-stream indent forms)
|
|
(if (consp forms)
|
|
(if (eq :write (car forms))
|
|
`(defop-format ,out-stream ,indent
|
|
,(normalize-op-list (cdr forms)))
|
|
(cons (replace-write out-stream indent (car forms))
|
|
(replace-write out-stream indent (cdr forms))))
|
|
forms)))
|
|
|
|
(defmacro defop (op-name+args (&key (indent 4)) &body body)
|
|
(with-gensyms (out-stream)
|
|
(destructuring-bind (op-name . args) (mklist op-name+args)
|
|
`(setf (gethash ,(string op-name) *operations*)
|
|
(lambda (,out-stream ,@args)
|
|
,(if (or (stringp (car body)) (stringp (caar body)))
|
|
`(defop-format ,out-stream ,indent
|
|
,(normalize-op-list body))
|
|
(replace-write out-stream indent (car body))))))))
|
|
|
|
(defop (push 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 dump ()
|
|
"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 code) ()
|
|
"mov rax, 60"
|
|
("mov rdi, ~a" code)
|
|
"syscall")
|
|
|
|
(defop (ise label-num) ()
|
|
"pop rax"
|
|
"test rax, rax"
|
|
("jz et_~a" label-num))
|
|
|
|
(defop (yoksa yap-num ise-num) (:indent 0)
|
|
(" jmp et_~a" yap-num)
|
|
("et_~a:" ise-num))
|
|
|
|
(defop (yap label-num &optional döngü-num) (:indent 0)
|
|
(if (null döngü-num)
|
|
(:write ("et_~a:" label-num))
|
|
(:write (" jmp et_~a" döngü-num)
|
|
("et_~a:" label-num))))
|
|
|
|
(defop eş ()
|
|
"pop rax"
|
|
"push rax"
|
|
"push rax")
|
|
|
|
(defop düş ()
|
|
"pop rax")
|
|
|
|
(defop (iken label-num) ()
|
|
"pop rax"
|
|
"test rax, rax"
|
|
("jz et_~a" label-num))
|
|
|
|
(defop (döngü label-num) (:indent 0)
|
|
("et_~a:" label-num))
|
|
|
|
(defop < ()
|
|
"mov rcx, 0"
|
|
"mov rdx, 1"
|
|
"pop rbx"
|
|
"pop rax"
|
|
"cmp rax, rbx"
|
|
"cmovl rcx, rdx"
|
|
"push rcx")
|
|
|
|
(defop > ()
|
|
"mov rcx, 0"
|
|
"mov rdx, 1"
|
|
"pop rbx"
|
|
"pop rax"
|
|
"cmp rax, rbx"
|
|
"cmovg rcx, rdx"
|
|
"push rcx")
|
|
|
|
(defop bel ()
|
|
"push bel")
|
|
|
|
(defop oku ()
|
|
"pop rax"
|
|
"xor rbx, rbx"
|
|
"mov bl, [rax]"
|
|
"push rbx")
|
|
|
|
(defop yaz ()
|
|
"pop rbx"
|
|
"pop rax"
|
|
"mov [rax], bl")
|
|
|
|
(defop (syscall num) ()
|
|
(iter (with call-regs = #("rdi" "rsi" "rdx" "r10" "r8" "r9"))
|
|
(initially (:write "pop rax"))
|
|
(for i from (- num 1) downto 0)
|
|
(:write ("pop ~a" (aref call-regs i)))
|
|
(finally (:write "syscall"))))
|
|
|
|
(defun gen-header (op str)
|
|
(format str " ;; -- ~s --~%" op))
|
|
|
|
(defun gen-code (op str)
|
|
(let ((op-fn (gethash (string (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")))
|