276 lines
10 KiB
Common Lisp
276 lines
10 KiB
Common Lisp
(in-package :kurt)
|
|
|
|
(defun make-token (sym? line col &optional (type nil))
|
|
(when (null type)
|
|
(setf type
|
|
(cond ((consp sym? ) :list)
|
|
((numberp sym?) :number)
|
|
((stringp sym?) :string)
|
|
((is-identifier sym?) :identifier)
|
|
(t :unknown))))
|
|
(list sym? :line line :col col :type type))
|
|
|
|
(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 read-character (stream)
|
|
(let ((ch? (read-char stream)))
|
|
(if (not (char-equal ch? #\\))
|
|
(if (char-equal #\' (peek-char nil stream))
|
|
(progn (read-char stream) ch?)
|
|
(error "Unterminated char."))
|
|
(progn (case (read-char stream)
|
|
(#\n (setf ch? #\Newline)))
|
|
(if (char-equal #\' (peek-char nil stream))
|
|
(progn (read-char stream) ch?)
|
|
(error "Unterminated char."))))))
|
|
|
|
(defun lex-line (line &optional (line-num 0))
|
|
(let ((*package* (find-package "KEYWORD")))
|
|
(iter (with line-stream = (make-string-input-stream line))
|
|
(with col = 0)
|
|
(for next-char = (peek-char nil line-stream nil nil))
|
|
(until (null next-char))
|
|
(let ((flag t))
|
|
(cond ((char= #\| next-char)
|
|
(read-char line-stream)
|
|
(collect (make-token :pipe 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 :string)
|
|
into tokens))
|
|
((char= #\' next-char)
|
|
(read-char line-stream)
|
|
(collect (make-token (read-character line-stream)
|
|
line-num col :char)
|
|
into tokens))
|
|
(t (setf flag nil)))
|
|
(when flag
|
|
(incf col) ;; TODO: currently this is wrong for char and strings
|
|
(next-iteration)))
|
|
(for next-sym in-stream line-stream
|
|
using #'read-preserving-whitespace)
|
|
(collect (make-token next-sym line-num col) into tokens)
|
|
(incf col (length (princ-to-string next-sym)))
|
|
(finally (return tokens)))))
|
|
|
|
(defun lex-stream (str)
|
|
(iter (for line = (read-line str nil nil))
|
|
(until (null line))
|
|
(for line-num from 1)
|
|
(appending (lex-line line line-num))))
|
|
|
|
(defun lex-file (file-name)
|
|
(with-open-file (str file-name :external-format :utf-8)
|
|
(lex-stream str)))
|
|
|
|
(defun lex-string (string)
|
|
(lex-stream (make-string-input-stream string)))
|
|
|
|
|
|
|
|
;;; PARSER
|
|
(defmacro add-op (token parser)
|
|
`(progn (vector-push-extend ,token (ops ,parser))
|
|
(incf (index ,parser))))
|
|
|
|
(defparameter *makro-defs* (make-hash-table))
|
|
|
|
(defclass parser ()
|
|
((if-stack :initform ()
|
|
:accessor if-stack)
|
|
(ops :accessor ops)
|
|
(tokens :initarg :tokens
|
|
:accessor tokens)
|
|
(index :initform 0
|
|
:accessor index)))
|
|
|
|
(defun make-parser (tokens)
|
|
(let ((parser (make-instance 'parser :tokens tokens)))
|
|
(setf (ops parser) (make-array (length tokens) :fill-pointer 0
|
|
:adjustable t))
|
|
parser))
|
|
|
|
(defmethod peek-token ((parser parser))
|
|
(car (tokens parser)))
|
|
|
|
(defmethod read-token ((parser parser))
|
|
(pop (tokens parser)))
|
|
|
|
(defmethod parse-token ((parser parser) (type (eql :number)))
|
|
(add-op `(:push-int ,(car (read-token parser))) parser))
|
|
|
|
(defmethod parse-token ((parser parser) (type (eql :char)))
|
|
(add-op `(:push-int ,(char-code (car (read-token parser)))) parser))
|
|
|
|
(defmethod parse-token ((parser parser) (type (eql :string)))
|
|
(let ((token (read-token parser)))
|
|
(add-op `(:push-str ,(length (car token))
|
|
,(index parser)
|
|
,(car token))
|
|
parser)))
|
|
|
|
(defmethod parse-token ((parser parser) (type (eql :identifier)))
|
|
(let ((token (read-token parser)))
|
|
(parse-op parser token (car token))))
|
|
|
|
(defmethod parse-token ((parser parser) (type (eql :unknown)))
|
|
(let* ((token (read-token parser))
|
|
(makrodef (gethash (car token) *makro-defs*)))
|
|
(if (not (null makrodef))
|
|
;; (parser-parse-tokens parser makrodef)
|
|
(setf (tokens parser) (append makrodef (tokens parser)))
|
|
(error "parse-token: token has unknown identifier: ~a"
|
|
(read-token parser)))))
|
|
|
|
;; (defmethod parser-parse-tokens ((parser parser) tokens)
|
|
;; (iter (for makro-op in-vector)
|
|
;; (add-op makro-op ops))
|
|
;; ())
|
|
|
|
(defmethod parse-op ((parser parser) token (type (eql :ise)))
|
|
(push (list :ise (index parser)) (if-stack parser))
|
|
(add-op (list :ise nil) parser))
|
|
|
|
(defmethod parse-op ((parser parser) token (type (eql :yoksa)))
|
|
(let ((top (pop (if-stack parser))))
|
|
(assert (and (string= :ise (car top))
|
|
(string= :ise (car (aref (ops parser) (cadr top))))))
|
|
(setf (second (aref (ops parser) (cadr top))) (index parser))
|
|
(push (list :yoksa (index parser)) (if-stack parser))
|
|
(add-op (list :yoksa nil (index parser)) parser)))
|
|
|
|
(defmethod parse-op ((parser parser) token (type (eql :yap)))
|
|
(let ((top (pop (if-stack parser))))
|
|
(unless (and (find (car top) (list :yoksa :ise :iken))
|
|
(find (car (aref (ops parser) (cadr top)))
|
|
(list :yoksa :ise :iken)))
|
|
(error "yap cannot close ~a" (aref (ops parser) (cadr top))))
|
|
(cond ((find (car top) (list :yoksa :ise))
|
|
(setf (second (aref (ops parser) (cadr top))) (index parser))
|
|
(add-op (list :yap (index parser)) parser))
|
|
((string= :iken (car top))
|
|
(setf (second (aref (ops parser) (cadr top))) (index parser))
|
|
(add-op (list :yap (index parser) (third top)) parser))
|
|
(t (error "yap cannot reference: ~a" (car top))))))
|
|
|
|
(defmethod parse-op ((parser parser) token (type (eql :döngü)))
|
|
(push (list :döngü (index parser)) (if-stack parser))
|
|
(add-op (list :döngü (index parser)) parser))
|
|
|
|
(defmethod parse-op ((parser parser) token (type (eql :iken)))
|
|
(let ((top (pop (if-stack parser))))
|
|
(assert (string= :döngü (car top)))
|
|
(push (list :iken (index parser) (cadr top)) (if-stack parser))
|
|
(add-op (list :iken nil) parser)))
|
|
|
|
(defmethod parse-op ((parser parser) token (type (eql :makro)))
|
|
;; makro name must be undefined before
|
|
(let ((makro-name-tok (read-token parser)))
|
|
(assert (eq :unknown (getf (cdr makro-name-tok) :type)))
|
|
(let ((doc? (peek-token parser)))
|
|
(when (eq :list (getf (cdr doc?) :type))
|
|
(read-token parser)
|
|
;; setf doc?
|
|
))
|
|
(setf (gethash (car makro-name-tok) *makro-defs*)
|
|
(do ((tok (read-token parser)
|
|
(read-token parser))
|
|
(makrodef ()))
|
|
((eq :son (car tok)) (reverse makrodef))
|
|
(push tok makrodef)))))
|
|
|
|
(defmethod parse-op ((parser parser) token type)
|
|
(cond ((search "syscall" (string-downcase (string (car token))))
|
|
(let ((syscall-num (parse-integer (subseq (string (car token)) 8))))
|
|
(add-op (list :syscall syscall-num) parser)))
|
|
(t (add-op (list type) parser))))
|
|
|
|
(defmethod parse-op ((parser parser) token (type (eql :kütüphane)))
|
|
(let ((file (car (read-token parser))))
|
|
(setf (tokens parser) (append (lex-file file) (tokens parser)))))
|
|
|
|
(defun parse-tokens (tokens)
|
|
(let ((parser (make-parser tokens)))
|
|
(iter (while (not (null (tokens parser))))
|
|
(parse-token parser (getf (cdr (peek-token parser)) :type)))
|
|
(ops parser)))
|
|
|
|
(defun make-program (file-name)
|
|
(parse-tokens (lex-file file-name)))
|
|
|
|
;;; COMPILER
|
|
;;(defgeneric write-program (target program stream))
|
|
(defmethod write-program ((target (eql :nasm)) 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 (write-op target out (car op) (cdr op))))
|
|
(when (and (consp gen-val) (eq :string (car gen-val)))
|
|
(push (cdr gen-val) strs))))
|
|
(write-op target out :exit '(0))
|
|
(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))
|
|
|
|
(defmethod write-program ((target (eql :c)) program out &key (mem-cap 640000))
|
|
(declare (ignore mem-cap))
|
|
(gen-c-stack out)
|
|
(with-c-fn (:int main) () out
|
|
(iter (for op in-sequence program)
|
|
(write-op target out (car op) (cdr op)))
|
|
(format out "~% return 0;~%")))
|
|
|
|
(defun generate-program (program
|
|
&key (path "output.asm") (compile nil)
|
|
(mem-cap 640000) (silence nil) (target :nasm))
|
|
(with-open-file (out path :direction :output :if-exists :supersede)
|
|
(write-program target program out :mem-cap mem-cap))
|
|
(when compile
|
|
(compile-program target path silence)))
|
|
|
|
(defgeneric compile-program (target path silence))
|
|
(setf (documentation #'compile-program 'function)
|
|
(format nil "Produces the executable from source code, targets are ~a"
|
|
*targets*))
|
|
|
|
(defmethod compile-program ((target (eql :nasm)) path silence)
|
|
(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)))
|
|
|
|
(defmethod compile-program ((target (eql :c)) path silence)
|
|
(let ((name (first (uiop:split-string path :separator '(#\.)))))
|
|
(run `("gcc" ,path "-o" ,name)
|
|
:output t :silence silence)))
|
|
|
|
|
|
|