Making changes

3 files changed, 158 insertions, 107 deletions

diff --git a/basic.lsp b/basic.lsp
index 5209832..a355ed0 100644
--- a/basic.lsp
+++ b/basic.lsp
@@ -13,12 +13,12 @@
 (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-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 :accessor var)))
-(defclass <cmd-if> (<command>) ((expr :accessor expr) (num :accessor num)))
-(defclass <cmd-let> (<command>) ((var :accessor var) (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)))
 
@@ -29,33 +29,33 @@
 (defclass <phrase-p-end> (<phrase>) ())
 
 (defun priority-uop (unr-op)
-  (case unr-op
-    ((not) 1)
-    ((uminus) 7)))
+   (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)))
+   (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) " | ")))
+   (case bin-op
+         ((plus) "+")
+         ((mult) "*")
+         ((mod) "%")
+         ((minus) "-")
+         ((div) "/")
+         ((equal) " = ")
+         ((less) " < ")
+         ((lesseq) " <= ")
+         ((great) " > ")
+         ((greateq) " >= ")
+         ((diff) " <> ")
+         ((and) " & ")
+         ((or) " | ")))
 
 (defun pp-unrop (unr-op)
    (case unr-op
@@ -156,8 +156,8 @@
       (let* ((st (string cl))
              (pos (current cl))
              (res (ext pos)))
-         (setf (current cl) res)
-         (subseq (string cl) pos (- res pos)))))
+            (setf (current cl) res)
+            (subseq (string cl) pos (- res pos)))))
 
 ;; Some functions from C's ctype.h:
 (defun isdigit (c)
@@ -197,11 +197,11 @@
                          res))
                    ((member c '(#\+ #\- #\* #\/ #\% #\& #\| #\! #\= #\( #\)))
                     (forward cl)
-                    (create (class <lsymbol>) 's c))
+                    (create (class <lsymbol>) 's (create-string 1 c)))
                    ((or (char= c #\<) (char= c #\>))
                     (forward cl)
                     (if (>= (current cl) (size cl))
-                        (crate (class <lsymbols>) 's c)
+                        (crate (class <lsymbol>) 's (create-string 1 c))
                         (let ((cs (elt (string cl) (current cl))))
                              (cond ((and (char= c #\<) (char= cs #\=))
                                     (forward cl)
@@ -213,7 +213,7 @@
                                     (forward cl)
                                     (create (class <lsymbol>) 's "<>"))
                                    (t
-                                    (create (class <lsymbol>) c))))))
+                                    (create (class <lsymbol>) 's (create-string 1 c)))))))
                    (t (error "Lexer error")))))
       (if (>= (current cl) (size cl))
           (create (class <lend>))
@@ -222,48 +222,110 @@
 ;;; 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-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)
-  (cond ((string= s "!") 'not)
-	((string= s "-") 'uminus)
-	(t (throw 'parse-failure))))
+   (case-using #'string= s
+               (("!") 'not)
+	           (("-") '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)
-    ((string= s ">=") 'greateq)
-    ((string= s "<>") 'diff)
-    ((string= s "&") 'and)
-    ((string= s "|") 'or)
-    (t (throw 'parse-failure))))
+   (case-using #'string= s
+               (("+") 'plus)
+	           (("-") 'minus)
+	           (("*") 'mult)
+	           (("/") 'div)
+	           (("%") 'mod)
+	           (("=") 'equal)
+	           (("<") 'less)
+	           (("<=") 'lesseq)
+	           ((">") 'great)
+               ((">=") 'greateq)
+               (("<>") 'diff)
+               (("&") 'and)
+               (("|") 'or)
+               (t nil)))
 
 (defun tsymb (s)
-   (catch 'parse-failure (lambda 
+   (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>))
-	   (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")))))
+   (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))
@@ -282,21 +344,21 @@
 
 ;;;; 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))
+   (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)))
-      ())))
+   (let ((tprog (apply #'vector prog)))
+        (for ((i 0 (+ i 1)))
+             ((>= i (length tprog)))
+             ())))
 
 ;;;; Expression evaluation
 (defgeneric eval-exp (n envt expr))
diff --git a/btech.lsp b/btech.lsp
index 5a4d11b..07b0d48 100755
--- a/btech.lsp
+++ b/btech.lsp
@@ -1,27 +1,18 @@
-#!/home/dbane/openlisp-10.9.0/uxlisp -shell
-;;; ISLisp is fine so long as you do "read-line" from the same place you call the entry point fun.
-;;; So -shell with an immediate call doesn't work, something is closed after reading the Lisp source.
-;;; -shell -keep, supplying the call from the keyboard works fine.
-;;;
-;;; Calling entry point from a Lisp CLI (after "load") also works.
-;;; And this may be what I end up with, if I'm doing a view in Emacs.
-(require "cmd")
-(require "builtins")
-(defpackage #:btech
-  (:use #:cmd #:builtins)
-  (:export
-    #:main))
-(in-package #:btech)
-;; Favour symbols & objects over C-like numbers
-(defconstant +cmds+ (list
-                      (create-tab #'bt-quit "QUIT" 1)
-                      (create-tab #'help "help" 2)
-                      (create-tab #'look "look" 2)))
-(defun main ()
-  (read-line)                           ; Throw away LF
-  (format (standard-output) "> ")
-  (let* ((tab (lookup (parse (read-line)) +cmds+))
-          (f (fun tab)))
-    (funcall f)))                       ; I *think* this is better than (flet ...
-(provide "btech")
-(main)
+(defclass <unit> () ((name :initarg n :reader name)
+                     (tp :initarg tp :reader tp)
+                     (pv :initarg p :reader pv)))
+(defconstant +mad-3r+ (create (class <unit>)
+                              'n 'marauder
+                              'tp 'bm
+                              'p 42
+                              'sz 3
+                              'tmm 1
+                              'mv 8
+                              'role 'sniper
+                              'skill 3
+                              'damage #(2 3 3)
+                              'ov 1
+                              'a 0
+                              's 0
+                              'crit
+                              'id))
diff --git a/cap-muck.lsp b/cap-muck.lsp
index 36bffba..54bfa9a 100644
--- a/cap-muck.lsp
+++ b/cap-muck.lsp
@@ -183,5 +183,3 @@
   (while (not *terminate-program*)
          (check-for-inputs)))
 (main)
-
-