diff options
| -rw-r--r-- | cl-forth.lisp | 105 |
1 files 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)) |