path: root/basic.lsp

;;  -*- islisp -*-
;;; BASIC interpreter

;; TODO: rewrite some cond/cases as defmethods. Look for calls to "instancep".

;;; Abstract syntax

;; If these were only C enums, without any payload, I'd just use symbols and (error) in the t case.
;; But classes seem better for the associated data, in discriminated unions.

(defclass <expression> () () (:abstractp t))
(defclass <exp-int> (<expression>) ((int :accessor int)))
(defclass <exp-var> (<expression>) ((var :accessor var)))
(defclass <exp-str> (<expression>) ((str :accessor str)))
(defclass <exp-unr> (<expression>) ((op :accessor op) (expr :accessor expr)))
(defclass <exp-bin> (<expression>) ((exp1 :accessor exp1) (op :accessor op) (exp2 :accessor exp2)))

(defclass <command> () () (:abstractp t))
(defclass <cmd-rem> (<command>) ((rem :initarg r :accessor rem)))
(defclass <cmd-goto> (<command>) ((goto :initarg g :accessor goto)))
(defclass <cmd-print> (<command>) ((expr :accessor expr)))
(defclass <cmd-input> (<command>) ((var :initarg v :accessor var)))
(defclass <cmd-if> (<command>) ((expr :initarg e :accessor expr) (num :initarg n :accessor num)))
(defclass <cmd-let> (<command>) ((var :initarg v :accessor var) (expr :initarg e :accessor expr)))

(defclass <line> () ((num :accessor num) (cmd :accessor cmd)))

(defclass <phrase> () () (:abstractp t))
(defclass <phrase-line> (<phrase>) ((line :accessor line)))
(defclass <phrase-list> (<phrase>) ())
(defclass <phrase-run> (<phrase>) ())
(defclass <phrase-p-end> (<phrase>) ())

(defun priority-uop (unr-op)
   (case unr-op
         ((not) 1)
         ((uminus) 7)))

