path: root/basic.lsp

;;; BASIC interpreter

;;; 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) (exp :accessor exp)))
(defclass <exp-bin> (<expression>) ((exp1 :accessor exp1) (op :accessor op) (exp2 :accessor exp2)))

(defclass <command> () () (:abstractp t))
(defclass <cmd-rem> (<command>) ((rem :accessor rem)))
(defclass <cmd-goto> (<command>) ((goto :accessor goto)))
(defclass <cmd-print> (<command>) ((expr :accessor expr)))
(defclass <cmd-input> (<command>) ((var :accessor var)))
(defclass <cmd-if> (<command>) ((expr :accessor expr) (num :accessor num)))
(defclass <cmd-let> (<command>) ((var :accessor var) (expr :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)
             (parenthesis (string-append res-op res-e))
             (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 "PRNT " (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 (car l) <string>) "  " (pp-command (cdr l))))

;;; Lexing
(defclass <lexeme> () () (:abstractp t))
(defclass <lint> (<lexeme>) ((int :reader int)))
(defclass <lident> (<lexeme>) ((ident :reader ident)))
(defclass <lsymbol> (<lexeme>) ((lsymbol :reader lsymbol)))
(defclass <lstring> (<lexeme>) ((lstring :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 (str self))))

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

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

(defgeneric extract-int (cl))
(defmethod extract-int ((cl <string-lexer>))
   (flet ((is-int (x)
             (and (char>= x #\0) (char<= x #\9))))
      (convert (extract is-int cl) <number>)))

(defgeneric extract-ident (cl))
(defmethod extract-ident ((cl <string-lexer>))
   (flet ((is-alpha-num (x)
             (or (and (char>= x #\a) (char<= x #\z))
                 (and (char>= x #\A) (char<= x #\Z))
                 (and (char>= x #\0) (char<= x #\9))
                 (char= x #\_))))
      (extract is-alpha-num)))

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

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

(defun bin-symb (s)
  (cond ((string= s "+") 'plus)
	((string= s "-") 'minus)
	((string= s "*") 'mult)
	((string= s "/") 'div)
	((string= s "%") 'mod)
	((string= s "=") 'equal)
	((string= s "<") 'less)
	((string= s "<=") 'lesseq)
	((string= s ">") 'great)))

(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>))
	   (cond ((string= (ident tok) "LIST")
		  (create (class <phrase-list>)))
		 ((string= (ident tok) "RUN")
		  (create (class <phrase-run>)))
		 ((string= (ident tok) "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...~%"))