blob: a63ab27f101eb5dbfaff1dbc9afbdba85da10d69 (
plain) (
tree)
|
|
;;; 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 (num 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...~%"))
|