simyager/kurt
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

massive overhaul to defop, temporarily disable interpretation

Browse Source
This commit is contained in:
mRnea
2024-07-31 14:53:18 +03:00
parent 7f6bb99e08
commit e4419034ce
2 changed files with 229 additions and 206 deletions
Download Patch File Download Diff File Expand all files Collapse all files

149
cl-forth.lisp
View File

@@ -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))