204 lines
7.8 KiB
Common Lisp
204 lines
7.8 KiB
Common Lisp
(in-package :cl-forth)
|
|
|
|
(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?))
|
|
(values (list sym? :line line :col col) nil)
|
|
(values (list sym? :line line :col col :error t) t)))
|
|
|
|
(defun token-op (token)
|
|
(car token))
|
|
|
|
(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))
|
|
(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)))
|
|
(when flag
|
|
(incf col)
|
|
(next-iteration)))
|
|
(for next-sym in-stream line-stream
|
|
using #'read-preserving-whitespace)
|
|
(multiple-value-bind (token err)
|
|
(make-token next-sym line-num col)
|
|
(collect token into tokens)
|
|
(when err ;; skip line on error and continue lexing
|
|
(setf has-err t)
|
|
(finish))
|
|
(incf col (length (princ-to-string next-sym))))
|
|
(finally (return (values tokens has-err)))))
|
|
|
|
(defun lex-file (file-name &optional report-errors)
|
|
(let ((has-error nil))
|
|
(values
|
|
(with-open-file (str file-name)
|
|
(iter outer
|
|
(for line = (read-line str nil nil))
|
|
(until (null line))
|
|
(for line-num from 1)
|
|
(multiple-value-bind (tokens has-err)
|
|
(lex-line line line-num)
|
|
(when has-err
|
|
(setf has-error t)
|
|
(when report-errors
|
|
(format t "~a~%" line)
|
|
(let ((err-token (find-if (lambda (tok) (find :error tok))
|
|
tokens)))
|
|
(format t "~a^"
|
|
(make-string (getf (cdr err-token) :col)
|
|
:initial-element #\Space)))))
|
|
(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))))))
|
|
|
|
(defun parse-tokens (tokens)
|
|
(iter (with ops = (make-array (length tokens) :fill-pointer 0
|
|
:adjustable t))
|
|
(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)
|
|
(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))))
|
|
|
|
(defun make-program (file-name)
|
|
(multiple-value-bind (tokens has-error)
|
|
(lex-file file-name t)
|
|
(when has-error
|
|
(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)))))
|
|
|
|
(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))
|
|
(|.| (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))
|
|
|
|
;; (defun not-implemented (str)
|
|
;; (format str " ;; -- TODO: not implemented --~%"))
|
|
|
|
(defun generate-program (program &key (path "output.asm") (compile nil))
|
|
(with-open-file (out path :direction :output
|
|
:if-exists :supersede)
|
|
(format out "~a~%" "segment .text")
|
|
(gen-dump out)
|
|
(format out "~{~a~%~}" '("global _start"
|
|
"_start:"))
|
|
(iter (for op in-sequence program)
|
|
(gen-header op out)
|
|
(let ((op-fn (gethash (car op) *operations*)))
|
|
(if (null op-fn)
|
|
(format t "~s is not an op" (car op))
|
|
(apply op-fn out (cdr op)))))
|
|
(format out "~{~a~%~}" '(" mov rax, 60"
|
|
" mov rdi, 0"
|
|
" syscall")))
|
|
(when compile
|
|
(run `("nasm" "-felf64" ,path))
|
|
(let ((name (first (uiop:split-string path :separator '(#\.)))))
|
|
(run `("ld" "-o" ,name ,(concatenate 'string name ".o"))))))
|
|
|
|
(defun compile-program (path)
|
|
(generate-program (make-program path) :compile t))
|
|
|
|
|
|
|