;;; pl0c.el --- PL/0->elisp compiler                 -*- lexical-binding: t; -*-

;; Copyright (C) 2021  Vasilij Schneidermann <mail@vasilij.de>
;; SPDX-License-Identifier: GPL-3.0-or-later

;; Author: Vasilij Schneidermann <mail@vasilij.de>
;; URL: https://depp.brause.cc/pl0c.el
;; Version: 0.0.1
;; Package-Requires: ((emacs "25.1"))
;; Keywords: languages

;; This file is NOT part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; An Emacs Lisp port of the PL/0 compiler presented on Brian Robert
;; Callahan's blog: https://briancallahan.net/blog/20210814.html

;;; Code:

(defgroup pl0c nil
  "PL/0 compiler"
  :group 'languages
  :prefix "pl0c-")

(defvar pl0c-depth)
(defvar pl0c-token)
(defvar pl0c-type)

;;; lexer

(defun pl0c-current-line ()
  (line-number-at-pos (point)))

(defun pl0c-exit (status)
  (when noninteractive
    (kill-emacs status)))

(defun pl0c-fprintf (printcharfun string &rest args)
  (if noninteractive
      (princ (apply 'format string args) printcharfun)
    ;; FIXME: message/princ differ in newline behavior
    (apply 'message string args)))

(defun pl0c-printf (string &rest args)
  (apply 'pl0c-fprintf standard-output string args))

(defun pl0c-eprintf (string &rest args)
  (apply 'pl0c-fprintf 'external-debugging-output string args))

(defun pl0c-error (message &rest args)
  (let* ((row (pl0c-current-line))
         (col (current-column))
         (message (concat "pl0c: error: %d:%d: " message)))
    (if noninteractive
        (progn
          (apply 'pl0c-eprintf message row col args)
          (pl0c-eprintf "\n")
          (pl0c-exit 1))
      (error message row col args))))

(defun pl0c-lex-ident ()
  (let ((beg (point)))
    (skip-chars-forward "a-zA-Z_")
    (let ((end (point)))
      (setq pl0c-token (buffer-substring beg end))
      (forward-char -1)
      (cond
       ((equal pl0c-token "const") 'const)
       ((equal pl0c-token "var") 'var)
       ((equal pl0c-token "procedure") 'procedure)
       ((equal pl0c-token "call") 'call)
       ((equal pl0c-token "begin") 'begin)
       ((equal pl0c-token "end") 'end)
       ((equal pl0c-token "if") 'if)
       ((equal pl0c-token "then") 'then)
       ((equal pl0c-token "while") 'while)
       ((equal pl0c-token "do") 'do)
       ((equal pl0c-token "odd") 'odd)
       (t 'ident)))))

(defun pl0c-lex-number ()
  (let ((beg (point)))
    (skip-chars-forward "0-9_")
    (let* ((end (point))
           (token (buffer-substring beg end)))
      (forward-char -1)
      (setq pl0c-token (replace-regexp-in-string "_" "" token))))
  'number)

(defun pl0c-lex-comment ()
  (let (done)
    (while (not done)
      (when (looking-at-p "}")
        (setq done t))
      (forward-char 1)
      (when (eobp)
        (pl0c-error "unterminated comment")))))

(defun pl0c-lex-buffer ()
  ;; skip whitespace
  (skip-chars-forward " \t\n")
  (let ((c (char-after)))
    (cond
     ((looking-at-p "[a-zA-Z_]")
      (pl0c-lex-ident))
     ((looking-at-p "[0-9]")
      (pl0c-lex-number))
     ((looking-at-p "{")
      (pl0c-lex-comment)
      ;; NOTE: the original code resembles something closer to TCO
      ;; HACK: this might blow up with many comments in a row
      (pl0c-lex-buffer))
     ((looking-at-p "[-.=,;#<>+*/()]")
      (setq pl0c-token (string c))
      (cond
       ((char-equal c ?.) 'dot)
       ((char-equal c ?=) 'equal)
       ((char-equal c ?,) 'comma)
       ((char-equal c ?\;) 'semicolon)
       ((char-equal c ?#) 'hash)
       ((char-equal c ?<) 'lessthan)
       ((char-equal c ?>) 'greaterthan)
       ((char-equal c ?+) 'plus)
       ((char-equal c ?-) 'minus)
       ((char-equal c ?*) 'multiply)
       ((char-equal c ?/) 'divide)
       ((char-equal c ?\() 'lparen)
       ((char-equal c ?\)) 'rparen)))
     ((looking-at-p ":")
      (forward-char 1)
      (when (not (eobp))
        (when (not (looking-at-p "="))
          (pl0c-error "unknown token: %c" (char-after)))
        'assign))
     ((eobp) nil)
     (t
      (pl0c-error "unknown token: %c" c)))))

;;; parser

;; program	= block "." .
;; block	= [ "const" ident "=" number { "," ident "=" number } ";" ]
;;		  [ "var" ident { "," ident } ";" ]
;;		  { "procedure" ident ";" block ";" } statement .
;; statement	= [ ident ":=" expression
;;		  | "call" ident
;;		  | "begin" statement { ";" statement } "end"
;;		  | "if" condition "then" statement
;;		  | "while" condition "do" statement ] .
;; condition	= "odd" expression
;;		| expression ( "=" | "#" | "<" | ">" ) expression .
;; expression	= [ "+" | "-" ] term { ( "+" | "-" ) term } .
;; term		= factor { ( "*" | "/" ) factor } .
;; factor	= ident
;;		| number
;;		| "(" expression ")" .

(defun pl0c-next ()
  (setq pl0c-type (pl0c-lex-buffer))
  (when (not (eobp))
    (forward-char 1)))

(defun pl0c-expect (match)
  (when (not (eq match pl0c-type))
    (pl0c-error "syntax error"))
  (pl0c-next))

(defun pl0c-parse-block ()
  (when (> pl0c-depth 1)
    (pl0c-error "nesting depth exceeded"))
  (setq pl0c-depth (1+ pl0c-depth))

  (when (eq pl0c-type 'const)
    (pl0c-expect 'const)
    (pl0c-expect 'ident)
    (pl0c-expect 'equal)
    (pl0c-expect 'number)
    (while (eq pl0c-type 'comma)
      (pl0c-expect 'comma)
      (pl0c-expect 'ident)
      (pl0c-expect 'equal)
      (pl0c-expect 'number))
    (pl0c-expect 'semicolon))

  (when (eq pl0c-type 'var)
    (pl0c-expect 'var)
    (pl0c-expect 'ident)
    (while (eq pl0c-type 'comma)
      (pl0c-expect 'comma)
      (pl0c-expect 'ident))
    (pl0c-expect 'semicolon))

  (while (eq pl0c-type 'procedure)
    (pl0c-expect 'procedure)
    (pl0c-expect 'ident)
    (pl0c-expect 'semicolon)
    (pl0c-parse-block)
    (pl0c-expect 'semicolon))

  (pl0c-parse-statement)

  (setq pl0c-depth (1- pl0c-depth))
  (when (< pl0c-depth 0)
    (pl0c-error "nesting depth fell below 0")))

(defun pl0c-parse-statement ()
  (cond
   ((eq pl0c-type 'ident)
    (pl0c-expect 'ident)
    (pl0c-expect 'assign)
    (pl0c-parse-expression))
   ((eq pl0c-type 'call)
    (pl0c-expect 'call)
    (pl0c-expect 'ident))
   ((eq pl0c-type 'begin)
    (pl0c-expect 'begin)
    (pl0c-parse-statement)
    (while (eq pl0c-type 'semicolon)
      (pl0c-expect 'semicolon)
      (pl0c-parse-statement))
    (pl0c-expect 'end))
   ((eq pl0c-type 'if)
    (pl0c-expect 'if)
    (pl0c-parse-condition)
    (pl0c-expect 'then)
    (pl0c-parse-statement))
   ((eq pl0c-type 'while)
    (pl0c-expect 'while)
    (pl0c-parse-condition)
    (pl0c-expect 'do)
    (pl0c-parse-statement))))

(defun pl0c-parse-condition ()
  (if (eq pl0c-type 'odd)
      (progn
        (pl0c-expect 'odd)
        (pl0c-parse-expression))
    (pl0c-parse-expression)
    (if (member pl0c-type '(equal hash lessthan greaterthan))
        (pl0c-next)
      (pl0c-error "invalid conditional"))
    (pl0c-parse-expression)))

(defun pl0c-parse-factor ()
  (cond
   ((member pl0c-type '(ident number))
    (pl0c-next))
   ((eq pl0c-type 'lparen)
    (pl0c-expect 'lparen)
    (pl0c-parse-expression)
    (pl0c-expect 'rparen))))

(defun pl0c-parse-term ()
  (pl0c-parse-factor)
  (while (memq pl0c-type '(multiply divide))
    (pl0c-next)
    (pl0c-parse-factor)))

(defun pl0c-parse-expression ()
  (when (memq pl0c-type '(plus minus))
    (pl0c-next))
  (pl0c-parse-term)
  (when (memq pl0c-type '(plus minus))
    (pl0c-next)
    (pl0c-parse-term)))

(defun pl0c-parse-buffer ()
  (let ((pl0c-depth 0)
        pl0c-token
        pl0c-type)
    (pl0c-next)
    (pl0c-parse-block)
    (pl0c-expect 'dot)
    (when pl0c-type
      (pl0c-error "extra tokens at end of file"))))

(defun pl0c-compile-file (path)
  (with-temp-buffer
    (insert-file-contents-literally path)
    (goto-char (point-min))
    (pl0c-parse-buffer)))

(defun pl0c-cli ()
  (when (and argv (equal (car argv) "--"))
    (pop argv))
  (when (not (= (length argv) 1))
    (pl0c-eprintf "usage: pl0c <file>\n")
    (pl0c-exit 1))
  (pl0c-compile-file (pop argv))
  (pl0c-exit 0))

(provide 'pl0c)
;;; pl0c.el ends here