From 7fa561a9d9651f36de5aaf40a8faf533a5effc61 Mon Sep 17 00:00:00 2001
From: mRnea <akannemre@gmail.com>
Date: Tue, 23 Jul 2024 16:17:16 +0300
Subject: added op-case and some conditions for it (error checking)
---
cl-forth.lisp | 105 ++++++++++++++++++++++++++++++++++++++++++++++------------
1 file changed, 84 insertions(+), 21 deletions(-)
diff --git a/cl-forth.lisp b/cl-forth.lisp
index 565e1f5..14b6573 100644
--- a/cl-forth.lisp
+++ b/cl-forth.lisp
@@ -1,9 +1,10 @@
(in-package :cl-forth)
-(defparameter *identifiers* '(+ - |.| =))
-
-(defun is-identifier (sym)
- (find sym *identifiers*))
+(eval-always
+ (defparameter *identifiers*
+ '(+ - |.| = ise yoksa yap eş push değiş üst rot düş))
+ (defun is-identifier (sym)
+ (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)
- (iter (with col = 0)
+(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))
@@ -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,23 +95,79 @@
(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)
- (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))
- (|.| (print (vector-pop stack)))
- (= (vector-push-extend (= (vector-pop stack)
- (vector-pop stack))
- stack))
- (otherwise (error "op: ~a -- Not implemented yet" (first op))))))
+ ;; (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))
+ (|.| (print (vector-pop stack)))
+ (= (vector-push-extend (if (= (vector-pop stack)
+ (vector-pop stack))
+ 1 0)
+ stack))
+ (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))
--
cgit v1.2.3