diff options
| -rw-r--r-- | assembly.lisp | 6 | ||||
| -rw-r--r-- | cl-forth.asd | 1 | ||||
| -rw-r--r-- | cl-forth.lisp | 34 | ||||
| -rw-r--r-- | util.lisp | 5 |
4 files changed, 35 insertions, 11 deletions
diff --git a/assembly.lisp b/assembly.lisp index e2b62f1..81b0ca1 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -1,6 +1,6 @@ (in-package :cl-forth) -(defparameter *operations* (make-hash-table)) +(defparameter *operations* (make-hash-table :test 'equal)) (eval-always (defun normalize-op-list (asm-list) @@ -27,7 +27,7 @@ (defmacro defop (op-name+args (&key (indent 4)) &body body) (with-gensyms (out-stream) (destructuring-bind (op-name . args) (mklist op-name+args) - `(setf (gethash ',op-name *operations*) + `(setf (gethash ,(string op-name) *operations*) (lambda (,out-stream ,@args) ,(if (or (stringp (car body)) (stringp (caar body))) `(defop-format ,out-stream ,indent @@ -141,7 +141,7 @@ (format str " ;; -- ~s --~%" op)) (defun gen-code (op str) - (let ((op-fn (gethash (car op) *operations*))) + (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))))) diff --git a/cl-forth.asd b/cl-forth.asd index 7c6f9ea..cb77107 100644 --- a/cl-forth.asd +++ b/cl-forth.asd @@ -4,6 +4,7 @@ :author "Emre Akan" :licence "MIT" :depends-on ("iterate") + :serial t :components ((:file "package") (:file "util") (:file "assembly") diff --git a/cl-forth.lisp b/cl-forth.lisp index e4b166c..5291ceb 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -6,10 +6,10 @@ syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6 bel oku yaz)) (defun is-identifier (sym) - (find sym *identifiers*))) + (find sym *identifiers* :test #'string=))) (defun make-token (sym? line col) - (if (or (is-identifier sym?) (numberp sym?)) + (if (or (numberp sym?) (is-identifier sym?)) (values (list sym? :line line :col col) nil) (values (list sym? :line line :col col :error t) t))) @@ -61,6 +61,28 @@ (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 lex-string (string &optional report-errors) + (let ((has-error nil)) + (values + (let ((str (make-string-input-stream string))) + (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 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))))) @@ -159,7 +181,7 @@ (- (vector-push-extend (let ((top (vector-pop stack))) (- (vector-pop stack) top)) stack)) - (|.| (print (vector-pop stack))) + (dump (print (vector-pop stack))) (= (vector-push-extend (if (= (vector-pop stack) (vector-pop stack)) 1 0) @@ -211,15 +233,15 @@ (format out "~a ~a~%" "bel: resb" mem-cap)) (defun generate-program (program &key (path "output.asm") (compile nil) - (mem-cap 640000)) + (mem-cap 640000) (silence nil)) (with-open-file (out path :direction :output :if-exists :supersede) (write-program program out :mem-cap mem-cap)) (when compile - (run `("nasm" "-felf64" ,path) :output t) + (run `("nasm" "-felf64" ,path) :output t :silence silence) (let ((name (first (uiop:split-string path :separator '(#\.))))) (run `("ld" "-o" ,name ,(concatenate 'string name ".o")) - :output t)))) + :output t :silence silence)))) (defun compile-program (path) (generate-program (make-program path) :compile t)) @@ -20,8 +20,9 @@ (defun mklist (form) (if (listp form) form (list form))) -(defun run (args &rest options) - (format t "~{~a~^ ~}~%" args) +(defun run (args &rest options &key &allow-other-keys) + (unless (eq t (getf options :silence)) + (format t "~{~a~^ ~}~%" args)) (apply #'uiop:run-program args options)) (defun from-root (path) |