283 lines
8.4 KiB
Common Lisp
283 lines
8.4 KiB
Common Lisp
(in-package :cl-forth)
|
|
|
|
(defparameter *operations* (make-hash-table :test 'equal))
|
|
|
|
(defparameter *psuedo-identifiers*
|
|
'(syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6)
|
|
"These do not map to operations directly, but are valid to lexer")
|
|
|
|
(defparameter *identifiers* ())
|
|
;; '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >
|
|
;; bel oku yaz >> << & "|")
|
|
|
|
(defun is-identifier (sym)
|
|
(or (find sym *identifiers* :test #'string=)
|
|
(find sym *psuedo-identifiers* :test #'string=)))
|
|
|
|
(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))
|
|
|
|
(defun add-indent (indent fmt-string)
|
|
(format nil "~a~a"
|
|
(make-string indent :initial-element #\Space)
|
|
fmt-string))
|
|
|
|
(defun split-stack (stack)
|
|
(let ((split-num (position '-- stack)))
|
|
(values (butlast stack (- (length stack) split-num))
|
|
(nthcdr (+ 1 split-num) stack))))
|
|
|
|
(defun op->string (asm-instruction &key (push? t))
|
|
"asm-instruction is something like (:add rax rbx)"
|
|
(destructuring-bind (op arg1 arg2) asm-instruction
|
|
(let ((*print-case* :downcase))
|
|
(if (null push?)
|
|
(format nil (format nil "~a ~a, ~a" op arg1 arg2))
|
|
(list (format nil "~a ~a, ~a" op arg1 arg2)
|
|
(format nil "push ~a" arg1))))))
|
|
|
|
(defun stack->string (stack)
|
|
(multiple-value-bind (prev next)
|
|
(split-stack stack)
|
|
(let ((*print-case* :downcase))
|
|
(append (iter (for sym in (reverse prev))
|
|
(collect (format nil "pop ~a" sym)))
|
|
(iter (for form in next)
|
|
(cond ((symbolp form)
|
|
(appending (list (format nil "push ~a" form))))
|
|
((listp form)
|
|
(appending (op->string form)))))))))
|
|
|
|
(defun syntax-of (form)
|
|
(cond ((or (stringp form)
|
|
(and (consp form) (stringp (car form))))
|
|
:string)
|
|
((and (listp form) (find '-- form))
|
|
:stack)
|
|
((and (listp form) (keywordp (car form)))
|
|
:op)
|
|
(t :general)))
|
|
|
|
(defun group-by-syntax (forms &optional (syntax nil) (cur ()) (acc ()))
|
|
(when (null forms)
|
|
(return-from group-by-syntax
|
|
(cdr (reverse (append (list (cons (syntax-of (car cur))
|
|
(reverse cur)))
|
|
acc)))))
|
|
(let* ((form (car forms))
|
|
(form-syntax (syntax-of form)))
|
|
(cond ((eq syntax form-syntax)
|
|
(group-by-syntax (cdr forms) syntax
|
|
(cons form cur) acc))
|
|
(t (group-by-syntax (cdr forms) form-syntax
|
|
(list form) (append (list (cons syntax
|
|
(reverse cur)))
|
|
acc))))))
|
|
|
|
(defun expand-group (group out-stream &key (indent 4))
|
|
(destructuring-bind (syntax-type . forms) group
|
|
(case syntax-type
|
|
(:stack `(defop-format ,out-stream ,indent
|
|
,(cons 'list (mapcan (lambda (form) (stack->string form))
|
|
forms))))
|
|
(:op `(defop-format ,out-stream ,indent
|
|
,(cons 'list (mapcar (lambda (form) (op->string form :push? nil))
|
|
forms))))
|
|
(:string `(defop-format ,out-stream ,indent
|
|
,(normalize-op-list forms)))
|
|
(:general `(progn ,@(mapcar (lambda (form) (replace-write out-stream indent
|
|
form))
|
|
forms)))))))
|
|
|
|
(defmacro defop (op-name+args (&key (indent 4) (lex t)) &body body)
|
|
(with-gensyms (out-stream)
|
|
(destructuring-bind (op-name . args) (mklist op-name+args)
|
|
`(progn
|
|
,@(unless (null lex)
|
|
`((push ',op-name *identifiers*)))
|
|
(setf (gethash ,(string op-name) *operations*)
|
|
(lambda (,out-stream ,@args)
|
|
,@(mapcar #'(lambda (group) (expand-group group out-stream
|
|
:indent indent))
|
|
(group-by-syntax body))))))))
|
|
|
|
;;; TODO: Turn stack operation comments to DEFOP option,
|
|
;;; which then can be used by the user as a documentation
|
|
;;; DONE: Better yet, generate the asm code directly from
|
|
;;; the stack op documentation (this seems easily doable)
|
|
;;; Hopefully these two are done, need testing...
|
|
|
|
;; ( -- a)
|
|
(defop (push a) (:lex nil)
|
|
("push ~d" a))
|
|
|
|
(defop + ()
|
|
(rbx rax -- (:add rax rbx)))
|
|
|
|
(defop - ()
|
|
(rbx rax -- (:sub rbx rax)))
|
|
|
|
(defop = ()
|
|
(:mov rcx 0)
|
|
(:mov rdx 1)
|
|
(rbx rax -- )
|
|
(:cmp rax rbx)
|
|
( -- (:cmove rcx rdx)))
|
|
|
|
(defop eş ()
|
|
(rax -- rax rax))
|
|
|
|
(defop düş ()
|
|
(rax -- ))
|
|
|
|
(defop < ()
|
|
(:mov rcx 0)
|
|
(:mov rdx 1)
|
|
(rax rbx -- )
|
|
(:cmp rax rbx)
|
|
( -- (:cmovl rcx rdx)))
|
|
|
|
(defop > ()
|
|
(:mov rcx 0)
|
|
(:mov rdx 1)
|
|
(rax rbx -- )
|
|
(:cmp rax rbx)
|
|
( -- (:cmovg rcx rdx)))
|
|
|
|
(defop bel ()
|
|
( -- bel))
|
|
|
|
(defop oku ()
|
|
(rax -- )
|
|
(:xor rbx rbx)
|
|
(:mov bl [rax])
|
|
( -- rbx))
|
|
|
|
(defop yaz ()
|
|
(rax rbx -- )
|
|
(:mov [rax] bl))
|
|
|
|
(defop üst ()
|
|
(rbx rax -- rbx rax rbx))
|
|
|
|
(defop rot ()
|
|
(rcx rbx rax -- rbx rax rcx))
|
|
|
|
(defop değiş ()
|
|
(rbx rax -- rax rbx))
|
|
|
|
(defop << ()
|
|
(rbx rcx -- (:shl rbx cl)))
|
|
|
|
(defop >> ()
|
|
(rbx rcx -- (:shr rbx cl)))
|
|
|
|
(defop "|" ()
|
|
(rbx rax -- (:or rbx rax)))
|
|
|
|
(defop & ()
|
|
(rbx rax -- (:and rbx rax)))
|
|
|
|
(defop dump ()
|
|
"pop rdi"
|
|
"call dump")
|
|
|
|
(defop (exit code) (:lex nil)
|
|
"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 (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 (syscall num) (:lex nil)
|
|
(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")))
|