245 lines
10 KiB
Common Lisp
245 lines
10 KiB
Common Lisp
(in-package :cl-forth)
|
|
|
|
(defun assembly-undefined-ops ()
|
|
(iter (for (k) in-hashtable *operations*)
|
|
(collect k into defops)
|
|
(finally (return (remove-if (lambda (sym) (search "SYSCALL" (string sym)))
|
|
(set-difference *identifiers* defops
|
|
:test #'string=))))))
|
|
|
|
(defun make-token (sym? line col)
|
|
(if (or (numberp sym?) (is-identifier 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))
|
|
|
|
;;; LEXER
|
|
(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= #\| next-char)
|
|
(read-char line-stream)
|
|
(collect (make-token "|" line-num col) into tokens))
|
|
((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 :external-format :utf-8)
|
|
(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 lex-string (string &optional report-errors)
|
|
(let ((has-error nil))
|
|
(values
|
|
(let ((str (make-string-input-stream string)))
|
|
(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)))
|
|
|
|
;;; PARSER
|
|
(defun parse-tokens (tokens)
|
|
(iter (with ops = (make-array (length tokens) :fill-pointer 0
|
|
:adjustable t))
|
|
(with stack = ())
|
|
(for i from 0)
|
|
(for token in tokens)
|
|
(let ((op (token-op token)))
|
|
(cond ((numberp op)
|
|
(vector-push-extend `(push ,op) ops))
|
|
((string= 'ise op)
|
|
(push (list 'ise i) stack)
|
|
(vector-push-extend (list 'ise nil) ops))
|
|
((string= 'yoksa op)
|
|
(let ((top (pop stack)))
|
|
(assert (string= 'ise (car top)))
|
|
(setf (second (aref ops (cadr top))) i)
|
|
(push (list 'yoksa i) stack)
|
|
(vector-push-extend (list 'yoksa nil i) ops)))
|
|
((string= 'yap op)
|
|
(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))
|
|
((string= '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))))))
|
|
((string= 'döngü op)
|
|
(push (list 'döngü i) stack)
|
|
(vector-push-extend (list 'döngü i) ops))
|
|
((string= 'iken op)
|
|
(let ((top (pop stack)))
|
|
(assert (string= 'döngü (car top)))
|
|
(push (list 'iken i (cadr top)) stack)
|
|
(vector-push-extend (list 'iken nil) ops)))
|
|
((search "syscall" (string-downcase (string op)))
|
|
(let ((syscall-num (parse-integer (subseq (string op) 8))))
|
|
(vector-push-extend (list 'syscall syscall-num) 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)))
|
|
|
|
|
|
;;; 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)
|
|
;; (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))
|
|
(format out "~a~%" "segment .text")
|
|
(gen-dump out)
|
|
(format out "~{~a~%~}" '("global _start"
|
|
"_start:"))
|
|
(iter (for op in-sequence program)
|
|
(gen-header op out)
|
|
(gen-code op out))
|
|
(gen-header '(exit 0) out)
|
|
(gen-code '(exit 0) out)
|
|
(format out "~a~%" "segment .bss")
|
|
(format out "~a ~a~%" "bel: resb" mem-cap))
|
|
|
|
(defun generate-program (program &key (path "output.asm") (compile nil)
|
|
(mem-cap 640000) (silence nil))
|
|
(with-open-file (out path :direction :output
|
|
:if-exists :supersede)
|
|
(write-program program out :mem-cap mem-cap))
|
|
(when compile
|
|
(run `("nasm" "-felf64" ,path) :output t :silence silence)
|
|
(let ((name (first (uiop:split-string path :separator '(#\.)))))
|
|
(run `("ld" "-o" ,name ,(concatenate 'string name ".o"))
|
|
:output t :silence silence))))
|
|
|
|
(defun compile-program (path)
|
|
(generate-program (make-program path) :compile t))
|
|
|
|
|