path: root/cl-forth.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 line-num line col)
  (let ((ch? (read-char stream)))
    (if (not (char-equal ch? #\\))
        (if (char-equal #\' (peek-char nil stream))
            (progn (read-char stream) ch?)
            (error (handle-char-not-closed line-num line col)))
        (progn (case (read-char stream)
                 (#\n (setf ch? #\Newline)))
               (if (char-equal #\' (peek-char nil stream))
                   (progn (read-char stream) ch?)
                   (error (handle-char-not-closed line-num line col)))))))

(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)
                   (if (char-equal #\Space
                                   (peek-char nil line-stream nil nil))
                       (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 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)))))

(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 (merge-pathnames file sb-ext:*core-pathname*))
                  (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)))