Add Pascal J. Bourguignons BASIC interpreter, may be a better starting point

1 files changed, 991 insertions, 0 deletions

diff --git a/basic.lisp b/basic.lisp
new file mode 100644
index 0000000..6853507
--- /dev/null
+++ b/basic.lisp
@@ -0,0 +1,991 @@
+;;;;****************************************************************************
+;;;;FILE:               basic.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     standard i/o
+;;;;DESCRIPTION
+;;;;
+;;;;    Quick, Dirty and Ugly BASIC.
+;;;;
+;;;;    This is a silly BASIC interpreter.  The lines are tokenized and stored
+;;;;    as-is in an array indexed by the line number.  When interpreting the
+;;;;    program, the instructions are parsed directly from there ; the
+;;;;    expressions are parsed into trees which are then evaluated.
+;;;;    The variables are stored into a hash table indexed by their
+;;;;    identifier (symbol). Undefined variables are taken as 0 or "".
+;;;;    We distinguish number and string variables depending on the presence
+;;;;    of a '$' character in the last position of the variable identifier.
+;;;;    Variables are reset by the command RUN. (A program can be restarted
+;;;;    without losing the variable using the GOTO or GOSUB statements).
+;;;;
+;;;;    Commands are not distinguished from statements and may occur in a
+;;;;    program. In particular, LOAD could be used to load a subprogram
+;;;;    overlay, and takes a line number where to jump to.
+;;;;
+;;;;    Programs are loaded and saved in source form.
+;;;;
+;;;;SYNOPSIS
+;;;;
+;;;;    (LOAD (COMPILE-FILE "BASIC.LISP"))
+;;;;    (COM.INFORMATIMAGO.COMMON-LISP.BASIC:MAIN)
+;;;;
+;;;;
+;;;;    command ::= number statements | statements .
+;;;;    statements ::= statement { ':' statement } .
+;;;;    statement ::=
+;;;;            PRINT [ expression { ( ',' | ';' ) expression }
+;;;;          | INPUT string identifier { ',' identifier }
+;;;;          | READ  identifier { ',' identifier }
+;;;;          | DATA  ( string | number ) { ',' ( string | number ) }
+;;;;          | RESTORE [ expression ]
+;;;;          | GOTO      expression
+;;;;          | GOSUB expression
+;;;;          | RETURN
+;;;;          | STOP
+;;;;          | REM whatever-up-to-the-end-of-line
+;;;;          | identifier '=' expression
+;;;;          | FOR identifier '=' expression TO expression [ STEP expression ]
+;;;;          | NEXT [ identifier ]
+;;;;          | IF condition THEN statements [ ':' ELSE statements ]
+;;;;          | LIST
+;;;;          | DIR [name.type]
+;;;;          | SAVE string
+;;;;          | LOAD string [ number ]
+;;;;          | ERASE ( ALL | number { number } )
+;;;;          | RUN
+;;;;          | BYE
+;;;;          .
+;;;;    expression  ::= expression ( '+' | '-' ) term .
+;;;;    term        ::= term       ( '*' | '/' | 'mod' ) fact .
+;;;;    fact        ::= fact       ( '^' ) simp .
+;;;;    simp        ::= number | string | identifier | '(' expression ')'
+;;;;                  | ( '+' | '-' ) simp .
+;;;;    condition   ::= disjonction .
+;;;;    disjonction ::= disjonction { 'OR' conjonction }  | conjonction .
+;;;;    conjonction ::= conjonction { 'AND' logicalnot }  | logicalnot .
+;;;;    logicalnot  ::= comparaison | 'NOT' logicalnot | '(' disjonction ')'
+;;;;    comparaison ::= expression ( '<' | '<=' | '>' | '>=' | '=' | '<>' )
+;;;;                                 expression .
+;;;;    identifier  ::= alpha { alphanum } [ '$' ].
+;;;;    string      ::= '"' { any-character-but-double-quote } '"' .
+;;;;    number      ::= digit { digit } .
+;;;;
+;;;;    The '+' operator can be used to concatenate strings.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon
+;;;;MODIFICATIONS
+;;;;    2005-09-26 <PJB> Added missing :NICKNAMES.
+;;;;    2003-05-19 <PJB> Created (in 2 days).
+;;;;BUGS
+;;;;    NOT IMPLEMENTED YET: scanning floating point.
+;;;;                         scanning parenthesis (we have them in parser).
+;;;;                         built-in functions: SIN COS ATAN EXP LOG
+;;;;                                             LEFT$ MID$ RIGHT$ ...
+;;;;                         arrays
+;;;;
+;;;;    This code would be happier with some factoring (basic-eval).
+;;;;
+;;;;    Some more testing could be used.
+;;;;
+;;;;    The program is stored in a fixed-size array (1000).
+;;;;    Perhaps we should provide either for a bigger array
+;;;;    or for a sparse structure (hash?).
+;;;;
+;;;;    Missing as a test case: a LISP interpreter implemented in BASIC.
+;;;;    (Of course, this BASIC interpreter implemented in LISP should then
+;;;;    be tested over the LISP interpreter implemented in BASIC :-).
+;;;;
+;;;;    Two-letter operators are not parsed correctly ("<>" --> "<>" and ">").
+;;;;
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2003 - 2003
+;;;;    mailto:pjb@informatimago.com
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 of the License, or (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be
+;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;****************************************************************************
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf *readtable* (copy-readtable nil)))
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.BASIC"
+  (:nicknames "BASIC")
+  (:use "COMMON-LISP")
+  (:export "BASIC" "MAIN")
+  );;BASIC
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.BASIC")
+
+
+(defvar *program* (make-array '(1000) :initial-element nil))
+(defvar *stack*   (make-array '(100)
+                              :initial-element nil
+                              :adjustable t
+                              :fill-pointer 0));;*STACK*
+(defvar *variables* (make-hash-table :test (function eq) :size 100))
+
+(defvar *current-line* 0)
+(defvar *data-ptr* (cons 0 nil) "marker for DATA/READ/RESTORE")
+
+
+(defmacro while (condition &body body) `(do () ((not ,condition)) ,@body))
+(defmacro until (condition &body body) `(do () (,condition)       ,@body))
+
+
+(defun split-line (line)
+  "
+DO:         Split the line between the special characters:
+            space , ; : < > <= >= = <>  + - * / ^
+            as one token.  The special characters are enclosed  in pipes.
+RETURN:     A list of token string (where spaces are removed) ;
+            nil or an error message string.
+NOTE:       No parentheses: yuck maths!  No dots in numbers: yuck maths!
+"
+  (do ((i 0 (1+ i))
+       (p 0)
+       (parts ())
+       (err nil))
+      ((<= (length line) i)
+       (values (progn (when (< p (length line))
+                        (push (subseq line p (length line)) parts))
+                      (nreverse parts)) err))
+    (macrolet ((push-part () `(when (< p i)
+                                (push (subseq line p i) parts)
+                                (setq p i))))
+      (cond
+       ((char= (char line i) (character " "))
+        (push-part)
+        (incf p))
+       ((char= (char line i) (character "\""))
+        (push-part)
+        (incf i)
+        (do ()
+            ((or (<= (length line) i) (char= (char line i) (character "\""))))
+          (incf i))
+        (if (< i (length line)) (incf i))
+        (push-part)
+        (decf i))
+       ((position (char line i) ",;:=+-*/^")
+        (push-part)
+        (incf p)
+        (push (format nil "|~A|" (subseq line i p)) parts))
+       ((char= (char line i) (character "<"))
+        (push-part)
+        (if (or (char= (char line (1+ i)) (character "="))
+                (char= (char line (1+ i)) (character ">")))
+          (progn (push (format nil "|~A|" (subseq line i (+ i 2))) parts)
+                 (setq p (incf i)))
+          (progn (incf p)
+                 (push (format nil "|~A|" (subseq line i p)) parts))))
+       ((char= (char line i) (character ">"))
+        (push-part)
+        (if  (char= (char line (1+ i)) (character "="))
+          (progn (push (format nil "|~A|" (subseq line i (+ i 2))) parts)
+                 (setq p (incf i)))
+          (progn (incf p)
+                 (push (format nil "|~A|" (subseq line i p)) parts))))
+       ((or (alphanumericp (char line i))
+            (char= (character "$") (char line i))
+            (char= (character "%") (char line i))))
+       (t
+        (setq err (format nil "INVALID CHARACTER: '~A' AT POSITION ~D."
+                          (char line i) i))
+        (setq i (length line))))))
+  );;SPLIT-LINE
+
+
+
+
+(defun fetch-data ()
+  "
+RETURN:     The data found at or following *DATA-PTR*, or NIL if none remains.
+DO:         Increments *DATA-PTR*, or issue an error (setting *CURRENT-LINE*).
+"
+  (while (and (< (car *data-ptr*) (array-dimension *program* 0))
+              (null (cdr *data-ptr*)))
+    (incf (car *data-ptr*))
+    (while (and (< (car *data-ptr*) (array-dimension *program* 0))
+                (or (null (aref *program* (car *data-ptr*)))
+                    (not (eq 'data (car (aref *program* (car *data-ptr*)))))))
+      (incf (car *data-ptr*)))
+    (if (and (< (car *data-ptr*) (array-dimension *program* 0))
+             (aref *program* (car *data-ptr*)))
+      (setf (cdr *data-ptr*) (cdr (aref *program* (car *data-ptr*))))))
+  ;;(format t "data-ptr= ~S~%" *data-ptr*)
+  (if (null (cdr *data-ptr*))
+    (progn  (berror "NO MORE DATA TO READ.") nil)
+    (if (and (cdr (cdr *data-ptr*))
+             (or (null (cddr (cdr *data-ptr*)))
+                 (not (eq '|,| (cadr (cdr *data-ptr*))))
+                 (not (or (stringp (car (cdr *data-ptr*)))
+                          (numberp (car (cdr *data-ptr*)))))))
+      (progn (berror "MALFORMED DATA LINE ~A." (car *data-ptr*))    nil)
+      (prog1 (pop (cdr *data-ptr*)) (pop (cdr *data-ptr*))))))
+
+
+
+(defmacro protect-break (form)
+  `(handler-case
+       (values ,form)
+     (t () (format t "~&BREAK~%") (setq *current-line* nil) nil)
+     (:no-error (data) data)))
+
+
+(defun input-data (type)
+  (cond
+   ((eq type 'string) (protect-break (read-line)))
+   ((eq type 'number) (protect-break (read)))))
+
+
+
+
+(defun find-for (variable)
+  "
+DO:         Finds the first entry in the stack that is a list beginning
+            with :FOR and the VARIABLE, or just :FOR if VARIABLE is NIL.
+            (compared with EQ).
+NOTE:       If found, any entry above the found entry are poped.
+RETURN:     NIL or the entry.
+"
+  (do ((pointer (1- (fill-pointer *stack*)) (decf pointer)))
+      ((or (< pointer 0)
+           (and (consp (aref *stack* pointer))
+                (eq :for     (car    (aref *stack* pointer)))
+                (or (null variable)
+                    (eq variable (second (aref *stack* pointer))))))
+       (if (< pointer 0)
+         nil
+         (progn
+           (setf (fill-pointer *stack*) (1+ pointer))
+           (aref *stack* pointer))))))
+
+
+(defun find-gosub ()
+  "
+DO:         Finds the first entry in the stack that is a list beginning
+            with :GOSUB.
+NOTE:       If found, any entry above the found entry are poped.
+RETURN:     NIL or the entry.
+"
+  (do ((pointer (1- (fill-pointer *stack*)) (decf pointer)))
+      ((or (< pointer 0)
+           (and (consp (aref *stack* pointer))
+                (eq :gosub     (car    (aref *stack* pointer)))))
+       (if (< pointer 0)
+         nil
+         (progn
+           (setf (fill-pointer *stack*) (1+ pointer))
+           (aref *stack* pointer))))))
+
+
+
+(defun berror (fmt &rest args)
+  "
+DO:         Prints an error message formated from fmt and args.
+"
+  (if *current-line*
+    (format t "~&ERROR LINE ~D: ~A~%"
+            *current-line* (apply (function format) nil fmt args))
+    (format t "~&ERROR: ~A~%"  (apply (function format) nil fmt args)))
+  (setq *current-line* nil))
+
+
+(defun check-line (linenum)
+  "
+DO:         Check the line number and issue an error message.
+RETURN:     Whether the linenum is a valid line number.
+"
+  (declare (integer linenum))
+  (if (or (< linenum 1)
+          (<= (array-dimension *program* 0) linenum))
+    (progn (berror "LINE NUMBER OUT OF RANGE (1..~D)."
+                   (array-dimension *program* 0))
+           nil)
+    t))
+
+
+(defun find-line-or-next (linenum)
+  "
+PRE:       (check-line linenum)
+RETURN:    If line linenum exists then line linenum
+           else the line with the minimum line number greater than linenum
+           or else nil.
+"
+  (if (or (<= linenum 0) (<= (array-dimension *program* 0) linenum))
+    (progn (setq *current-line* nil)
+           nil)
+    (do* ((linenum linenum (1+ linenum))
+          (line (aref *program* linenum) (aref *program* linenum)) )
+        ((or line (= (array-dimension *program* 0) (1+ linenum)))
+         (if line
+           (progn (setq *current-line* linenum)
+                  line)
+           (progn (setq *current-line* nil)
+                  nil))))))
+
+
+
+
+(defun slurp-expression (tokens terminals)
+  "
+DO:         Parse tokens until a terminal or end of list's found.
+RETURN:     A list of tokens making an expression ;
+            A cdr of tokens.
+"
+  (do ((expr ())
+       (tokens tokens (cdr tokens)))
+      ((or (null tokens)
+           (member (car tokens) terminals :test (function eq)))
+       (values (nreverse expr) tokens))
+    (push (car tokens) expr)))
+
+
+;;; expr : term { [+|-] expr }
+;;; term : fact { [*|/] term }
+;;; fact : simple { ^ fact }
+;;; simple : ident | number | ( expr ) .
+
+(defun parse-simp (simp)
+  "
+DO:         Parses a simple expression:
+            simp ::= number | string | identifier | ( expr ) .
+NOTE:       We're missing a function call: identifier ( expr { , expr } )
+RETURN:     A parse tree or :ERROR ; a cdr of simp.
+"
+  (cond
+   ((member (car simp) '(+ -))
+    (multiple-value-bind (expr rest) (parse-simp (cdr simp))
+      (if (eq :error expr)
+        (values expr rest)
+        (if (eq (car simp) '+)
+          (values expr rest)
+          (values (list 'neg expr) rest)))))
+   ((numberp (car simp)) (values (car simp) (cdr simp)))
+   ((stringp (car simp)) (values (car simp) (cdr simp)))
+   ((symbolp (car simp)) (values (car simp) (cdr simp)))
+   ((eq '|(| (car simp))
+    (multiple-value-bind (expr rest) (parse-expr (cdr simp))
+      (if (eq '|)| (car rest))
+        (values expr (cdr rest))
+        (progn
+          (berror "MISSING A CLOSING PARENTHESE.")
+          (values :error nil)))))
+   (t (berror "INVALID TOKEN IN EXPRESSION ~S." (car simp)))))
+
+
+
+(defmacro make-parse-level (name operators next)
+  "
+DO:         Generate a function named PARSE-{name} that parses the
+            following rule:  name ::= name { operators next } .
+            That functions will return a parse tree or :ERROR ; a cdr of expr.
+"
+  (let ((parse-level-name (intern (format nil "PARSE-~A" name)))
+        (parse-next-name  (intern (format nil "PARSE-~A" next))))
+    `(defun ,parse-level-name (expr)
+       (let ((result))
+         (multiple-value-bind (term rest) (,parse-next-name expr)
+           (setq result term expr rest))
+         (do () ((or (eq :error result)
+                     (null expr)
+                     (not (member (car expr) ',operators
+                                  :test (function eq)))))
+           (multiple-value-bind (term rest) (,parse-next-name (cdr expr))
+             (if (eq :error term)
+               (setq result :error)
+               (setq result (list (car expr) result term)
+                     expr   rest))))
+         (values result expr)))))
+
+(defun parse-lnot (lnot)
+  "
+DO:         Parses a simple logical expression:
+            lnot ::= comp | NOT lnot | ( disj ).
+RETURN:     A parse tree or :ERROR ; a cdr of expr.
+"
+  (cond
+   ((eq (car lnot) 'not)
+    (multiple-value-bind (expr rest) (parse-lnot (cdr lnot))
+      (if (eq :error expr)
+        (values expr rest)
+        (values (list 'not expr) rest))))
+   ((eq '|(| (car lnot))
+    (multiple-value-bind (expr rest) (parse-disj (cdr lnot))
+      (if (eq '|)| (car rest))
+        (values expr (cdr rest))
+        (progn
+          (berror "MISSING A CLOSING PARENTHESE.")
+          (values :error nil)))))
+   (t (parse-comp lnot))))
+
+
+(make-parse-level fact (^)       simp)
+(make-parse-level term (* / mod) fact)
+(make-parse-level expr (+ -)     term)
+(make-parse-level comp (< <= > >= = <>) expr)
+(make-parse-level conj (and) lnot)
+(make-parse-level disj (or)  conj)
+
+
+
+(defun bdiv (a b)
+  "
+RETURN: A floating-point division of a by b.
+"
+  (if (equal 0 b)
+    (progn
+      (berror "DIVISION BY ZERO.")
+      nil)
+    (/ (float a) b)))
+
+
+
+
+(defun boolp (operand)  (member operand '(:true :false)))
+(defun band (a b) (and (eq :true a) (eq :true b)))
+(defun bor  (a b) (or  (eq :true a) (eq :true b)))
+(defun bnot (a)   (eq :false a))
+(defun bool (lisp-bool) (if lisp-bool :true :false))
+
+(defmacro make-comparison (name operator number-op string-op)
+  `(defun ,name (a b)
+     (cond
+      ((and (numberp a) (numberp b)) (bool (,number-op a b)))
+      ((and (stringp a) (stringp b)) (bool (,string-op a b)))
+      (t (berror "INCOMPATIBLE OPERANDS FOR ~A." ',operator)))))
+
+(make-comparison blt <  <  string< )
+(make-comparison ble <= <= string<=)
+(make-comparison bgt >  >  string> )
+(make-comparison bge >= >= string>=)
+(make-comparison beq =  =  string= )
+(make-comparison bne <> /= string/=)
+
+
+(defmacro num-op (operator operation)
+  "PRIVATE MACRO for BASIC-EVAL-TREE"
+  `(let ((left  (basic-eval-tree (second tree)))
+         (right (basic-eval-tree (third  tree))))
+     (cond
+      ((and (numberp left) (numberp right)) (,operation left right))
+      (t (berror "INCOMPATIBLE OPERANDS FOR ~A." ',operator)    nil))))
+
+(defmacro comp-op (operator operation)
+  "PRIVATE MACRO for BASIC-EVAL-TREE"
+  `(let ((left  (basic-eval-tree (second tree)))
+         (right (basic-eval-tree (third  tree))))
+     (cond
+      ((and (numberp left) (numberp right)) (,operation left right))
+      ((and (stringp left) (stringp right)) (,operation left right))
+      (t (berror "INCOMPATIBLE OPERANDS FOR ~A." ',operation)    nil))))
+
+(defmacro bool-op (operator operation)
+  "PRIVATE MACRO for BASIC-EVAL-TREE"
+  `(let ((left  (basic-eval-tree (second tree)))
+         (right (basic-eval-tree (third  tree))))
+     (cond
+      ((and (boolp left) (boolp right)) (,operation left right))
+      (t (berror "INCOMPATIBLE OPERANDS FOR ~A." ',operation)     nil))))
+
+
+
+(defun basic-eval-tree (tree)
+  "
+DO:         Evaluate an expression tree.
+RETURN:     NIL or the computed value.
+"
+  (cond
+   ((numberp tree) tree)
+   ((stringp tree) tree)
+   ((symbolp tree)
+    (let ((value (gethash tree *variables*)))
+      (unless value
+        (setq value
+              (setf (gethash tree *variables*)
+                    (if (char= (character "$")
+                               (char (symbol-name tree)
+                                     (1- (length (symbol-name tree)))))
+                      "" 0))))
+      value))
+   ((consp tree)
+    (case (car tree)
+      (-   (num-op  -   -))
+      (*   (num-op  *   *))
+      (/   (num-op  /   bdiv))
+      (^   (num-op  ^   expt))
+      (mod (num-op  mod mod))
+      (and (bool-op and band))
+      (or  (bool-op or  bor))
+      (<   (comp-op <   blt))
+      (<=  (comp-op <=  ble))
+      (>   (comp-op >   bgt))
+      (>=  (comp-op >=  bge))
+      (=   (comp-op =   beq))
+      (<>  (comp-op <>  bne))
+      (+ (let ((left  (basic-eval-tree (second tree)))
+               (right (basic-eval-tree (third  tree))))
+           (cond
+            ((and (stringp left) (stringp right))
+             (concatenate 'string left right))
+            ((and (numberp left) (numberp right))      (+ left right))
+            (t (berror "INCOMPATIBLE OPERANDS FOR +.") nil))))
+      (not (let ((left  (basic-eval-tree (second tree))))
+             (cond
+              ((boolp left)                                   (bnot left))
+              (t (berror "INCOMPATIBLE OPERANDS FOR UNARY NOT.") nil))))
+      (neg (let ((left  (basic-eval-tree (second tree))))
+             (cond
+              ((numberp left)                                    (- left))
+              (t (berror "INCOMPATIBLE OPERANDS FOR UNARY -.")   nil))))
+      (otherwise (berror "UNEXPECTED OPERATOR ~A." (car tree))   nil)))
+   (t (berror "UNEXPECTED OPERAND ~A." tree)                     nil)))
+
+
+
+(defun basic-eval-expression (expr)
+  "
+DO:         Parses the BASIC expression EXPR and evaluates it.
+RETURN:     NIL or the computed value.
+"
+  (multiple-value-bind (tree rest) (parse-expr expr)
+    (cond
+     ((eq :error tree)
+      (berror "SYNTAX ERROR IN EXPRESSION ~A." expr)
+      nil)
+     ((null rest)
+      (basic-eval-tree tree))
+     (t
+      (berror "UNEXPECTED TOKEN IN EXPRESSION: ~A." (car rest))
+      nil))))
+
+
+
+(defun basic-eval-condition (expr)
+  "
+DO:         Parses the BASIC condition EXPR and evaluates it.
+RETURN:     NIL or the computed value.
+"
+  (multiple-value-bind (tree rest) (parse-disj expr)
+    (cond
+     ((eq :error tree)
+      (berror "SYNTAX ERROR IN CONDITION ~A." expr)
+      nil)
+     ((null rest)
+      (basic-eval-tree tree))
+     (t
+      (berror "UNEXPECTED TOKEN IN CONDITION: ~A." (car rest))
+      nil))))
+
+
+(defun identifierp  (sym)
+  (and (symbolp sym)
+       (alpha-char-p (char (symbol-name sym) 0))))
+
+
+(defun identifier-type (sym)
+  (char (symbol-name sym) (1- (length (symbol-name sym)))))
+
+
+(defun check-list-var (listvar)
+  "
+DO:         Check that listvar is a list of identifier symbols separated
+            by comas.
+RETURN:     The list of identifier symbols without the comas.
+"
+  (do ((listvar listvar (cddr listvar))
+       (result  '()))
+      ((null listvar) (nreverse result))
+    (cond
+     ((null listvar)
+      (berror "EXPECTED A LIST OF VARIABLES SEPARATED BY COMAS.")
+      (setq result nil listvar nil))
+     ((null (cdr listvar))
+      (if (identifierp (car listvar))
+        (push (car listvar) result)
+        (progn
+          (berror "EXPECTED A VARIABLE INSTEAD OF ~A." (car listvar))
+          (setq result nil listvar nil))))
+     ((null (cddr listvar))
+      (berror "MALFORMED LIST OF VARIABLES.")
+      (setq result nil listvar nil))
+     (t
+      (if (and (identifierp (car listvar)) (eq '|,| (cadr listvar)))
+        (push (car listvar) result)
+        (progn
+          (if (eq '|,| (cadr listvar))
+            (berror "EXPECTED A VARIABLE INSTEAD OF ~A." (car listvar))
+            (berror "EXPECTED A COMA INSTEAD OF ~A." (cadr listvar)))
+          (setq result nil listvar nil)))))))
+
+
+(defun basic-eval (statement)
+  "
+DO:         Evaluate the statement,
+            and the following if *current-line* is non nil.
+RETURN:     NIL or :BYE.
+"
+  (loop
+   ;; (format t "current-line=~S   token=~A:~A statement=~S~%"
+   ;;         *current-line* (package-name (symbol-package (car statement)))
+   ;;         (car statement) statement)
+   ;; (format t "dir=~A:~A   EQUAL=~S~%" (package-name (symbol-package 'dir))
+   ;;         'dir (equal 'dir (car statement)))
+   (unless statement (return nil))
+   (case (car statement)
+     ((print)
+      (multiple-value-bind (expr rest)
+          (slurp-expression (cdr statement) '(|,| |;| |:|))
+        (if expr
+          (let ((value (basic-eval-expression expr)))
+            (if value
+              (progn
+                (format t (case (car rest)
+                            ((|,|) "~A ")
+                            ((|;|) "~A")
+                            (t "~A~%")) value)
+                (when rest
+                  (case (car rest)
+                    ((|,| |;|) (basic-eval (cons 'print (cdr rest))))
+                    ((nil))
+                    ((|:|)     (basic-eval (cdr rest)))
+                    (otherwise (berror "UNEXPECTED TOKEN '~A'.") ))))
+              (setq *current-line* nil))))))
+     ((for)
+      ;; FOR A = EXPR TO EXPR [ STEP EXPR ] :
+      (let* ((varsym (second statement))
+             (variable (if (symbolp varsym) (symbol-name varsym) nil))
+             (vartype (if variable (char variable (1- (length variable)))))
+             (target)
+             (step)
+             (remainder)
+             (linenum *current-line*))
+        (if (and variable
+                 (alpha-char-p (char variable 0))
+                 (char/= (character "$") vartype)
+                 (eq '= (third statement)))
+          ;; for a =
+          (multiple-value-bind (assignment rest)
+              (slurp-expression (cdr statement) '(to))
+            (if (eq 'to (car rest))
+              (multiple-value-bind (target-expr rrest)
+                  (slurp-expression (cdr rest) '(step |:|))
+                (setq target (basic-eval-expression target-expr))
+                (if target
+                  (if (numberp target)
+                    (if (eq (car rrest) 'step)
+                      (multiple-value-bind (step-expr rrrest)
+                          (slurp-expression (cdr rrest) '(|:|))
+                        (setq step (basic-eval-expression step-expr))
+                        (if (numberp step)
+                          (setq remainder  rrrest)
+                          (progn
+                            (berror "INVALID STEP VALUE: MUST BE NUMERIC!")
+                            (setq step nil))))
+                      (setq step 1
+                            remainder  rrest))
+                    (progn
+                      (berror "INVALID TARGET VALUE: MUST BE NUMERIC!")
+                      (setq target nil)))))
+              (berror "INVALID TOKEN AFTER ASSIGNMENT IN FOR: '~A'."
+                      (car rest)))
+            (when step
+              (vector-push-extend
+               (list :for varsym target step linenum (cdr remainder))
+               *stack* (array-dimension *stack* 0))
+              (basic-eval (nconc assignment remainder))))
+          (berror "FOR EXPECTS A NUMERIC VARIABLE ASSIGNMENT."))))
+     ((next)
+      (if (and (< 2 (length statement)) (not (eq '|:| (third statement))))
+        (berror "INVALID TOKEN AFTER NEXT: '~A'." (third statement))
+        (let* ((varsym    (if (eq '|:| (second statement))
+                            nil (second statement)))
+               (for-state (find-for varsym)))
+          (if for-state
+            (let ((varsym    (second for-state))
+                  (target    (third for-state))
+                  (step      (fourth for-state))
+                  (linenum   (fifth for-state))
+                  (remainder (sixth for-state))
+                  (value     (gethash varsym *variables*)))
+              (setq value (+ value step))
+              (setf (gethash varsym *variables*) value)
+              (if (if (< 0 step) (<= value target) (<= target value))
+                (progn ;; loop
+                  (setq *current-line* linenum)
+                  (basic-eval (or remainder '(rem))))
+                (progn ;; exit loop
+                  (vector-pop *stack*)
+                  (basic-eval (if varsym
+                                (cdddr statement)
+                                (cddr  statement))))))
+            (if (null varsym)
+              (berror "NO 'FOR' LOOP.")
+              (berror "NO 'FOR' LOOP WITH THIS VARIABLE ~A." varsym))))))
+     ((if) ;; if bool then .... else ...
+      (multiple-value-bind (expr rest)
+          (slurp-expression (cdr statement) '(then))
+        (let ((condition (basic-eval-condition expr)))
+          (cond
+           ((null condition)) ;; error already issued
+           ((boolp condition)
+            (if (eq (car rest) 'then)
+              (if (eq :true condition)
+                ;; run after then
+                (basic-eval (cdr rest))
+                ;; run after else
+                (basic-eval (cdr (member 'else rest))))
+              (berror "EXPECTED 'THEN' AFTER 'IF' CONDITION, NOT '~A'."
+                      (car rest))))
+           (t
+            (berror "INVALID BOOL EXPRESSION."))))))
+     ((else)) ;; ignored and skip the rest of the line.
+     ((goto)
+      (multiple-value-bind (expr rest)
+          (slurp-expression (cdr statement) '(|:|))
+        (let ((value (basic-eval-expression expr)))
+          (if (and value (integerp value) (check-line value))
+            (setq *current-line* (1- value))
+            (berror "INVALID TARGET LINE NUMBER IN GOTO.")))))
+     ((gosub)
+      (multiple-value-bind (expr rest)
+          (slurp-expression (cdr statement) '(|:|))
+        (let ((value (basic-eval-expression expr)))
+          (if (and value (integerp value) (check-line value))
+            (progn
+              (vector-push-extend
+               (list :gosub *current-line* (cdr rest))
+               *stack* (array-dimension *stack* 0))
+              (setq *current-line* (1- value)))
+            (berror "INVALID TARGET LINE NUMBER IN GOSUB.")))))
+     ((return)
+      (let* ((gosub-state (find-gosub)))
+        (if gosub-state
+          (let ((linenum   (second gosub-state))
+                (remainder (third  gosub-state)))
+            (setq *current-line* linenum)
+            (if remainder (basic-eval remainder)))
+          (berror "NO 'GOSUB' FOR 'RETURN'."))))
+     ((input)
+      (let ((stat-list-var))
+        (if (stringp (second statement))
+          (let ((saved *current-line*))
+            (setq *current-line* nil)
+            (basic-eval (list 'print (second statement) '|;|))
+            (setq *current-line* saved)
+            (setq stat-list-var (cddr statement)))
+          (progn
+            (format t "> ")
+            (setq stat-list-var (cdr statement))))
+        (multiple-value-bind (listvar rest)
+            (slurp-expression stat-list-var '(|:|))
+          (let ((listsym (check-list-var listvar)))
+            (when listsym
+              (do* ((listsym listsym (cdr listsym))
+                    (varsym (car listsym) (car listsym))
+                    (vartype (identifier-type varsym) (identifier-type varsym))
+                    (value))
+                  ((null listsym))
+                (setq value (input-data (if (char= (character "$") vartype)
+                                          'string 'number)))
+                (cond
+                 ((null value))
+                 ;; the error is already issued and *current-line* nullified
+                 ((and (numberp value) (char/= (character "$") vartype))
+                  (setf (gethash varsym *variables*) value))
+                 ((and (stringp value) (char= (character "$") vartype))
+                  (setf (gethash varsym *variables*) value))
+                 (t (berror "TYPE MISMATCH FOR ~A." varsym)))))))))
+     ((data)) ;; skip the rest of the line which is data.
+     ((read)
+      (multiple-value-bind (listvar rest)
+          (slurp-expression (cdr statement) '(|:|))
+        (let ((listsym (check-list-var listvar)))
+          (when listsym
+            (do* ((listsym listsym (cdr listsym))
+                  (varsym (car listsym) (car listsym))
+                  (vartype (identifier-type varsym) (identifier-type varsym))
+                  (value))
+                ((null listsym))
+              (setq value (fetch-data))
+              (cond
+               ((null value))
+               ;; the error is already issued and *current-line* nullified
+               ((and (numberp value) (char/= (character "$") vartype))
+                (setf (gethash varsym *variables*) value))
+               ((and (stringp value) (char= (character "$") vartype))
+                (setf (gethash varsym *variables*) value))
+               (t (berror "TYPE MISMATCH FOR ~A." varsym))))))))
+     ((restore)
+      (let* ((rest nil)
+             (linenum
+              (multiple-value-bind (expr tser)
+                  (slurp-expression (cdr statement) '(|:|))
+                (prog1
+                    (if (null expr)
+                      (if (or (null (cdr statement))
+                              (eq '|:| (cadr statement)))
+                        1
+                        (progn (berror "UNEXPECTED TOKEN AFTER RESTORE: ~A"
+                                       (cadr statement))
+                               nil))
+                      (basic-eval-expression expr))
+                  (setq rest (cdr tser))))))
+        (when linenum
+          (if (check-line linenum)
+            (progn
+              (setq *data-ptr* (cons (1- linenum) nil))
+              (basic-eval (or rest '(rem))))
+            (berror "INVALID LINE NUMBER FOR READ: ~A" linenum)))))
+     ((rem)) ;; ignored
+     ((stop)
+      (setq *current-line* nil))
+     ((run)
+      (setf (fill-pointer *stack*) 0)
+      (setq *data-ptr* (cons 0 nil))
+      (setq *variables* (make-hash-table :test (function eq) :size 100))
+      (if (and (cdr statement) (integerp (second statement)))
+        (when (check-line (second statement))
+          (basic-eval (or (find-line-or-next (second statement))
+                          (find-line-or-next 1))))
+        (basic-eval (find-line-or-next 1)))
+      (setq *current-line* nil))
+     ((list)
+      (dotimes (linenum (array-dimension *program* 0))
+        (let ((line (aref *program* linenum)))
+          (when line
+            (format t "~4D " linenum)
+            (mapc (lambda (token)
+                    (if (symbolp token)
+                      (format t "~A " (symbol-name token))
+                      (format t "~S " token))) line)
+            (format t "~%")))))
+     ((dir)
+      (format t "~{~A~%~}" (mapcar (function pathname-name)
+                                   (directory "*.basic"))))
+     ((save)
+      (if (stringp (cadr statement))
+        (with-open-file (*standard-output*
+                         (cadr statement) :direction :output
+                         :if-exists :supersede :if-does-not-exist :create)
+          (let ((saved *current-line*))
+            (setq *current-line* nil)
+            (basic-eval '(list))
+            (setq *current-line* saved)))
+        (berror "NOT A FILE NAME: ~S." (cadr statement))))
+     ((load)
+      (if (stringp (second statement))
+        (progn
+          (with-open-file (in (cadr statement) :direction :input
+                              :if-does-not-exist nil)
+            (if (null in)
+              (berror "CAN'T FIND A FILE FILE NAMED: ~S." (cadr statement))
+              (progn
+                (setq *current-line* nil)
+                (basic-eval '(erase all))
+                (do ((line (read-line in nil nil) (read-line in nil nil)))
+                    ((not line))
+                  (basic-process-line line)))))
+          (setq *current-line*
+                (if (and (numberp (third statement))
+                         (check-line (third statement)))
+                  (1- (third statement)) nil)))
+        (berror "NOT A FILE NAME: ~S." (second statement))))
+     ((erase)
+      (mapc (lambda (linenum)
+              (cond
+               ((integerp linenum)
+                (when (check-line linenum)
+                  (setf (aref *program* linenum) nil)))
+               ((eq 'all linenum)
+                (dotimes (i (array-dimension *program* 0))
+                  (setf (aref *program* i) nil)))
+               (t (berror "NOT A LINE NUMBER: ~S." linenum))))
+            (cdr statement)))
+     ((bye) (setq *current-line* nil) (return :bye))
+     (otherwise
+      (let* ((varsym   (car statement))
+             (variable (if (symbolp varsym) (symbol-name varsym)   nil))
+             (vartype  (if variable (char variable (1- (length variable))))))
+        (if (and variable
+                 (alpha-char-p (char variable 0))
+                 (eq '= (second statement)))
+          ;; assignment
+          (multiple-value-bind (expr rest)
+              (slurp-expression (cddr statement) '(|:|))
+            (if (or (null rest) (eq (car rest) '|:|))
+              (progn
+                (let ((value (basic-eval-expression expr)))
+                  (cond
+                   ((null value))
+                   ;; the error is already issued and *current-line* nullified
+                   ((and (numberp value) (char/= (character "$") vartype))
+                    (setf (gethash varsym *variables*) value))
+                   ((and (stringp value) (char= (character "$") vartype))
+                    (setf (gethash varsym *variables*) value))
+                   (t (berror "TYPE MISMATCH FOR ~A." variable))))
+                (when rest (basic-eval (cdr rest))))
+              (berror "INVALID TOKEN ~S IN EXPRESSION." (car rest))))
+          (berror "INVALID TOKEN ~S IN STATEMENT." (car statement)))))
+     ) ;;case
+   (if *current-line*
+     (progn
+       (incf *current-line*)
+       (setq statement (find-line-or-next *current-line*)))
+     (return nil))))
+
+
+(defun basic-process-line (line)
+  "
+DO:         Process one BASIC line.
+"
+  (multiple-value-bind (tokens err) (split-line line)
+    (setq tokens (let ((*package* (find-package "BASIC")))
+                   (mapcar (lambda (item) (read-from-string item)) tokens)))
+    (cond (err (berror "~A" err))
+          ((and (< 0 (length tokens)) (integerp (car tokens)))
+           (when (check-line (car tokens))
+             (setf (aref *program* (car tokens)) (cdr tokens))))
+          (t (setq *current-line* nil)
+             (basic-eval tokens)))))
+
+
+(defun basic ()
+  "
+DO:         Read a line and either execute it or store it in the program.
+            Repeat until the BYE command is executed.
+"
+  (setf (fill-pointer *stack*) 0)
+  (setq *data-ptr* (cons 0 nil))
+  (format t "*** QUICK-DIRTY-AND-UGLY BASIC, VERSION 0.1 ***~%~
+             COPYRIGHT PASCAL J. BOURGUIGNON 2003~%~
+             QUICK-DIRTY-AND-UGLY BASIC COMES WITH *ABSOLUTELY NO WARRANTY*.~%~
+             THIS IS FREE SOFTWARE, AND YOU ARE WELCOME TO REDISTRIBUTE IT~%~
+             UNDER THE CONDITIONS LISTED IN THE GNU PUBLIC LICENSE.~4%")
+  (block :top-level
+    (loop
+     (format t "~&> ")
+     (let ((line (read-line *standard-input* nil nil)))
+       (unless line (return-from :top-level))
+       (if (eq :bye (basic-process-line line))
+         (return-from :top-level)))))
+  (values))
+
+
+(defun main (&rest arguments)
+  (declare (ignore arguments))
+  (basic))
+
+
+;;;; basic.lisp                       -- 2004-03-14 01:34:04 -- pascal   ;;;;