320 lines
12 KiB
Common Lisp
320 lines
12 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 line-num line col)
|
|
"This function is called when a #\" (double quote) is read from the STREAM."
|
|
(let ((i 0))
|
|
(values
|
|
(with-output-to-string (str)
|
|
(iter (for ch = (read-char stream nil 'eof))
|
|
(cond ((eq 'eof ch)
|
|
(error (cond-string-not-closed
|
|
line-num line col
|
|
(get-output-stream-string str))))
|
|
((char= ch #\")
|
|
(if (> i 0)
|
|
(finish)
|
|
(error (cond-empty-string line-num line col))))
|
|
((char= ch #\\)
|
|
(case (peek-char nil stream)
|
|
(#\n (write-char #\Newline str))
|
|
(#\0 (write-char (code-char 0) str))
|
|
(#\\ (write-char #\\ str))
|
|
(#\" (write-char #\" str)))
|
|
(read-char stream))
|
|
(t (write-char ch str)))
|
|
(incf i)))
|
|
i)))
|
|
|
|
(defun read-character (stream line-num line col)
|
|
"This function is called when a #\' (single quote) is read from the STREAM."
|
|
(let ((ch? (read-char stream nil 'eof)))
|
|
(cond ((eq 'eof ch?)
|
|
(error (cond-char-not-closed line-num line col 'yok)))
|
|
((char-equal ch? #\\)
|
|
(let ((escaped-ch (read-char stream nil 'eof)))
|
|
(case escaped-ch
|
|
(eof (error (cond-char-not-closed line-num line col 'yok)))
|
|
(#\n (setf ch? #\Newline))
|
|
(#\0 (setf ch? (code-char 0)))
|
|
(otherwise (setf ch? escaped-ch)))))
|
|
((char-equal ch? #\')
|
|
(error (cond-empty-char line-num line col)))
|
|
(t nil))
|
|
(let ((closing-ch (read-char stream nil 'eof)))
|
|
(if (or (eq 'eof closing-ch)
|
|
(not (char-equal #\' closing-ch)))
|
|
(error (cond-char-not-closed line-num line col ch?))
|
|
ch?))))
|
|
|
|
(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)
|
|
(let ((peeked (peek-char nil line-stream nil nil)))
|
|
(if (or (not peeked) (char-equal #\Space peeked))
|
|
(collect (make-token :pipe line-num col :identifier)
|
|
into tokens)
|
|
(progn (unread-char #\| line-stream)
|
|
(setf flag nil)))))
|
|
((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 line col)
|
|
line-num col :string)
|
|
into tokens))
|
|
((char= #\' next-char)
|
|
(read-char line-stream)
|
|
(collect (make-token (read-character
|
|
line-stream line-num line col)
|
|
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)))
|
|
|
|
|
|
(defgeneric parse-token (parser type)
|
|
(:documentation "Parses the next token from TOKENS of parser depending on the TYPE."))
|
|
|
|
(defgeneric parse-op (parser token identifier)
|
|
(:documentation "When the TYPE of token is :IDENTIFIER, PARSE-TOKEN parses depending on the identifier of the token.")
|
|
(:method ((parser parser) token id) ;; default parsing
|
|
(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 id) 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"
|
|
token))))
|
|
|
|
;; (defmethod parser-parse-tokens ((parser parser) tokens)
|
|
;; (iter (for makro-op in-vector)
|
|
;; (add-op makro-op ops))
|
|
;; ())
|
|
|
|
(defmethod parse-op ((parser parser) token (id (eql :ise)))
|
|
(push (list :ise (index parser)) (if-stack parser))
|
|
(add-op (list :ise nil) parser))
|
|
|
|
(defmethod parse-op ((parser parser) token (id (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 (id (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 (id (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 (id (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 (id (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)))))
|
|
|
|
(defun find-library (name)
|
|
(or (probe-file (merge-pathnames name sb-ext:*core-pathname*))
|
|
(probe-file (merge-pathnames name (from-root "test/")))
|
|
(probe-file (merge-pathnames name (from-root "lib/")))
|
|
(error "library ~a could not be found." name)))
|
|
|
|
(defmethod parse-op ((parser parser) token (id (eql :kütüphane)))
|
|
"Library and the executable must be in the same location, no other search is made currently."
|
|
(let ((file (car (read-token parser))))
|
|
(setf (tokens parser)
|
|
(append (lex-file (find-library 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)))
|
|
|
|
|
|
|