added op-case and some conditions for it (error checking)

cl-forth.lisp

@@ -1,9 +1,10 @@
 (in-package :cl-forth)
 
-(defparameter *identifiers* '(+ - |.| =))
+(eval-always
-
+  (defparameter *identifiers*
+    '(+ - |.| = ise yoksa yap eş push değiş üst rot düş))
   (defun is-identifier (sym)
-  (find sym *identifiers*))
+    (find sym *identifiers*)))
 
 (defun make-token (sym? line col)
   (if (or (is-identifier sym?) (numberp sym?))
@@ -13,8 +14,9 @@
 (defun token-op (token)
   (car token))
 
-(defun lex-line (line-stream line-num)
+(defun lex-line (line &optional (line-num 0))
-  (iter (with col = 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))
@@ -49,7 +51,7 @@
              (until (null line))
              (for line-num from 1)
              (multiple-value-bind (tokens has-err)
-                 (lex-line (make-string-input-stream line) line-num)
+                 (lex-line line line-num)
                (when has-err
                  (setf has-error t)
                  (when report-errors
@@ -77,6 +79,11 @@
         (let ((op (token-op token)))
           (cond ((numberp op)
                  (vector-push-extend `(push ,op) ops))
+                ((eq 'ise op)
+                 (vector-push-extend
+                  `(ise ,(position 'yap tokens :start i :key #'token-op))
+                  ops))
+                ;; currently does not handle nesting
                 (t (vector-push-extend (list op) ops))))
         (finally (return ops))))
 
@@ -88,11 +95,39 @@
     (parse-tokens tokens)))
 
 ;; (defun *ops* '(push pop minus dump))
+(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 op in-sequence program)
-        (case (first op)
+        (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))
@@ -101,10 +136,38 @@
                                      (- (vector-pop stack) top))
                                    stack))
             (|.| (print (vector-pop stack)))
-          (= (vector-push-extend (= (vector-pop stack)
+            (= (vector-push-extend (if (= (vector-pop stack)
                                           (vector-pop stack))
+                                       1 0)
                                    stack))
-          (otherwise (error "op: ~a -- Not implemented yet" (first op))))))
+            (yap (next-iteration))
+            (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)))))))
+;; swap, değiş 
+;; dup, eş
+;; over, üst
+;; rot, rot
+;; drop, düşür
 
 (defun gen-header (op str)
   (format str "    ;; -- ~s --~%" op))