simyager/kurt
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

defop uses generic functions now. extended stack syntax

Browse Source
This commit is contained in:
mRnea
2024-08-06 23:02:14 +03:00
parent d989745845
commit b215590395
3 changed files with 170 additions and 115 deletions
Download Patch File Download Diff File Expand all files Collapse all files

158
assembly.lisp
View File

@@ -15,6 +15,8 @@
(find sym *psuedo-identifiers* :test #'string=)))
(eval-always
(defparameter *targets* '(:nasm :c))
(defun normalize-op-list (asm-list)
(cons 'list
(mapcar (lambda (el) (cond ((stringp el) el)
@@ -67,12 +69,39 @@
((listp form)
(appending (op->string form)))))))))
(defparameter *stack-fn-assoc* '((:= :cmove)
(:> :cmovg)
(:< :cmovl)))
(defun stack-unextend (stack)
"Turns an extended stack to body of a defop, second part of an extended stack is in the form of (:op arg1 arg2 :then val1 :else val2) which is asserted."
(multiple-value-bind (fst snd) (split-stack stack)
(assert (= 1 (length snd)))
(append (iter (for x in (reverse fst))
(let ((*print-case* :downcase))
(collect (format nil "pop ~a" x))))
(let* ((push-part (car snd))
(ifs (nthcdr 3 push-part)))
(list `(:mov rdx ,(getf ifs :ise))
`(:mov rcx ,(getf ifs :değilse))
`(:cmp ,(second push-part) ,(third push-part))
`(,(cadr (assoc (car push-part) *stack-fn-assoc*))
rcx rdx)
(format nil "push rcx"))))))
(defun syntax-of (form)
(cond ((or (stringp form)
(and (consp form) (stringp (car form))))
:string)
((and (listp form) (find '-- form))
:stack)
(if (multiple-value-bind (fst snd) (split-stack form)
(declare (ignore fst))
(and (consp snd)
(consp (car snd))
(find (caar snd) *stack-fn-assoc*
:key #'car)))
:stack-extended
:stack))
((and (listp form) (keywordp (car form)))
:op)
(t :general)))
@@ -96,29 +125,60 @@
(defun expand-group (group out-stream &key (indent 4))
(destructuring-bind (syntax-type . forms) group
(case syntax-type
(:stack `(defop-format ,out-stream ,indent
(:stack `((defop-format ,out-stream ,indent
,(cons 'list (mapcan (lambda (form) (stack->string form))
forms))))
(:op `(defop-format ,out-stream ,indent
forms)))))
(:stack-extended (expand-nasm out-stream indent
(stack-unextend (car 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
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)
(defun expand-nasm (out-stream indent body)
(mapcan #'(lambda (group) (expand-group group out-stream
:indent indent))
(group-by-syntax body)))
(defun expand-for-target (target out-stream body &optional (indent 4))
(case target
(:nasm (expand-nasm out-stream indent body))
(:c '(nil))))
(defun expand-method (target out-stream indent op-name args body)
(with-gensyms (_op _args _target)
(declare (ignorable _args))
`(defmethod write-op
((,_target (eql ,target)) ,out-stream
(,_op (eql ,(intern (string op-name) "KEYWORD")))
,_args)
,@(if (null args)
(expand-for-target target out-stream body indent)
`((destructuring-bind ,args ,_args
,@(expand-for-target target out-stream body indent))))))))
(defgeneric write-op (target stream op args)
(:documentation "Generate code for OP and ARGS and write it to STREAM according to the TARGET"))
(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets :nasm)
(as nil))
&body body)
(declare (ignorable indent))
(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))))))))
,@(iter (for target in (if (eq :all targets)
*targets*
(mklist targets)))
(collect (expand-method target out-stream indent
(if (null as) op-name as)
args body)))))))
;;; TODO: Turn stack operation comments to DEFOP option,
;;; which then can be used by the user as a documentation
@@ -126,15 +186,6 @@
;;; the stack op documentation (this seems easily doable)
;;; Hopefully these two are done, need testing...
;; ( -- a)
(defop (push-int a) (:lex nil)
("push ~d" a))
(defop (push-str len addr str) (:lex nil)
(progn (:write ("push ~d" len)
("push str_~d" addr))
(list :string addr str)))
(defop + ()
(rbx rax -- (:add rax rbx)))
@@ -142,11 +193,7 @@
(rbx rax -- (:sub rbx rax)))
(defop = ()
(:mov rcx 0)
(:mov rdx 1)
(rbx rax -- )
(:cmp rax rbx)
( -- (:cmove rcx rdx)))
(rbx rax -- (:= rbx rax :ise 1 :değilse 0)))
(defop eş ()
(rax -- rax rax))
@@ -155,32 +202,14 @@
(rax -- ))
(defop < ()
(:mov rcx 0)
(:mov rdx 1)
(rax rbx -- )
(:cmp rax rbx)
( -- (:cmovl rcx rdx)))
(rax rbx -- (:< rax rbx :ise 1 :değilse 0)))
(defop > ()
(:mov rcx 0)
(:mov rdx 1)
(rax rbx -- )
(:cmp rax rbx)
( -- (:cmovg rcx rdx)))
(rax rbx -- (:> rax rbx :ise 1 :değilse 0)))
(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))
@@ -196,12 +225,31 @@
(defop >> ()
(rbx rcx -- (:shr rbx cl)))
(defop "|" ()
(defop "|" (:as pipe)
(rbx rax -- (:or rbx rax)))
(defop & ()
(rbx rax -- (:and rbx rax)))
(defop oku ()
(rax -- )
(:xor rbx rbx)
(:mov bl [rax])
( -- rbx))
(defop yaz ()
(rax rbx -- )
(:mov [rax] bl))
;; ( -- a)
(defop (push-int a) (:lex nil)
("push ~d" a))
(defop (push-str len addr str) (:lex nil)
(progn (:write ("push ~d" len)
("push str_~d" addr))
(list :string addr str)))
(defop dump ()
"pop rdi"
"call dump")
@@ -257,12 +305,16 @@
(mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x))
op)))
;; (defun gen-code (op str)
;; (let ((op-fn (gethash (string (car op)) *operations*)))
;; (when (null op-fn)
;; (error "~s is not a valid op" op))
;; (gen-header op str)
;; (apply op-fn str (cdr op))))
(defun gen-code (op str)
(let ((op-fn (gethash (string (car op)) *operations*)))
(when (null op-fn)
(error "~s is not a valid op" op))
(gen-header op str)
(apply op-fn str (cdr op))))
(write-op :nasm str (car op) (cdr op)))
(defun gen-dump (str)
(format str "~{~a~%~}"

51
cl-forth.lisp
View File

@@ -28,6 +28,7 @@
(t (write-char ch str))))))
(defun lex-line (line &optional (line-num 0))
(let ((*package* (find-package "KEYWORD")))
(iter (with line-stream = (make-string-input-stream line))
(with col = 0)
(with has-err = nil)
@@ -39,7 +40,7 @@
;; (read-char line-stream))
((char= #\| next-char)
(read-char line-stream)
(collect (make-token "|" line-num col :identifier) into tokens))
(collect (make-token :pipe line-num col :identifier) into tokens))
((char= #\Space next-char) (read-char line-stream))
((char= #\; next-char) ;; and not in string
(finish))
@@ -61,7 +62,7 @@
(setf has-err t)
(finish))
(incf col (length (princ-to-string next-sym))))
(finally (return (values tokens has-err)))))
(finally (return (values tokens has-err))))))
(defun lex-file (file-name &optional report-errors)
(let ((has-error nil))
@@ -119,39 +120,39 @@
(let ((op (token-op token))
(op-type (getf (cdr token) :type)))
(cond ((eq :number op-type)
(vector-push-extend `(push-int ,op) ops))
(vector-push-extend `(:push-int ,op) ops))
((eq :string op-type)
(vector-push-extend `(push-str ,(length op) ,i ,op)
(vector-push-extend `(:push-str ,(length op) ,i ,op)
ops))
((string= 'ise op)
(push (list 'ise i) stack)
(vector-push-extend (list 'ise nil) ops))
((string= 'yoksa op)
((string= :ise op)
(push (list :ise i) stack)
(vector-push-extend (list :ise nil) ops))
((string= :yoksa op)
(let ((top (pop stack)))
(assert (string= 'ise (car top)))
(assert (string= :ise (car top)))
(setf (second (aref ops (cadr top))) i)
(push (list 'yoksa i) stack)
(vector-push-extend (list 'yoksa nil i) ops)))
((string= 'yap op)
(push (list :yoksa i) stack)
(vector-push-extend (list :yoksa nil i) ops)))
((string= :yap op)
(let ((top (pop stack)))
(cond ((find (car top) (list 'yoksa 'ise))
(cond ((find (car top) (list :yoksa :ise))
(setf (second (aref ops (cadr top))) i)
(vector-push-extend (list 'yap i) ops))
((string= 'iken (car top))
(vector-push-extend (list :yap i) ops))
((string= :iken (car top))
(setf (second (aref ops (cadr top))) i)
(vector-push-extend (list 'yap i (third top)) ops))
(vector-push-extend (list :yap i (third top)) ops))
(t (error "yap cannot reference: ~a" (car top))))))
((string= 'döngü op)
(push (list 'döngü i) stack)
(vector-push-extend (list 'döngü i) ops))
((string= 'iken op)
((string= :döngü op)
(push (list :döngü i) stack)
(vector-push-extend (list :döngü i) ops))
((string= :iken op)
(let ((top (pop stack)))
(assert (string= 'döngü (car top)))
(push (list 'iken i (cadr top)) stack)
(vector-push-extend (list 'iken nil) ops)))
(assert (string= :döngü (car top)))
(push (list :iken i (cadr top)) stack)
(vector-push-extend (list :iken nil) ops)))
((search "syscall" (string-downcase (string op)))
(let ((syscall-num (parse-integer (subseq (string op) 8))))
(vector-push-extend (list 'syscall syscall-num) ops)))
(vector-push-extend (list :syscall syscall-num) ops)))
(t (vector-push-extend (list op) ops))))
(finally (return ops))))
@@ -173,7 +174,7 @@
(let ((gen-val (gen-code op out)))
(when (and (consp gen-val) (eq :string (car gen-val)))
(push (cdr gen-val) strs))))
(gen-code '(exit 0) out)
(gen-code '(:exit 0) out)
(unless (null strs)
(format out "segment .data~%")
(dolist (str strs)

2
main.lisp
View File

@@ -15,6 +15,8 @@
(compile-program (second args)))
((string= flag "-i")
(interpret-program (make-program (second args))))
((string= flag "-p")
(format t "~a" (make-program (second args))))
((string= flag "-t")
(run-tests))
(t (format t "~a is not a valid flag~%" flag))))))