ISLisp changes

2 files changed, 296 insertions, 12 deletions

diff --git a/basic.lsp b/basic.lsp
index 135c2ba..a63ab27 100644
--- a/basic.lsp
+++ b/basic.lsp
@@ -1,16 +1,278 @@
-#!/home/dbane/openlisp-11.0.0/uxlisp -shell
+;;; BASIC interpreter
 
-(require "abs-syn")
-(require "lex")
-(require "parsing")
-(defpackage #:basic
-  (:use #:openlisp)
-  (:export
-   #:main))
-(in-package #:basic)
+;;; Abstract syntax
 
-;;; 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.
+;; 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) "> ")
@@ -34,4 +296,3 @@
                        (format (standard-output) "> ")
                        (catch 'error (one-command st)))))
    (format (standard-output) "See you later...~%"))
-(provide "basic")
diff --git a/dbc2.lsp b/dbc2.lsp
new file mode 100644
index 0000000..477dc38
--- /dev/null
+++ b/dbc2.lsp
@@ -0,0 +1,23 @@
+(defmacro unless (test :rest body)
+  `(if (not ,test) (progn ,@body)))
+;;(defun reduce (function sequence)
+;;  (let ((res 0))
+;;    (for ((xs sequence (cdr xs)))
+;;      ((null xs) res)
+;;      (setq res (+ res (car xs))))))
+;;(reduce #'+ (map '<list> #'abs values))
+(defun sum (sequence)
+  (let ((res 0))
+    (for ((xs sequence (cdr xs)))
+      ((null xs) res)
+      (setq res (+ res (car xs))))))
+(defun average-of-absolutes (values)
+  (the <list> values)
+  (unless (> (length values) 0)
+    (error "average-of-absolutes requires non-null list" values))
+  (let ((res (quotient (sum values) (length values))))
+    (unless (>= res 0)
+      (error "average-of-absolutes must ensure positive result" res))
+    (the <fixnum> res)))
+;; (average-of-absolutes '(1 3))
+;; (average-of-absolutes '())