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

168
assembly.lisp
View File

@@ -15,6 +15,8 @@
(find sym *psuedo-identifiers* :test #'string=))) (find sym *psuedo-identifiers* :test #'string=)))
(eval-always (eval-always
(defparameter *targets* '(:nasm :c))
(defun normalize-op-list (asm-list) (defun normalize-op-list (asm-list)
(cons 'list (cons 'list
(mapcar (lambda (el) (cond ((stringp el) el) (mapcar (lambda (el) (cond ((stringp el) el)
@@ -67,12 +69,39 @@
((listp form) ((listp form)
(appending (op->string 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) (defun syntax-of (form)
(cond ((or (stringp form) (cond ((or (stringp form)
(and (consp form) (stringp (car form)))) (and (consp form) (stringp (car form))))
:string) :string)
((and (listp form) (find '-- form)) ((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))) ((and (listp form) (keywordp (car form)))
:op) :op)
(t :general))) (t :general)))
@@ -96,29 +125,60 @@
(defun expand-group (group out-stream &key (indent 4)) (defun expand-group (group out-stream &key (indent 4))
(destructuring-bind (syntax-type . forms) group (destructuring-bind (syntax-type . forms) group
(case syntax-type (case syntax-type
(:stack `(defop-format ,out-stream ,indent (:stack `((defop-format ,out-stream ,indent
,(cons 'list (mapcan (lambda (form) (stack->string form)) ,(cons 'list (mapcan (lambda (form) (stack->string form))
forms)))) forms)))))
(:op `(defop-format ,out-stream ,indent (:stack-extended (expand-nasm out-stream indent
,(cons 'list (mapcar (lambda (form) (op->string form :push? nil)) (stack-unextend (car forms))))
forms)))) (:op `((defop-format ,out-stream ,indent
(:string `(defop-format ,out-stream ,indent ,(cons 'list (mapcar (lambda (form) (op->string form :push? nil))
,(normalize-op-list forms))) forms)))))
(:general `(progn ,@(mapcar (lambda (form) (replace-write out-stream indent (:string `((defop-format ,out-stream ,indent
form)) ,(normalize-op-list forms))))
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) (with-gensyms (out-stream)
(destructuring-bind (op-name . args) (mklist op-name+args) (destructuring-bind (op-name . args) (mklist op-name+args)
`(progn `(progn
,@(unless (null lex) ,@(unless (null lex)
`((push ',op-name *identifiers*))) `((push ',op-name *identifiers*)))
(setf (gethash ,(string op-name) *operations*) ,@(iter (for target in (if (eq :all targets)
(lambda (,out-stream ,@args) *targets*
,@(mapcar #'(lambda (group) (expand-group group out-stream (mklist targets)))
:indent indent)) (collect (expand-method target out-stream indent
(group-by-syntax body)))))))) (if (null as) op-name as)
args body)))))))
;;; TODO: Turn stack operation comments to DEFOP option, ;;; TODO: Turn stack operation comments to DEFOP option,
;;; which then can be used by the user as a documentation ;;; which then can be used by the user as a documentation
@@ -126,15 +186,6 @@
;;; the stack op documentation (this seems easily doable) ;;; the stack op documentation (this seems easily doable)
;;; Hopefully these two are done, need testing... ;;; 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 + () (defop + ()
(rbx rax -- (:add rax rbx))) (rbx rax -- (:add rax rbx)))
@@ -142,11 +193,7 @@
(rbx rax -- (:sub rbx rax))) (rbx rax -- (:sub rbx rax)))
(defop = () (defop = ()
(:mov rcx 0) (rbx rax -- (:= rbx rax :ise 1 :değilse 0)))
(:mov rdx 1)
(rbx rax -- )
(:cmp rax rbx)
( -- (:cmove rcx rdx)))
(defop eş () (defop eş ()
(rax -- rax rax)) (rax -- rax rax))
@@ -155,32 +202,14 @@
(rax -- )) (rax -- ))
(defop < () (defop < ()
(:mov rcx 0) (rax rbx -- (:< rax rbx :ise 1 :değilse 0)))
(:mov rdx 1)
(rax rbx -- )
(:cmp rax rbx)
( -- (:cmovl rcx rdx)))
(defop > () (defop > ()
(:mov rcx 0) (rax rbx -- (:> rax rbx :ise 1 :değilse 0)))
(:mov rdx 1)
(rax rbx -- )
(:cmp rax rbx)
( -- (:cmovg rcx rdx)))
(defop bel () (defop bel ()
( -- bel)) ( -- bel))
(defop oku ()
(rax -- )
(:xor rbx rbx)
(:mov bl [rax])
( -- rbx))
(defop yaz ()
(rax rbx -- )
(:mov [rax] bl))
(defop üst () (defop üst ()
(rbx rax -- rbx rax rbx)) (rbx rax -- rbx rax rbx))
@@ -196,12 +225,31 @@
(defop >> () (defop >> ()
(rbx rcx -- (:shr rbx cl))) (rbx rcx -- (:shr rbx cl)))
(defop "|" () (defop "|" (:as pipe)
(rbx rax -- (:or rbx rax))) (rbx rax -- (:or rbx rax)))
(defop & () (defop & ()
(rbx rax -- (:and rbx rax))) (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 () (defop dump ()
"pop rdi" "pop rdi"
"call dump") "call dump")
@@ -257,12 +305,16 @@
(mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x)) (mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x))
op))) 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) (defun gen-code (op str)
(let ((op-fn (gethash (string (car op)) *operations*))) (gen-header op str)
(when (null op-fn) (write-op :nasm str (car op) (cdr op)))
(error "~s is not a valid op" op))
(gen-header op str)
(apply op-fn str (cdr op))))
(defun gen-dump (str) (defun gen-dump (str)
(format str "~{~a~%~}" (format str "~{~a~%~}"

115
cl-forth.lisp
View File

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

2
main.lisp
View File

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