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

1 files changed, 28 insertions, 6 deletions

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))