From 004c2b5628ba2db3297829a76a1e3983c62926ab Mon Sep 17 00:00:00 2001
From: mRnea <akannemre@gmail.com>
Date: Mon, 29 Jul 2024 23:15:38 +0300
Subject: some arrangements to fix quirks of symbols in the executable program
 note that (eq 'baz:foo bar:foo) is not true so some stuff that works in the
 repl fails in executable

---
 assembly.lisp |  6 +++---
 cl-forth.asd  |  1 +
 cl-forth.lisp | 34 ++++++++++++++++++++++++++++------
 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)))
 
@@ -49,6 +49,28 @@
   (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 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 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))
@@ -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))
diff --git a/util.lisp b/util.lisp
index e4a9ccb..9f80adb 100644
--- a/util.lisp
+++ b/util.lisp
@@ -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)
-- 
cgit v1.2.3