defop uses generic functions now. extended stack syntax

1 files changed, 58 insertions, 57 deletions

diff --git a/cl-forth.lisp b/cl-forth.lisp
index 1026253..ec7927f 100644
--- a/cl-forth.lisp
+++ b/cl-forth.lisp
@@ -28,40 +28,41 @@
                 (t (write-char ch str))))))
 
 (defun lex-line (line &optional (line-num 0))
-  (iter (with line-stream = (make-string-input-stream line))
-        (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= #\|  next-char)
-             (read-char line-stream)
-             (collect (make-token "|" line-num col :identifier) into tokens))
-            ((char= #\Space next-char) (read-char line-stream))
-            ((char= #\; next-char) ;; and not in string
-             (finish))
-            ((char= #\" next-char)
-             (read-char line-stream)
-             (collect (make-token (read-string line-stream)
-                                  line-num col)
-               into tokens))
-            (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)))))
+  (let ((*package* (find-package "KEYWORD")))
+    (iter (with line-stream = (make-string-input-stream line))
+          (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= #\|  next-char)
+               (read-char line-stream)
+               (collect (make-token :pipe line-num col :identifier) into tokens))
+              ((char= #\Space next-char) (read-char line-stream))
+              ((char= #\; next-char) ;; and not in string
+               (finish))
+              ((char= #\" next-char)
+               (read-char line-stream)
+               (collect (make-token (read-string line-stream)
+                                    line-num col)
+                 into tokens))
+              (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))
@@ -119,39 +120,39 @@
         (let ((op (token-op token))
               (op-type (getf (cdr token) :type)))
           (cond ((eq :number op-type)
-                 (vector-push-extend `(push-int ,op) ops))
+                 (vector-push-extend `(:push-int ,op) ops))
                 ((eq :string op-type)
-                 (vector-push-extend `(push-str ,(length op) ,i ,op)
+                 (vector-push-extend `(:push-str ,(length op) ,i ,op)
                                      ops))
-                ((string= 'ise op)
-                 (push (list 'ise i) stack)
-                 (vector-push-extend (list 'ise nil) ops))
-                ((string= 'yoksa op)
+                ((string= :ise op)
+                 (push (list :ise i) stack)
+                 (vector-push-extend (list :ise nil) ops))
+                ((string= :yoksa op)
                  (let ((top (pop stack)))
-                   (assert (string= 'ise (car top)))
+                   (assert (string= :ise (car top)))
                    (setf (second (aref ops (cadr top))) i)
-                   (push (list 'yoksa i) stack)
-                   (vector-push-extend (list 'yoksa nil i) ops)))
-                ((string= 'yap op)
+                   (push (list :yoksa i) stack)
+                   (vector-push-extend (list :yoksa nil i) ops)))
+                ((string= :yap op)
                  (let ((top (pop stack)))
-                   (cond ((find (car top) (list 'yoksa 'ise))
+                   (cond ((find (car top) (list :yoksa :ise))
                           (setf (second (aref ops (cadr top))) i)
-                          (vector-push-extend (list 'yap i) ops))
-                         ((string= 'iken (car top))
+                          (vector-push-extend (list :yap i) ops))
+                         ((string= :iken (car top))
                           (setf (second (aref ops (cadr top))) i)
-                          (vector-push-extend (list 'yap i (third top)) ops))
+                          (vector-push-extend (list :yap i (third top)) ops))
                          (t (error "yap cannot reference: ~a" (car top))))))
-                ((string= 'döngü op)
-                 (push (list 'döngü i) stack)
-                 (vector-push-extend (list 'döngü i) ops))
-                ((string= 'iken op)
+                ((string= :döngü op)
+                 (push (list :döngü i) stack)
+                 (vector-push-extend (list :döngü i) ops))
+                ((string= :iken op)
                  (let ((top (pop stack)))
-                   (assert (string= 'döngü (car top)))
-                   (push (list 'iken i (cadr top)) stack)
-                   (vector-push-extend (list 'iken nil) ops)))
+                   (assert (string= :döngü (car top)))
+                   (push (list :iken i (cadr top)) stack)
+                   (vector-push-extend (list :iken nil) ops)))
                 ((search "syscall" (string-downcase (string op)))
                  (let ((syscall-num (parse-integer (subseq (string op) 8))))
-                   (vector-push-extend (list 'syscall syscall-num) ops)))
+                   (vector-push-extend (list :syscall syscall-num) ops)))
                 (t (vector-push-extend (list op) ops))))
         (finally (return ops))))
 
@@ -173,7 +174,7 @@
           (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)
+         (gen-code '(:exit 0) out)
          (unless (null strs)
            (format out "segment .data~%")
            (dolist (str strs)