(defun priority-binop (bin-op)
   (cond ((member bin-op '(mult div)) 6)
         ((member bin-op '(plus minus)) 5)
         ((eql bin-op 'mod) 4)
         ((member bin-op '(equal less lesseq great greateq diff)) 3)
         ((member bin-op '(and or)) 2)))

;;; Program pretty printing
(defun pp-binop (bin-op)
   (case bin-op
         ((plus) "+")
         ((mult) "*")
         ((mod) "%")
         ((minus) "-")
         ((div) "/")
         ((equal) " = ")
         ((less) " < ")
         ((lesseq) " <= ")
         ((great) " > ")
         ((greateq) " >= ")
         ((diff) " <> ")
         ((and) " & ")
         ((or) " | ")))

(defun pp-unrop (unr-op)
   (case unr-op
         ((uminus) "-")
         ((not) "!")))

(defun parenthesis (x)
   (string-append "(" x ")"))

(defgeneric ppl (pr expr))
(defmethod ppl (pr (expr <exp-int>))
   (convert (int expr) <string>))
(defmethod ppl (pr (expr <exp-var>))
   (var expr))
(defmethod ppl (pr (expr <exp-str>))
   (string-append "\"" (str expr) "\""))
(defmethod ppl (pr (expr <exp-unr>))
   (let* ((op (op expr))
          (res-op (pp-unrop op))
          (pr2 (priority-uop op))
          (res-e (ppl pr2 (expr expr))))
         (if (= pr 0)
             (string-append res-op res-e)
             (parenthesis (string-append res-op res-e)))))
(defmethod ppl (pr (expr <exp-bin>))
   (let* ((op (op expr))
          (pr2 (priority-binop op))
          (res (string-append (ppl pr2 (expr1 expr)) (pp-binop op) (ppr pr2 (expr2 expr)))))
         (if (>= pr2 pr)
             res
             (parenthesis res))))

(defgeneric ppr (pr expr))
(defmethod ppr (pr (expr <exp-bin>))
   (let* ((op (op expr))
          (pr2 (priority-binop op))
          (res (string-append (ppl pr2 (expr1 expr)) (pp-binop op) (ppr pr2 (expr2 expr)))))
         (if (> pr2 pr)
             res
             (parenthesis res))))
(defmethod ppr (pr (expr <exp-int>))
   (ppl pr expr))
(defmethod ppr (pr (expr <exp-var>))
   (ppl pr expr))
(defmethod ppr (pr (expr <exp-str>))
   (ppl pr expr))
(defmethod ppr (pr (expr <exp-unr>))
   (ppl pr expr))

(defun pp-expression (expr)
   (ppl 0 expr))

(defgeneric pp-command (cmd))
(defmethod pp-command ((cmd <cmd-rem>))
   (string-append "REM " (str cmd)))
(defmethod pp-command ((cmd <cmd-goto>))
   (string-append "GOTO " (convert (num cmd) <string>)))
(defmethod pp-command ((cmd <cmd-print>))
   (string-append "PRINT " (pp-expression (expr cmd))))
(defmethod pp-command ((cmd <cmd-input>))
   (string-append "INPUT " (var cmd)))
(defmethod pp-command ((cmd <cmd-if>))
   (string-append "IF " (pp-expression (expr cmd)) " THEN " (convert (num cmd) <string>)))
(defmethod pp-command ((cmd <cmd-let>))
   (string-append "LET " (var cmd) " = " (pp-expression (expr cmd))))

(defun pp-line (l)
   (string-append (convert (num l) <string>) "  " (pp-command (cmd l))))

;;; Lexing
(defclass <lexeme> () () (:abstractp t))
(defclass <lint> (<lexeme>) ((int :initarg i :reader int)))
(defclass <lident> (<lexeme>) ((ident :initarg i :reader ident)))
(defclass <lsymbol> (<lexeme>) ((lsymbol :initarg s :reader lsymbol)))
(defclass <lstring> (<lexeme>) ((lstring :initarg s :reader lstring)))
(defclass <lend> (<lexeme>) ())

(defclass <string-lexer> () ((string :initarg s :accessor string)
                             (current :initform 0 :accessor current)
                             (size :accessor size)))

(defmethod initialize-object :after ((self <string-lexer>) initargs)
   (setf (size self) (length (string self))))

(defgeneric forward (cl &rest args))
(defmethod forward ((cl <string-lexer>) &rest args)
   (let ((incr (if (null args)
                   1
                   (car args))))
        (setf (current cl) (+ (current cl) incr))))

(defgeneric extract (pred cl))
(defmethod extract (pred (cl <string-lexer>))
   (flet ((ext (n)
             (if (and (< n (size cl)) (apply #'pred (elt st n)))
                 (ext (+ n 1))
                 n)))
      (let* ((st (string cl))
             (pos (current cl))
             (res (ext pos)))
            (setf (current cl) res)
            (subseq (string cl) pos (- res pos)))))

;; Some functions from C's ctype.h:
(defun isdigit (c)
   (and (char>= x #\0) (char<= x #\9)))
(defun isalpha (c)
   (or (and (char>= c #\a) (char<= c #\z))
       (and (char>= c #\A) (char<= c #\Z))))
(defun isalnum (c)
   (or (isalpha c)
       (isdigit c)))

(defgeneric extract-int (cl))
(defmethod extract-int ((cl <string-lexer>))
   (convert (extract #'isdigit cl) <number>))

(defgeneric extract-ident (cl))
(defmethod extract-ident ((cl <string-lexer>))
   (flet ((is-alpha-num (x)
             (or (isalnum x)
                 (char= x #\_))))
      (extract #'is-alpha-num)))

(defgeneric lexer (cl))
(defmethod lexer ((cl <string-lexer>))
   (flet ((lexer-char (c)
             (cond ((or (char= c #\space) (char= c #\tab))
                    (forward cl)
                    (lexer cl))
                   ((isalpha c)
                    (create (class <lident>) 'i (extract-ident cl)))
                   ((isdigit c)
                    (create (class <lint>) 'i (extract-int cl)))
                   ((char= c #\")
                    (forward cl)
                    (let ((res (create (class <lstring>) 's (extract (lambda (c) (char/= c #\")) cl))))
                         (forward cl)
                         res))
                   ((member c '(#\+ #\- #\* #\/ #\% #\& #\| #\! #\= #\( #\)))
                    (forward cl)
                    (create (class <lsymbol>) 's (create-string 1 c)))
                   ((or (char= c #\<) (char= c #\>))
                    (forward cl)
                    (if (>= (current cl) (size cl))
                        (create (class <lsymbol>) 's (create-string 1 c))
                        (let ((cs (elt (string cl) (current cl))))
                             (cond ((and (char= c #\<) (char= cs #\=))
                                    (forward cl)
                                    (create (class <lsymbol>) 's "<="))
                                   ((and (char= c #\>) (char= cs #\=))
                                    (forward cl)
                                    (create (class <lsymbol>) 's ">="))
                                   ((and (char= c #\<) (char= cs #\>))
                                    (forward cl)
                                    (create (class <lsymbol>) 's "<>"))
                                   (t
                                    (create (class <lsymbol>) 's (create-string 1 c)))))))
                   (t (error "Lexer error")))))
      (if (>= (current cl) (size cl))
          (create (class <lend>))
          (lexer-char (elt (string cl) (current cl))))))

;;; Parsing
(defclass <exp-elem> () () (:abstractp t))
(defclass <elem-exp> (<exp-elem>) ((expr :accessor expr)))
(defclass <elem-bin> (<exp-elem>) ((bin-op :initarg o :accessor bin-op)))
(defclass <elem-unr> (<exp-elem>) ((unr-op :initarg o :accessor unr-op)))
(defclass <elem-lp> (<exp-elem>) ())

(defun unr-symb (s)
   (case-using #'string= s
               (("!") 'not)
	           (("-") 'uminus)
	           (t (error "Parse error"))))

(defun bin-symb (s)
   (case-using #'string= s
               (("+") 'plus)
	           (("-") 'minus)
	           (("*") 'mult)
	           (("/") 'div)
	           (("%") 'mod)
	           (("=") 'equal)
	           (("<") 'less)
	           (("<=") 'lesseq)
	           ((">") 'great)
               ((">=") 'greateq)
               (("<>") 'diff)
               (("&") 'and)
               (("|") 'or)
               (t nil)))

(defun tsymb (s)
   (let ((maybe-bin (bin-symb s)))
        (if (null maybe-bin)
            (create (class <elem-unr>) 'o (unr-symb s))
            (create (class <elem-bin>) 'o maybe-bin))))

(defun reduce (pr)
   )

(defun stack-or-reduce (lex stack)
   )

(defun reduce-all (st)
   (cond ((null st) (error "Parse error"))
         ((and (= (length st) 1) (instancep (car st) (class <elem-exp>))) (expr (car st)))
         (t (reduce-all (reduce 0 st)))))

(defun parse-exp (stop cl)
   (let ((p 0))
        (flet ((parse-one (stack)
                  (setq p (current cl))
                  (let ((l (lexer cl)))
                       (if (not (stop l))
                           (parse-one (stack-or-reduce l stack))
                           (progn (setf (current cl) p)
                                  (reduce-all stack))))))
           (parse-one '()))))

(defun parse-cmd (cl)
   (let ((tok (lexer cl)))
        (if (instancep tok (class <lident>))
            (case-using #'string= (ident tok)
                        (("REM")
                         (create (class <cmd-rem>) 'r (extract (lambda (x) t) cl)))
                        (("GOTO")
                         (create (class <cmd-goto>) 'g (let ((tok (lexer cl)))
                                                            (if (instancep tok (class <lint>))
                                                                (int tok)
                                                                (error "Parse error")))))
                        (("INPUT")
                         (create (class <cmd-input>) 'v (let ((tok (lexer cl)))
                                                             (if (instancep tok (class <lident>))
                                                                 (ident tok)
                                                                 (error "Parse error")))))
                        (("PRINT")
                         (create (class <cmd-print>) 'e (parse-exp (lambda (x) (instancep x (class <lend>))) cl)))
                        (("LET")
                         (let ((l2 (lexer cl))
                               (l3 (lexer cl)))
                              (if (and (instancep l2 (class <lident>)) (instancep l3 (class <lsymbol>)) (string= (lsymbol l3) "="))
                                  (create (class <cmd-let>) 'v (ident l2) 'e (parse-exp (lambda (x) (instancep x <lend>)) cl))
                                  (error "Parse error"))))
                        (("IF")
                         (let ((test (parse-exp (lambda (x) (and (instancep x <lident>) (string= (ident x) "THEN"))) cl)))
                              (progn (lexer cl)
                                     (let ((tok (lexer cl)))
                                          (if (instancep tok (class <lint>))
                                              (create (class <cmd-if>) 'e test 'n (int tok))
                                              (error "Parse error"))))))
                        (t (error "Parse error")))
            (error "Parse error"))))

(defun parse (str)
   (let* ((cl (init-lex str))
	      (tok (lexer cl)))
         (cond ((instancep tok (class <lint>))
	            (create (class <line>) 'n n 'c (parse-cmd cl)))
	           ((instancep tok (class <lident>))
	            (case-using #'string= (ident tok)
                            (("LIST")
		                     (create (class <phrase-list>)))
		                    (("RUN")
		                     (create (class <phrase-run>)))
		                    (("END")
		                     (create (class <phrase-p-end>)))
		                    (t (error "Parse error"))))
	           (t (error "Parse error")))))

;;; Evaluation
(defclass <value> () () (:abstractp t))
(defclass <v-int> (<value>) ((int :accessor int)))
(defclass <v-str> (<value>) ((str :accessor str)))
(defclass <v-bool> (<value>) ((bool :accessor bool)))

(defclass <environment> () ((env :accessor env)))

(defclass <state-exec> () ((line :reader line)
                           (xprog :reader xprog)
                           (xenv :reader xenv)))

(defun runerr (n)
   (throw 'run-error n))

;;;; Assembly
(defun lookup-index (tprog num-line)
   (block result-lookup-index
          (for ((i 0 (+ i 1)))
               ((>= i (length tprog)))
               (let ((num-i (num (elt tprog i))))
                    (if (= num-i num-line)
                        (return-from result-lookup-index i)
                        (if (> num-i num-line)
                            (return-from result-lookup-index -1)))))
          -1))

(defun assemble (prog)
   (let ((tprog (apply #'vector prog)))
        (for ((i 0 (+ i 1)))
             ((>= i (length tprog)))
             ())))

;;;; Expression evaluation
(defgeneric eval-exp (n envt expr))
(defmethod eval-exp (n envt (expr <exp-int>))
   (create (class <v-int>) 'i (int expr)))
(defmethod eval-exp (n envt (expr <exp-unr>))
   (case (op expr)
         ((uminus)
          (let ((result (eval-exp (exp expr))))
               (if (instancep result (class <v-int>))
                   (progn (setf (exp result) (- (exp result)))
                          result)
                   (runerr n))))
         ((not)
          (let ((result (eval-exp (exp expr))))
               (if (instancep result (class <v-bool>))
                   (progn (setf (exp result) (not (exp result)))
                          result)
                   (runerr n))))))

;;;; Command evaluation

;;;; Program evaluation
(defun run (state)
   )

;;; Finishing touches

;; Not sure yet if it's a good idea or not,
;; but I'm trying to keep the number of top-level functions the same as in OCaml.

(defun one-command (st)
   (format (standard-output) "> ")
   (with-handler #'error-handler
      (let ((l parse (read-line)))
           (case (car l)
                 ((line) (insert (cadr c)))
                 ((p-end) (throw 'end nil)))))) ; throw and conditions are orthogonal

(defclass <state> () ((prog :accessor prog)
                      (env :accessor env)))
(defmethod initialize-object :after ((self <state>) initargs)
   (setf (prog self) nil)
   (setf (env self) nil))

(defun main ()
   (catch 'end (lambda ()
                  (format (standard-output) "BASIC version 0.1~%~%")
                  (for ((st (create (class <state>))))
                       (())
                       (format (standard-output) "> ")
                       (catch 'error (one-command st)))))
   (format (standard-output) "See you later...~%"))