201 lines
8.0 KiB
Common Lisp
201 lines
8.0 KiB
Common Lisp
(in-package :cl-forth)
|
|
|
|
(defun make-token (sym? line col &optional (type nil))
|
|
(when (null type)
|
|
(setf type
|
|
(cond ((numberp sym?) :number)
|
|
((stringp sym?) :string)
|
|
((is-identifier sym?) :identifier)
|
|
(t
|
|
;; temporary hack...
|
|
(return-from make-token
|
|
(values (list sym? :line line :col col :error t) t))))))
|
|
(values (list sym? :line line :col col :type type) nil))
|
|
|
|
(defun token-op (token)
|
|
(car token))
|
|
|
|
;;; LEXER
|
|
(defun read-string (stream)
|
|
;; TODO: Handle unmatched " and give proper error message
|
|
(with-output-to-string (str)
|
|
(iter (for ch = (read-char stream))
|
|
(cond ((char= ch #\")
|
|
(finish))
|
|
((and (char= ch #\\) (char= (peek-char nil stream) #\n))
|
|
(read-char stream)
|
|
(write-char #\Newline str))
|
|
(t (write-char ch str))))))
|
|
|
|
(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 :identifier) into tokens))
|
|
((char= #\Space next-char) (read-char line-stream))
|
|
((char= #\; next-char) ;; and not in string
|
|
(finish))
|
|
((char= #\" next-char)
|
|
(read-char line-stream)
|
|
(collect (make-token (read-string line-stream)
|
|
line-num col)
|
|
into tokens))
|
|
(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
|
|
(let ((err-token (find-if (lambda (tok) (find :error tok))
|
|
tokens)))
|
|
(format t "~5@a ~a~%"
|
|
(format nil "~a:" (getf (cdr err-token) :line))
|
|
line)
|
|
(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))
|
|
(op-type (getf (cdr token) :type)))
|
|
(cond ((eq :number op-type)
|
|
(vector-push-extend `(push-int ,op) ops))
|
|
((eq :string op-type)
|
|
(vector-push-extend `(push-str ,(length op) ,i ,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)))
|
|
|
|
;;; COMPILER
|
|
(defun write-program (program out &key (mem-cap 640000))
|
|
(format out "~a~%" "segment .text")
|
|
(gen-dump out)
|
|
(format out "~{~a~%~}" '("global _start"
|
|
"_start:"))
|
|
(let ((strs nil))
|
|
(iter (for op in-sequence program)
|
|
(let ((gen-val (gen-code op out)))
|
|
(when (and (consp gen-val) (eq :string (car gen-val)))
|
|
(push (cdr gen-val) strs))))
|
|
(gen-code '(exit 0) out)
|
|
(unless (null strs)
|
|
(format out "segment .data~%")
|
|
(dolist (str strs)
|
|
(format out "str_~a: db ~{0x~x~^,~}~%"
|
|
(first str)
|
|
(map 'list #'char-code (second str))))))
|
|
(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))
|
|
|
|
|