about summary refs log tree commit diff stats
path: root/basic.lisp
blob: 6853507202cfff242ebaedcb584eb4bbf16fbb58 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
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   ;;;;