diff options
| -rw-r--r-- | assembly.lisp | 72 | ||||
| -rwxr-xr-x | build.sh | 6 | ||||
| -rw-r--r-- | cl-forth.asd | 14 | ||||
| -rw-r--r-- | cl-forth.lisp | 140 | ||||
| -rw-r--r-- | main.lisp | 39 | ||||
| -rw-r--r-- | package.lisp | 3 | ||||
| -rw-r--r-- | test/prog.lorth | 6 | ||||
| -rw-r--r-- | util.lisp | 47 |
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))) + + |