diff options
Diffstat (limited to 'cl-forth.lisp')
| -rw-r--r-- | cl-forth.lisp | 153 |
1 files changed, 69 insertions, 84 deletions
diff --git a/cl-forth.lisp b/cl-forth.lisp index ab2da73..a22bb32 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -1,13 +1,5 @@ (in-package :cl-forth) -(eval-always - (defparameter *identifiers* - '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < > - syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6 - bel oku yaz >> << & "|")) - (defun is-identifier (sym) - (find sym *identifiers* :test #'string=))) - (defun assembly-undefined-ops () (iter (for (k) in-hashtable *operations*) (collect k into defops) @@ -150,83 +142,76 @@ ;;; INTERPRETER -(eval-always - (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))))) +;; (eval-always +;; (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 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)) - (dump (print (vector-pop stack))) - (= (vector-push-extend (if (= (vector-pop stack) - (vector-pop stack)) - 1 0) - stack)) - (yap (next-iteration)) - (yoksa (setf i (second op))) - (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 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 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)) +;; (dump (print (vector-pop stack))) +;; (= (vector-push-extend (if (= (vector-pop stack) +;; (vector-pop stack)) +;; 1 0) +;; stack)) +;; (yap (next-iteration)) +;; (yoksa (setf i (second op))) +;; (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))))))) ;;; COMPILER (defun write-program (program out &key (mem-cap 640000)) |