başlangıç, push pop + - . vb.

8 files changed, 327 insertions, 0 deletions

diff --git a/assembly.lisp b/assembly.lisp
new file mode 100644
index 0000000..3e80686
--- /dev/null
+++ b/assembly.lisp
@@ -0,0 +1,72 @@
+(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 args &body asm-strings)
+  `(setf (gethash ',op-name *operations*)
+         (lambda (out-stream ,@args)
+           (format out-stream "~{    ~a~%~}"
+                   ,(normalize-op-list asm-strings)))))
+
+
+(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 |.| ()
+  "pop rdi"
+  "call dump")
+
+(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")))
diff --git a/build.sh b/build.sh
new file mode 100755
index 0000000..80a559a
--- /dev/null
+++ b/build.sh
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+sbcl --load cl-forth.asd \
+     --eval '(ql:quickload :cl-forth)' \
+     --eval '(asdf:make :cl-forth)' \
+     --eval '(quit)'
diff --git a/cl-forth.asd b/cl-forth.asd
new file mode 100644
index 0000000..7c6f9ea
--- /dev/null
+++ b/cl-forth.asd
@@ -0,0 +1,14 @@
+(asdf:defsystem "cl-forth"
+  :description "Stack based language implemented in Common Lisp"
+  :version "0.1"
+  :author "Emre Akan"
+  :licence "MIT"
+  :depends-on ("iterate")
+  :components ((:file "package")
+               (:file "util")
+               (:file "assembly")
+               (:file "cl-forth")
+               (:file "main"))
+  :build-operation "program-op"
+  :build-pathname "test/cl-forth"
+  :entry-point "cl-forth:main")
diff --git a/cl-forth.lisp b/cl-forth.lisp
new file mode 100644
index 0000000..565e1f5
--- /dev/null
+++ b/cl-forth.lisp
@@ -0,0 +1,140 @@
+(in-package :cl-forth)
+
+(defparameter *identifiers* '(+ - |.| =))
+
+(defun is-identifier (sym)
+  (find sym *identifiers*))
+
+(defun make-token (sym? line col)
+  (if (or (is-identifier sym?) (numberp sym?))
+      (values (list sym? :line line :col col) nil)
+      (values (list sym? :line line :col col :error t) t)))
+
+(defun token-op (token)
+  (car token))
+
+(defun lex-line (line-stream line-num)
+  (iter (with col = 0)
+        (with has-err = nil)
+        (for next-char = (peek-char nil line-stream nil nil))
+        (until (null next-char))
+        (let ((flag t))
+          (cond ((char= #\. next-char)
+                 (collect (make-token '|.| line-num col) into tokens)
+                 (read-char line-stream))
+                ((char= #\Space next-char) (read-char line-stream))
+                ((char= #\; next-char) ;; and not in string
+                 (finish))
+                (t (setf flag nil)))
+          (when flag
+            (incf col)
+            (next-iteration)))
+        (for next-sym in-stream line-stream
+             using #'read-preserving-whitespace)
+        (multiple-value-bind (token err)
+            (make-token next-sym line-num col)
+          (collect token into tokens)
+          (when err ;; skip line on error and continue lexing
+            (setf has-err t)
+            (finish))
+          (incf col (length (princ-to-string next-sym))))
+        (finally (return (values tokens has-err)))))
+
+(defun lex-file (file-name &optional report-errors)
+  (let ((has-error nil))
+    (values
+     (with-open-file (str file-name)
+       (iter outer
+             (for line = (read-line str nil nil))
+             (until (null line))
+             (for line-num from 1)
+             (multiple-value-bind (tokens has-err)
+                 (lex-line (make-string-input-stream line) line-num)
+               (when has-err
+                 (setf has-error t)
+                 (when report-errors
+                   (format t "~a~%" line)
+                   (let ((err-token (find-if (lambda (tok) (find :error tok))
+                                             tokens)))
+                     (format t "~a^"
+                             (make-string (getf (cdr err-token) :col)
+                                          :initial-element #\Space)))))
+               (appending tokens))))
+     has-error)))
+
+;; (defun prog-from-tokens (tokens)
+;;   (iter (for token in tokens)
+;;         (let ((op (token-op token)))
+;;           (cond ((numberp op)
+;;                  (collect `(push ,op) result-type 'vector))
+;;                 (t (collect (list op) result-type 'vector))))))
+
+(defun parse-tokens (tokens)
+  (iter (with ops = (make-array (length tokens) :fill-pointer 0
+                                                :adjustable t))
+        (for i from 0)
+        (for token in tokens)
+        (let ((op (token-op token)))
+          (cond ((numberp op)
+                 (vector-push-extend `(push ,op) ops))
+                (t (vector-push-extend (list op) ops))))
+        (finally (return ops))))
+
+(defun make-program (file-name)
+  (multiple-value-bind (tokens has-error)
+      (lex-file file-name t)
+    (when has-error
+      (error "Can't generate program due to error during lexing"))
+    (parse-tokens tokens)))
+
+;; (defun *ops* '(push pop minus dump))
+
+(defun interpret-program (program)
+  (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
+        (for op in-sequence program)
+        (case (first op)
+          (push (vector-push-extend (second op) stack))
+          (+ (vector-push-extend (+ (vector-pop stack)
+                                    (vector-pop stack))
+                                 stack))
+          (- (vector-push-extend (let ((top (vector-pop stack)))
+                     (- (vector-pop stack) top))
+                   stack))
+          (|.| (print (vector-pop stack)))
+          (= (vector-push-extend (= (vector-pop stack)
+                                    (vector-pop stack))
+                                 stack))
+          (otherwise (error "op: ~a -- Not implemented yet" (first op))))))
+
+(defun gen-header (op str)
+  (format str "    ;; -- ~s --~%" op))
+
+;; (defun not-implemented (str)
+;;   (format str "    ;; -- TODO: not implemented --~%"))
+
+(defun generate-program (program &key (path "output.asm") (compile nil))
+  (with-open-file (out path :direction :output
+                            :if-exists :supersede)
+    (format out "~a~%" "segment .text")
+    (gen-dump out)
+    (format out "~{~a~%~}" '("global _start"
+                             "_start:"))
+    (iter (for op in-sequence program)
+          (gen-header op out)
+          (let ((op-fn (gethash (car op) *operations*)))
+            (if (null op-fn)
+                (format t "~s is not an op" (car op))
+                (apply op-fn out (cdr op)))))
+    (format out "~{~a~%~}" '("    mov rax, 60"
+                             "    mov rdi, 0"
+                             "    syscall")))
+  (when compile
+    (run `("nasm" "-felf64" ,path))
+    (let ((name (first (uiop:split-string path :separator '(#\.)))))
+      (run `("ld" "-o" ,name ,(concatenate 'string name ".o"))))))
+
+(defun compile-program (path)
+  (generate-program (make-program path) :compile t))
+
+
+
diff --git a/main.lisp b/main.lisp
new file mode 100644
index 0000000..716c76b
--- /dev/null
+++ b/main.lisp
@@ -0,0 +1,39 @@
+(in-package :cl-forth)
+
+(defun main ()
+  (let ((args (rest sb-ext:*posix-argv*)))
+    (let ((flag (first args)))
+      (cond ((string= flag "-c")
+             ;; (iter (for (k v) in-hashtable *operations*)
+             ;;       (for i from 0)
+             ;;       (format t "~s: ~s~%" i k))
+             ;; (let ((tokens (lex-file (second args))))
+             ;;   (format t "~s~%" tokens)
+             ;;   (let ((program (prog-from-tokens tokens)))
+             ;;     (format t "~s~%" program)
+             ;;     (generate-program program :compile t)))
+             (compile-program (second args)))
+            ((string= flag "-i")
+             (format t "Interpret program WIP~%"))
+            (t (format t "~a is not a valid flag~%" flag))))))
+
+;; (defun make-exe ()
+;;   (sb-ext:save-lisp-and-die #P"cl-forth"
+;;                             :toplevel #'main
+;;                             :executable t))
+
+(defparameter *example-path* "./test/prog.lorth") 
+
+(defun example-lex ()
+  (lex-file *example-path* t))
+
+(defun example-prog ()
+  (make-program *example-path*))
+
+(defun example-compile ()
+  (generate-program (make-program *example-path*) :path "test/output.asm"
+                                                  :compile t))
+
+(defun example-run ()
+  (example-compile)
+  (run '("test/output")))
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..76547a0
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,3 @@
+(defpackage cl-forth
+  (:use :common-lisp :iterate)
+  (:export #:main))
diff --git a/test/prog.lorth b/test/prog.lorth
new file mode 100644
index 0000000..3e78fbf
--- /dev/null
+++ b/test/prog.lorth
@@ -0,0 +1,6 @@
+2 3 + . ;; asddsaj 46
+10 6 - . ;; I am a comment
+
+   34    35     + .
+
+;;34 35 + 69 = .
diff --git a/util.lisp b/util.lisp
new file mode 100644
index 0000000..813f55b
--- /dev/null
+++ b/util.lisp
@@ -0,0 +1,47 @@
+(in-package :cl-forth)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro eval-always (&body body)
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       ,@body)))
+
+(eval-always 
+ (defmacro with-gensyms (syms &body body)
+   `(let ,(mapcar (lambda (sym) `(,sym (gensym ,(string sym)))) syms)
+      ,@body)))
+
+(defmacro init-hash (&body body)
+  (with-gensyms (table)
+    `(let ((,table (make-hash-table)))
+       ,@(iter (for (k v) in body)
+               (collect `(setf (gethash ',k ,table) ,v)))
+       ,table)))
+
+(defun mklist (form)
+  (if (listp form) form (list form)))
+
+;; (defmacro run (args)
+;;   (let ((sym (gensym)))
+;;     `(let ((,sym ,args))
+;;        (format t "~{~a~^ ~}~%" ,sym)
+;;        (uiop:run-program ,sym))))
+
+(defun run (args)
+  (format t "~{~a~^ ~}~%" args)
+  (uiop:run-program args :output *standard-output*))
+
+;; ,(file-namestring
+;;   (make-pathname :name (pathname-name path)
+;;                  :type "o"))
+
+(defparameter *test-program*
+  '((push 34)
+    (push 35)
+    (plus)
+    (dump)
+    (push 500)
+    (push 80)
+    (minus)
+    (dump)))
+
+