about summary refs log tree commit diff stats
path: root/basic.lsp
diff options
context:
space:
mode:
Diffstat (limited to 'basic.lsp')
-rw-r--r--basic.lsp111
1 files changed, 82 insertions, 29 deletions
diff --git a/basic.lsp b/basic.lsp
index 91c990a..5209832 100644
--- a/basic.lsp
+++ b/basic.lsp
@@ -9,7 +9,7 @@
 (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-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))
@@ -67,7 +67,7 @@
 
 (defgeneric ppl (pr expr))
 (defmethod ppl (pr (expr <exp-int>))
-   (convert (num expr) <string>))
+   (convert (int expr) <string>))
 (defmethod ppl (pr (expr <exp-var>))
    (var expr))
 (defmethod ppl (pr (expr <exp-str>))
@@ -78,8 +78,8 @@
           (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))))
+             (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))
@@ -114,7 +114,7 @@
 (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))))
+   (string-append "PRINT " (pp-expression (expr cmd))))
 (defmethod pp-command ((cmd <cmd-input>))
    (string-append "INPUT " (var cmd)))
 (defmethod pp-command ((cmd <cmd-if>))
@@ -123,14 +123,14 @@
    (string-append "LET " (var cmd) " = " (pp-expression (expr cmd))))
 
 (defun pp-line (l)
-   (string-append (convert (car l) <string>) "  " (pp-command (cdr l))))
+   (string-append (convert (num l) <string>) "  " (pp-command (cmd 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 <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)
@@ -138,41 +138,86 @@
                              (size :accessor size)))
 
 (defmethod initialize-object :after ((self <string-lexer>) initargs)
-   (setf (size self) (length (str self))))
+   (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 (curr cl) (+ (curr cl) incr))))
+        (setf (current cl) (+ (current 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)))
+   (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))))
+         (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>))
-   (flet ((is-int (x)
-             (and (char>= x #\0) (char<= x #\9))))
-      (convert (extract is-int cl) <number>)))
+   (convert (extract #'isdigit 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))
+             (or (isalnum x)
                  (char= x #\_))))
-      (extract is-alpha-num)))
+      (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 c))
+                   ((or (char= c #\<) (char= c #\>))
+                    (forward cl)
+                    (if (>= (current cl) (size cl))
+                        (crate (class <lsymbols>) 's 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>) 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))
@@ -184,7 +229,7 @@
 (defun unr-symb (s)
   (cond ((string= s "!") 'not)
 	((string= s "-") 'uminus)
-	(t (error "Parse error"))))
+	(t (throw 'parse-failure))))
 
 (defun bin-symb (s)
   (cond ((string= s "+") 'plus)
@@ -195,7 +240,15 @@
 	((string= s "=") 'equal)
 	((string= s "<") 'less)
 	((string= s "<=") 'lesseq)
-	((string= s ">") 'great)))
+	((string= s ">") 'great)
+    ((string= s ">=") 'greateq)
+    ((string= s "<>") 'diff)
+    ((string= s "&") 'and)
+    ((string= s "|") 'or)
+    (t (throw 'parse-failure))))
+
+(defun tsymb (s)
+   (catch 'parse-failure (lambda 
 
 (defun parse (str)
   (let* ((cl (init-lex str))