need separate namespace for dim vars

8 years ago · 3bbbf45358
parent 7903287fa2
commit 3bbbf45358
8 changed files with 222 additions and 24 deletions
--- a/beautiful-racket/br/demo/basic/aceyducey.bas
+++ b/beautiful-racket/br/demo/basic/aceyducey.bas
@ -11,7 +11,7 @@
 80 PRINT"IF YOU DO NOT WANT TO BET, INPUT A 0"
 100 N=100
 110 Q=100
-120 PRINT "YOU NOW HAVE ";Q;" DOLLARS."
+120 PRINT "YOU NOW HAVE";Q;"DOLLARS."
 130 PRINT
 140 GOTO 260
 210 Q=Q+M
--- a/beautiful-racket/br/demo/basic/amazing.bas
+++ b/beautiful-racket/br/demo/basic/amazing.bas
@ -1,9 +1,138 @@
 #lang br/demo/basic
-1 REM http://www.vintage-basic.net/bcg/amazing.bas

 10 PRINT TAB(28);"AMAZING PROGRAM"
 20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
 30 PRINT:PRINT:PRINT:PRINT
-100 INPUT "WHAT ARE YOUR WIDTH AND LENGTH";H,V
-102 IF H<>1 AND V<>1 THEN 110
-104 PRINT "MEANINGLESS DIMENSIONS.  TRY AGAIN.":GOTO 100
+100 H = 10 : V = 10
+110 DIM W(H,V),V(H,V)
+120 PRINT
+130 PRINT
+140 PRINT
+150 PRINT
+160 Q=0:Z=0:X=INT(0.5*H+1)
+165 FOR I=1 TO H
+170 IF I=X THEN 173
+171 PRINT ".--";:GOTO 180
+173 PRINT ".  ";
+180 NEXT I
+190 PRINT "."
+195 C=1:W(X,1)=C:C=C+1
+200 R=X:S=1:GOTO 260
+210 IF R<>H THEN 240
+215 IF S<>V THEN 230
+220 R=1:S=1:GOTO 250
+230 R=1:S=S+1:GOTO 250
+240 R=R+1
+250 IF W(R,S)=0 THEN 210
+260 IF R-1=0 THEN 530
+265 IF W(R-1,S)<>0 THEN 530
+270 IF S-1=0 THEN 390
+280 IF W(R,S-1)<>0 THEN 390
+290 IF R=H THEN 330
+300 IF W(R+1,S)<>0 THEN 330
+310 X=INT(0.5*3+1)
+320 ON X GOTO 790,820,860
+330 IF S<>V THEN 340
+334 IF Z=1 THEN 370
+338 Q=1:GOTO 350
+340 IF W(R,S+1)<>0 THEN 370
+350 X=INT(0.5*3+1)
+360 ON X GOTO 790,820,910
+370 X=INT(0.5*2+1)
+380 ON X GOTO 790,820
+390 IF R=H THEN 470
+400 IF W(R+1,S)<>0 THEN 470
+405 IF S<>V THEN 420
+410 IF Z=1 THEN 450
+415 Q=1:GOTO 430
+420 print R ; S+1 : IF W(R,S+1)<>0 THEN 450
+430 X=INT(0.5*3+1)
+440 ON X GOTO 790,860,910
+450 X=INT(0.5*2+1)
+460 ON X GOTO 790,860
+470 IF S<>V THEN 490
+480 IF Z=1 THEN 520
+485 Q=1:GOTO 500
+490  print R ; S+1 : IF W(R,S+1)<>0 THEN 520
+500 X=INT(0.5*2+1)
+510 ON X GOTO 790,910
+520 GOTO 790
+530 IF S-1=0 THEN 670
+540 IF W(R,S-1)<>0 THEN 670
+545 IF R=H THEN 610
+547 IF W(R+1,S)<>0 THEN 610
+550 IF S<>V THEN 560
+552 IF Z=1 THEN 590
+554 Q=1:GOTO 570
+560 IF W(R,S+1)<>0 THEN 590
+570 X=INT(0.5*3+1)
+580 ON X GOTO 820,860,910
+590 X=INT(0.5*2+1)
+600 ON X GOTO 820,860
+610 IF S<>V THEN 630
+620 IF Z=1 THEN 660
+625 Q=1:GOTO 640
+630 IF W(R,S+1)<>0 THEN 660
+640 X=INT(0.5*2+1)
+650 ON X GOTO 820,910
+660 GOTO 820
+670 IF R=H THEN 740
+680 IF W(R+1,S)<>0 THEN 740
+685 IF S<>V THEN 700
+690 IF Z=1 THEN 730
+695 Q=1:GOTO 830
+700 IF W(R,S+1)<>0 THEN 730
+710 X=INT(0.5*2+1)
+720 ON X GOTO 860,910
+730 GOTO 860
+740 IF S<>V THEN 760
+750 IF Z=1 THEN 780
+755 Q=1:GOTO 770
+760 IF W(R,S+1)<>0 THEN 780
+770 GOTO 910
+780 GOTO 1000
+790 W(R-1,S)=C
+800 C=C+1:V(R-1,S)=2:R=R-1
+810 IF C=H*V+1 THEN 1010
+815 Q=0:GOTO 260
+820 W(R,S-1)=C
+830 C=C+1
+840 V(R,S-1)=1:S=S-1:IF C=H*V+1 THEN 1010
+850 Q=0:GOTO 260
+860 W(R+1,S)=C
+870 C=C+1:IF V(R,S)=0 THEN 880
+875 V(R,S)=3:GOTO 890
+880 V(R,S)=2
+890 R=R+1
+900 IF C=H*V+1 THEN 1010
+905 GOTO 530
+910 IF Q=1 THEN 960
+920 W(R,S+1)=C:C=C+1:IF V(R,S)=0 THEN 940
+930 V(R,S)=3:GOTO 950
+940 V(R,S)=1
+950 S=S+1:IF C=H*V+1 THEN 1010
+955 GOTO 260
+960 Z=1
+970 IF V(R,S)=0 THEN 980
+975 V(R,S)=3:Q=0:GOTO 1000
+980 V(R,S)=1:Q=0:R=1:S=1:GOTO 250
+1000 GOTO 210
+1010 FOR J=1 TO V
+1011 PRINT "I";
+1012 FOR I=1 TO H
+1013 IF V(I,J)<2 THEN 1030
+1020 PRINT "   ";
+1021 GOTO 1040
+1030 PRINT "  I";
+1040 NEXT I
+1041 PRINT
+1043 FOR I=1 TO H
+1045 IF V(I,J)=0 THEN 1060
+1050 IF V(I,J)=2 THEN 1060
+1051 PRINT ":  ";
+1052 GOTO 1070
+1060 PRINT ":--";
+1070 NEXT I
+1071 PRINT "."
+1072 NEXT J
+1073 END
--- a/beautiful-racket/br/demo/basic/dim.bas
+++ b/beautiful-racket/br/demo/basic/dim.bas
@ -0,0 +1,7 @@
+#lang br/demo/basic
+
+5 A=5
+10 DIM A(A)
+20 PRINT A /* this should print 5 */
+30 PRINT A(0)
+40 PRINT A(5)
--- a/beautiful-racket/br/demo/basic/expander.rkt
+++ b/beautiful-racket/br/demo/basic/expander.rkt
@ -18,6 +18,7 @@
                       (gather-unique-ids #'(PROGRAM-LINE ...)))])
    #'(#%module-begin
       (define UNIQUE-ID 0) ...
+       (provide UNIQUE-ID ...)
       (run PROGRAM-LINE ... (line #f (statement "end"))))))

 ; #%app and #%datum have to be present to make #%top work
@ -66,18 +67,33 @@
    (set! return-stack (cons return-k return-stack))
    (basic:goto where)))

+(define current-line (make-parameter #f))
 (struct $line (number thunk))
 (define-macro (line NUMBER . STATEMENTS)
-  #'($line NUMBER (λ () (with-handlers ([end-line-signal? (λ _ #f)])
-                          . STATEMENTS))))
+  #'($line NUMBER (λ ()
+                    (current-line NUMBER)
+                    (with-handlers ([end-line-signal? (λ _ #f)]
+                                    [end-program-signal? raise]
+                                    [exn:fail? (λ(exn)
+                                                 (displayln (format "in line ~a" NUMBER))
+                                                 (raise exn))])
+                      . STATEMENTS))))

 (define-macro statement
-  [(statement ID "=" EXPR) #'(set! ID EXPR)]
+  [(statement ID "=" EXPR) #'(basic:let ID EXPR)]
  [(statement PROC-NAME . ARGS)
   (with-pattern
       ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
     #'(PROC-ID . ARGS))])

+(define-macro basic:let
+  [(_ (id-expr ID) EXPR)
+   #'(begin
+       #;(displayln (format "setting ~a = ~a in ~a" 'ID EXPR (current-line)))
+       (set! ID EXPR))]
+  [(_ (id-expr ID DIM-IDX ...) EXPR)
+   #'(array-set! ID DIM-IDX ... EXPR)])
+
 (define-macro basic:if
  [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
   #'(if (true? COND-EXPR)
@ -93,6 +109,16 @@
 (define (basic:and . args) (cond->int (andmap true? args)))
 (define (basic:or . args) (cond->int (ormap true? args)))

+(define-macro id-expr
+  [(_ ID) #'(cond
+              [(procedure? ID) (ID)]
+              [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element
+              [else ID])]
+  [(_ ID EXPR0 EXPR ...) #'(cond
+                             [(procedure? ID) (ID EXPR0 EXPR ...)]
+                             [(array? ID) (array-ref ID EXPR0 EXPR ...)]
+                             [else (error 'id-expr-confused)])])
+
 (define-macro expr
  [(_ COMP-EXPR) #'COMP-EXPR]
  [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
@ -132,22 +158,30 @@

 ;; todo: make it work more like http://www.antonis.de/qbebooks/gwbasman/PRINT.html
 (define (basic:print [args #f])
+  (define (println [x ""]) (displayln x) (set! current-print-position 0))
+  (define (print x) (display x) (set! current-print-position (+ current-print-position (string-length x))))
+  
  (match args
-    [#f (displayln "")]
-    [(list print-list-item ... ";" pl) (begin (for-each (λ(pli)
-                                                          (let ([pli (if (number? pli)
-                                                                         (format "~a " pli)
-                                                                         pli)])
-                                                            (display pli))) print-list-item)
-                                              (basic:print pl))]
-    [(list print-list-item ... ";") (for-each display print-list-item)]
-    [(list print-list-item ...) (for-each displayln print-list-item)]))
+    [#f (println)]
+    [(list print-list-items ... ";" pl)
+     (begin
+       (for-each
+        (λ(pli)
+          (print (if (number? pli)
+                     (format "~a " pli)
+                     pli)))
+        print-list-items)
+       (basic:print pl))]
+    [(list print-list-items ... ";") (for-each print print-list-items)]
+    [(list print-list-items ...)
+     (for-each println print-list-items)]))


 ;; todo: make it work more like http://www.antonis.de/qbebooks/gwbasman/TAB.html
 ;; need to track current line position
-(define (TAB num) (make-string num #\space))
-(define-macro (INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
+(define current-print-position 0)
+(define (TAB num) (make-string (max 0 (- num current-print-position)) #\space))
+(define (INT num) (inexact->exact (truncate num)))
 (define (SIN num) (sin num))
 (define (ABS num) (inexact->exact (abs num)))
 (define (RND num) (* (random) num))
@ -166,6 +200,13 @@

 (define (basic:goto where) where)

+(define-macro basic:on
+  [(_ TEST-EXPR "goto" OPTION ...)
+   #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]
+  [(_ TEST-EXPR "gosub" OPTION ...)
+   #'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))])
+
+
 (define (basic:return)
  (define return-k (car return-stack))
  (set! return-stack (cdr return-stack))
@ -174,6 +215,12 @@
 (define (basic:stop) (basic:end))
 (define (basic:end) (raise-end-program-signal))

+(require srfi/25)
+
+(define-macro (basic:dim (id-expr ID EXPR ...) ...)
+  #'(begin
+      (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...))
+
 (define for-stack empty)

 (define (push-for-stack thunk)
@ -191,7 +238,7 @@
   #'(basic:for VAR START-VALUE END-VALUE 1)]
  [(_ VAR START-VALUE END-VALUE STEP-VALUE)
   #'(begin
-       (statement VAR "=" START-VALUE) ; initialize the loop counter
+       (statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter
       (let/cc return-k ; create a return point
         (push-for-stack (cons 'VAR
                               (λ () ; thunk that increments counter & teleports back to beginning of loop
--- a/beautiful-racket/br/demo/basic/importest.rkt
+++ b/beautiful-racket/br/demo/basic/importest.rkt
@ -0,0 +1,2 @@
+#lang racket
+(require "for.bas")
--- a/beautiful-racket/br/demo/basic/on.bas
+++ b/beautiful-racket/br/demo/basic/on.bas
@ -0,0 +1,11 @@
+#lang br/demo/basic
+10 X = 3
+20 on X gosub 210, 220, 230
+21 print "yay"
+22 end
+210 print "one"
+211 return
+220 print "two"
+221 return
+230 print "three"
+231 return
--- a/beautiful-racket/br/demo/basic/parser.rkt
+++ b/beautiful-racket/br/demo/basic/parser.rkt
@ -5,12 +5,14 @@ basic-program : line*
 line: NUMBER statement [/":" statement]*

 statement : "def" id /"(" id /")" /"=" expr
+| "dim" id-expr [/"," id-expr]*
 | "end" | "stop"
 | "gosub" expr
 | "goto" expr
+| "on" expr ("gosub" | "goto") expr [/"," expr]*
 | "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
 | "input" [print-list /";"] id [/"," id]*
-| [/"let"] id "=" expr
+| [/"let"] id-expr "=" expr
 | "print" [print-list]
 | "return"
 | "for" id /"=" value /"to" value [/"step" value]
@ -32,10 +34,10 @@ product : [product ("*" | "/")] value
 | number
 | STRING

-/id-expr : id [/"(" expr [/"," expr]* /")"]
+id-expr : id [/"(" expr [/"," expr]* /")"]

@id : ID

-id-val : ["-"] id
+id-val : ["-"] id-expr

 number : ["-"] NUMBER
--- a/beautiful-racket/br/demo/basic/tokenizer.rkt
+++ b/beautiful-racket/br/demo/basic/tokenizer.rkt
@ -23,7 +23,7 @@
               "GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next"
               "RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run"
               "END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub"
-               "AND" "and" "OR" "or" "STOP" "stop" "LET" "let" "DEF" "def"
+               "AND" "and" "OR" "or" "STOP" "stop" "LET" "let" "DEF" "def" "DIM" "dim" "ON" "on"
               ";" "=" "(" ")" "+" "-" "*" "/"
               "<=" ">=" "<>" "<" ">" "=" ":" ",") (string-downcase lexeme)]
       [number (token 'NUMBER (string->number lexeme))]