Improve lex error reporting, removed old interpreter comments

1 files changed, 16 insertions, 80 deletions

diff --git a/cl-forth.lisp b/cl-forth.lisp
index adacdd1..7cee812 100644
--- a/cl-forth.lisp
+++ b/cl-forth.lisp
@@ -53,10 +53,12 @@
                (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^~%"
+                     (format t "~5@a ~a~%"
+                             (format nil "~a:" (getf (cdr err-token) :line))
+                             line)
+                     (format t "      ~a^~%"
                              (make-string (getf (cdr err-token) :col)
                                           :initial-element #\Space)))))
                (appending tokens))))
@@ -133,90 +135,24 @@
       (error "Can't generate program due to error during lexing"))
     (parse-tokens tokens)))
 
-
-;;; INTERPRETER
-;; (eval-always
-;;   (define-condition op-not-implemented (style-warning)
-;;     ((undef-ops :initarg :ops :reader undef-ops))
-;;     (:report (lambda (condition stream)
-;;                (format stream "These ops are not defined in op-case: ~s"
-;;                        (undef-ops condition)))))
-  
-;;   (defun identifier-coverage (defined-ops)
-;;     (let ((undef-ops (set-difference *identifiers* defined-ops)))
-;;       (unless (null undef-ops)
-;;         (warn (make-condition 'op-not-implemented :ops undef-ops))))))
-
-;; (defmacro op-case (case-form &body body)
-;;   (iter (for (op-id) in body)
-;;         (when (not (is-identifier op-id))
-;;           (error "op-case: ~a is not an identifier" op-id))
-;;         (collect op-id into defined-ops)
-;;         (finally (identifier-coverage defined-ops)))
-;;   (let ((case-sym (gensym)))
-;;     `(let ((,case-sym ,case-form))
-;;        (case ,case-sym
-;;          ,@body
-;;          (otherwise (if (is-identifier (first ,case-sym))
-;;                         (error "op: ~a -- Not implemented yet"
-;;                                (first ,case-sym))
-;;                         (error "op: ~a -- Does not exist"
-;;                                (first ,case-sym))))))))
-
-;; (defun interpret-program (program)
-;;   (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
-;;         ;; (for op in-sequence program)
-;;         (for i from 0 below (length program))
-;;         (let ((op (aref program i)))
-;;           (op-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))
-;;             (dump (print (vector-pop stack)))
-;;             (= (vector-push-extend (if (= (vector-pop stack)
-;;                                           (vector-pop stack))
-;;                                        1 0)
-;;                                    stack))
-;;             (yap (next-iteration))
-;;             (yoksa (setf i (second op)))
-;;             (ise (if (= (vector-pop stack) 1)
-;;                      nil
-;;                      (setf i (second op))))
-;;             (eş (let ((top (vector-pop stack)))
-;;                   (vector-push-extend top stack)
-;;                   (vector-push-extend top stack)))
-;;             (değiş (let* ((fst (vector-pop stack))
-;;                           (snd (vector-pop stack)))
-;;                      (vector-push-extend fst stack)
-;;                      (vector-push-extend snd stack)))
-;;             (düş (vector-pop stack))
-;;             (üst (let* ((fst (vector-pop stack))
-;;                         (snd (vector-pop stack)))
-;;                    (vector-push-extend snd stack)
-;;                    (vector-push-extend fst stack)
-;;                    (vector-push-extend snd stack)))
-;;             (rot (let* ((fst (vector-pop stack))
-;;                         (snd (vector-pop stack))
-;;                         (trd (vector-pop stack)))
-;;                    (vector-push-extend snd stack)
-;;                    (vector-push-extend fst stack)
-;;                    (vector-push-extend trd stack)))))))
-
 ;;; COMPILER
 (defun write-program (program out &key (mem-cap 640000))
   (format out "~a~%" "segment .text")
   (gen-dump out)
   (format out "~{~a~%~}" '("global _start"
                            "_start:"))
-  (iter (for op in-sequence program)
-        (gen-header op out)
-        (gen-code op out))
-  (gen-header '(exit 0) out)
-  (gen-code '(exit 0) out)
+  (let ((strs nil))
+    (iter (for op in-sequence program)
+          (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)
+         (unless (null strs)
+           (format out "segment .data~%")
+           (dolist (str strs)
+             (format out "str_~a: db ~{0x~x~^,~}~%"
+                     (first str)
+                     (map 'list #'char-code (second str))))))
   (format out "~a~%" "segment .bss")
   (format out "~a ~a~%" "bel: resb" mem-cap))