141 lines
5.1 KiB
Common Lisp
141 lines
5.1 KiB
Common Lisp
(in-package :cl-forth)
|
|
|
|
(defparameter *identifiers* '(+ - |.| =))
|
|
|
|
(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-stream line-num)
|
|
(iter (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 (make-string-input-stream 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))
|
|
(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))
|
|
|
|
(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))))))
|
|
|
|
(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))
|
|
|
|
|
|
|