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

changed . to dump, extended defop syntax, added while loops

Browse Source
This commit is contained in:
mRnea
2024-07-27 11:58:41 +03:00
parent 025c958e2f
commit 2d94db0990
2 changed files with 120 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

85
cl-forth.lisp
View File

@@ -2,7 +2,7 @@
(eval-always
(defparameter *identifiers*
'(+ - |.| = ise yoksa yap eş push değiş üst rot düş))
'(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >))
(defun is-identifier (sym)
(find sym *identifiers*)))
@@ -14,6 +14,7 @@
(defun token-op (token)
(car token))
;;; LEXER
(defun lex-line (line &optional (line-num 0))
(iter (with line-stream = (make-string-input-stream line))
(with col = 0)
@@ -21,13 +22,13 @@
(for next-char = (peek-char nil line-stream nil nil))
(until (null next-char))
(let ((flag t))
(cond ((char= #\. next-char)
(collect (make-token '|.| line-num col) into tokens)
(read-char line-stream))
((char= #\Space next-char) (read-char line-stream))
((char= #\; next-char) ;; and not in string
(finish))
(t (setf flag nil)))
(cond ;; ((char= #\. next-char)
;; (collect (make-token '|.| line-num col) into tokens)
;; (read-char line-stream))
((char= #\Space next-char) (read-char line-stream))
((char= #\; next-char) ;; and not in string
(finish))
(t (setf flag nil)))
(when flag
(incf col)
(next-iteration)))
@@ -64,34 +65,42 @@
(appending tokens))))
has-error)))
;; (defun prog-from-tokens (tokens)
;; (iter (for token in tokens)
;; (let ((op (token-op token)))
;; (cond ((numberp op)
;; (collect `(push ,op) result-type 'vector))
;; (t (collect (list op) result-type 'vector))))))
;;; PARSER
(defun parse-tokens (tokens)
(iter (with ops = (make-array (length tokens) :fill-pointer 0
:adjustable t))
(with if-stack = ())
(with stack = ())
(for i from 0)
(for token in tokens)
(let ((op (token-op token)))
(cond ((numberp op)
(vector-push-extend `(push ,op) ops))
((eq 'ise op)
(push i if-stack)
(push (list 'ise i) stack)
(vector-push-extend (list 'ise nil) ops))
((eq 'yoksa op)
(let ((current (pop if-stack)))
(setf (second (aref ops current)) i)
(push i if-stack)
(let ((top (pop stack)))
(assert (eq 'ise (car top)))
(setf (second (aref ops (cadr top))) i)
(push (list 'yoksa i) stack)
(vector-push-extend (list 'yoksa nil i) ops)))
((eq 'yap op)
(let ((current (pop if-stack)))
(setf (second (aref ops current)) i)
(vector-push-extend (list 'yap i) ops)))
(let ((top (pop stack)))
(cond ((find (car top) (list 'yoksa 'ise))
(setf (second (aref ops (cadr top))) i)
(vector-push-extend (list 'yap i) ops))
((eq 'iken (car top))
(setf (second (aref ops (cadr top))) i)
(vector-push-extend (list 'yap i (third top)) ops))
(t (error "yap cannot reference: ~a" (car top))))))
((eq 'döngü op)
(push (list 'döngü i) stack)
(vector-push-extend (list 'döngü i) ops))
((eq 'iken op)
(let ((top (pop stack)))
(assert (eq 'döngü (car top)))
(push (list 'iken i (cadr top)) stack)
(vector-push-extend (list 'iken nil) ops)))
(t (vector-push-extend (list op) ops))))
(finally (return ops))))
@@ -102,17 +111,19 @@
(error "Can't generate program due to error during lexing"))
(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)))))
;;; 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)))))
(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)
@@ -178,6 +189,9 @@
;; rot, rot
;; drop, düşür
;;; COMPILER
(defun gen-header (op str)
(format str " ;; -- ~s --~%" op))
@@ -203,5 +217,8 @@
(defun compile-program (path)
(generate-program (make-program path) :compile t))
(defun assembly-undefined-ops ()
(iter (for (k) in-hashtable *operations*)
(collect k into defops)
(finally (return (set-difference *identifiers* defops)))))