resume in gosub

beautiful-racket/br/demo/basic/aceyducey.bas

@@ -0,0 +1,101 @@
+#lang br/demo/basic
+10 PRINT TAB(26);"ACEY DUCEY CARD GAME"
+20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+21 PRINT
+22 PRINT
+30 PRINT"ACEY-DUCEY IS PLAYED IN THE FOLLOWING MANNER "
+40 PRINT"THE DEALER (COMPUTER) DEALS TWO CARDS FACE UP"
+50 PRINT"YOU HAVE AN OPTION TO BET OR NOT BET DEPENDING"
+60 PRINT"ON WHETHER OR NOT YOU FEEL THE CARD WILL HAVE"
+70 PRINT"A VALUE BETWEEN THE FIRST TWO."
+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."
+130 PRINT
+140 GOTO 260
+210 Q=Q+M
+220 GOTO 120
+240 Q=Q-M
+250 GOTO 120
+260 PRINT"HERE ARE YOUR NEXT TWO CARDS: "
+270 A=INT(14*RND(1))+2
+280 IF A<2 THEN 270
+290 IF A>14 THEN 270
+300 B=INT(14*RND(1))+2
+310 IF B<2 THEN 300
+320 IF B>14 THEN 300
+330 IF A>=B THEN 270
+350 IF A<11 THEN 400
+360 IF A=11 THEN 420
+370 IF A=12 THEN 440
+380 IF A=13 THEN 460
+390 IF A=14 THEN 480
+400 PRINT A
+410 GOTO 500
+420 PRINT"JACK"
+430 GOTO 500
+440 PRINT"QUEEN"
+450 GOTO 500
+460 PRINT"KING"
+470 GOTO 500
+480 PRINT"ACE"
+500 IF B<11 THEN 550
+510 IF B=11 THEN 570
+520 IF B=12 THEN 590
+530 IF B=13 THEN 610
+540 IF B=14 THEN 630
+550 PRINT B
+560 GOTO 650
+570 PRINT"JACK"
+580 GOTO 650
+590 PRINT"QUEEN"
+600 GOTO 650
+610 PRINT"KING"
+620 GOTO 650
+630 PRINT"ACE"
+640 PRINT
+650 PRINT
+660 INPUT"WHAT IS YOUR BET";M
+670 IF M<>0 THEN 680
+675 PRINT"CHICKEN!!"
+676 PRINT
+677 GOTO 260
+680 IF M<=Q THEN 730
+690 PRINT"SORRY, MY FRIEND, BUT YOU BET TOO MUCH."
+700 PRINT"YOU HAVE ONLY ";Q;" DOLLARS TO BET."
+710 GOTO 650
+730 C=INT(14*RND(1))+2
+740 IF C<2 THEN 730
+750 IF C>14 THEN 730
+760 IF C<11 THEN 810
+770 IF C=11 THEN 830
+780 IF C=12 THEN 850
+790 IF C=13 THEN 870
+800 IF C=14 THEN 890
+810 PRINT C
+820 GOTO 910
+830 PRINT"JACK"
+840 GOTO 910
+850 PRINT"QUEEN"
+860 GOTO 910
+870 PRINT"KING"
+880 GOTO 910
+890 PRINT "ACE"
+900 PRINT
+910 IF C>A THEN 930
+920 GOTO 970
+930 IF C>=B THEN 970
+950 PRINT"YOU WIN!!!"
+960 GOTO 210
+970 PRINT"SORRY, YOU LOSE"
+980 IF M<Q THEN 240
+990 PRINT
+1000 PRINT
+1010 PRINT"SORRY, FRIEND, BUT YOU BLEW YOUR WAD."
+1015 PRINT:PRINT
+1020 INPUT"TRY AGAIN (YES OR NO)";A$
+1025 PRINT:PRINT
+1030 IF A$="YES" THEN 110
+1040 PRINT"O.K., HOPE YOU HAD FUN!"
+1050 END

beautiful-racket/br/demo/basic/change.bas

@@ -1,3 +1,4 @@
+#lang br/demo/basic
 2 PRINT TAB(33);"CHANGE"
 4 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
 5 PRINT:PRINT:PRINT

beautiful-racket/br/demo/basic/chemist.bas

@@ -0,0 +1,29 @@
+#lang br/demo/basic
+
+3 PRINT TAB(33);"CHEMIST"
+6 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+8 PRINT:PRINT:PRINT
+10 PRINT "THE FICTITIOUS CHECMICAL KRYPTOCYANIC ACID CAN ONLY BE"
+20 PRINT "DILUTED BY THE RATIO OF 7 PARTS WATER TO 3 PARTS ACID."
+30 PRINT "IF ANY OTHER RATIO IS ATTEMPTED, THE ACID BECOMES UNSTABLE"
+40 PRINT "AND SOON EXPLODES.  GIVEN THE AMOUNT OF ACID, YOU MUST"
+50 PRINT "DECIDE WHO MUCH WATER TO ADD FOR DILUTION.  IF YOU MISS"
+60 PRINT "YOU FACE THE CONSEQUENCES."
+100 A=INT(RND(1)*50)
+110 W=7*A/3
+120 PRINT A;"LITERS OF KRYPTOCYANIC ACID.  HOW MUCH WATER";
+130 INPUT R
+140 D=ABS(W-R)
+150 IF D>W/20 THEN 200
+160 PRINT " GOOD JOB! YOU MAY BREATHE NOW, BUT DON'T INHALE THE FUMES!"
+170 PRINT
+180 GOTO 100
+200 PRINT " SIZZLE!  YOU HAVE JUST BEEN DESALINATED INTO A BLOB"
+210 PRINT " OF QUIVERING PROTOPLASM!"
+220 T=T+1
+230 IF T=9 THEN 260
+240 PRINT " HOWEVER, YOU MAY TRY AGAIN WITH ANOTHER LIFE."
+250 GOTO 100
+260 PRINT " YOUR 9 LIVES ARE USED, BUT YOU WILL BE LONG REMEMBERED FOR"
+270 PRINT " YOUR CONTRIBUTIONS TO THE FIELD OF COMIC BOOK CHEMISTRY."
+280 END

beautiful-racket/br/demo/basic/expander.rkt

@@ -10,8 +10,8 @@
 (define #'(basic-module-begin PARSE-TREE ...)
   #'(#%module-begin
      (inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$)
-       (println (quote PARSE-TREE ...))
-       PARSE-TREE ...)))
+                                (println (quote PARSE-TREE ...))
+                                PARSE-TREE ...)))
 
 ; #%app and #%datum have to be present to make #%top work
 (define #'(basic-top . id)
@@ -23,40 +23,66 @@
 
 (define (run lines)
   (define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines)))
-  (void (for/fold ([line-idx 0])
-                  ([i (in-naturals)]
-                   #:break (= line-idx (vector-length program-lines)))
-          (match-define (cons line-number proc)
-            (vector-ref program-lines line-idx))
-          (define maybe-jump-number (and proc (proc)))
-          (if (number? maybe-jump-number)
-              (let ([jump-number maybe-jump-number])
-                (for/or ([idx (in-range (vector-length program-lines))])
-                        (and (= (car (vector-ref program-lines idx)) jump-number)
-                             idx)))
-              (add1 line-idx)))))
+  (void (with-handlers ([exn:program-end? (λ (exn) (void))])
+          (for/fold ([program-counter 0])
+                    ([i (in-naturals)]
+                     #:break (= program-counter (vector-length program-lines)))
+            (match-define (cons line-number proc)
+              (vector-ref program-lines program-counter))
+            (define maybe-jump-number (and proc (proc)))
+            (if (number? maybe-jump-number)
+                (let ([jump-number maybe-jump-number])
+                  (for/or ([idx (in-range (vector-length program-lines))])
+                          (and (= (car (vector-ref program-lines idx)) jump-number)
+                               idx)))
+                (add1 program-counter))))))
 
 (define #'(cr-line ARG ...) #'(begin ARG ...))
 
-(define #'(line NUMBER STATEMENT ...)
-  #'(cons NUMBER (λ _ STATEMENT ...)))
 
+(define current-return-stack (make-parameter empty))
+
+(define-cases #'line
+  [#'(_ NUMBER (STATEMENT "GOSUB" WHERE)) #'(cons NUMBER
+                                                  (λ _
+                                                    (current-return-stack (cons NUMBER (current-return-stack)))
+                                                    (GOTO WHERE)))]
+  [#'(_ NUMBER STATEMENT ...)  #'(cons NUMBER (λ _ STATEMENT ...))])
 
-(define vars (make-hasheq))
 
 (define-cases #'statement
   [#'(statement ID "=" EXPR) #'(set! ID EXPR)]
   [#'(statement PROC ARG ...) #'(PROC ARG ...)])
 
+(define-cases #'IF
+  [#'(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT)
+   #'(if (true? COND)
+         TRUE-RESULT
+         FALSE-RESULT)]
+  [#'(_ COND "THEN" TRUE-RESULT)
+   #'(when (true? COND)
+       TRUE-RESULT)])
+
 (define-cases #'value
   [#'(value "(" EXPR ")") #'EXPR]
   [#'(value ID "(" ARG ... ")") #'(ID ARG ...)]
   [#'(value ID-OR-DATUM) #'ID-OR-DATUM])
 
-(define-cases expr
-  [(_ lexpr op rexpr) (if (op lexpr rexpr) 1 0)]
-  [(_ expr) expr])
-(provide < > <= >=)
+(define true? (compose1 not zero?))
+
+(define-cases #'expr
+  [#'(_ LEXPR "AND" REXPR)
+   #'(if (and (true? LEXPR) (true? REXPR)) 1 0)]
+  [#'(_ LEXPR "OR" REXPR)
+   #'(if (or (true? LEXPR) (true? REXPR)) 1 0)]
+  [#'(_ EXPR) #'EXPR])
+
+(define-cases #'comp-expr
+  [#'(_ lexpr "=" rexpr) #'(comp-expr lexpr equal? rexpr)] ; special case because = is overloaded
+  [#'(_ lexpr op rexpr) #'(if (op lexpr rexpr) 1 0)]
+  [#'(_ expr) #'expr])
+(define (<> lexpr rexpr) (not (equal? lexpr rexpr)))
+(provide < > <= >= <>)
 
 (define-cases sum
   [(_ term op sum) (op term sum)]
@@ -73,21 +99,46 @@
 (define (PRINT args)
   (match args
     [(list) (displayln "")]
-    [(list print-list-item ... ";" pl) (begin (for-each display print-list-item) (PRINT pl))]
-    [(list print-list-item ... ";") (for-each display print-list-item)]
+    [(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
+                                              (display " ")
+                                              (PRINT pl))]
+    [(list print-list-item ... ";") (begin
+                                      (for-each display print-list-item)
+                                      (display " "))]
     [(list print-list-item ...) (for-each displayln print-list-item)]))
 
 (define (TAB num) (make-string num #\space))
-(define (INT num) (inexact->exact (round num)))
+(define #'(INT EXPR ...) #'(inexact->exact (round (expr EXPR ...))))
 (define (SIN num) (sin num))
+(define (ABS num) (inexact->exact (abs num)))
 (define (RND num) (* (random) num))
 
-(define #'(INPUT PRINT-LIST ";" ID)
-  #'(begin
-      (PRINT (append PRINT-LIST (list ";")))
-      (set! ID (read-line))))
+(define-cases #'INPUT
+  [#'(_ PRINT-LIST ";" ID)
+   #'(begin
+       (PRINT (append PRINT-LIST (list ";")))
+       (INPUT ID))]
+  [#'(_ ID) #'(set! ID (let* ([str (read-line)]
+                              [num (string->number str)])
+                         (if num num str)))])
 
 (define (GOTO where)
   where)
 
+(define (GOSUB where)
+  where)
+
+(define (RETURN)
+  (define where (car (current-return-stack)))
+  (current-return-stack (cdr (current-return-stack)))
+  where)
+
+
+(struct exn:program-end exn:fail ())
+(define (END)
+  (raise
+   (exn:program-end
+    "program ended"
+    (current-continuation-marks))))
+
 (define (comment . args) void)

beautiful-racket/br/demo/basic/gosub.bas

@@ -0,0 +1,5 @@
+#lang br/demo/basic
+10 GOSUB 40
+11 END
+20 PRINT "YAY"
+25 RETURN

beautiful-racket/br/demo/basic/parser.rkt

@@ -6,24 +6,30 @@ program : [line [CR line]*]
 line: INTEGER statement+
 
 statement : "END"
-| "FOR" ID "=" expr "TO" expr ["STEP" expr]     
+| "FOR" ID "=" expr "TO" expr ["STEP" expr]
+| "GOSUB" INTEGER
 | "GOTO" expr
-| "IF" expr "THEN" (statement | expr) ; change: add expr
-| "INPUT" print-list ";" ID
+| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]; change: add expr
+| "INPUT" [print-list ";"] ID
 | ["LET"] ID "=" expr ; change: make "LET" opt
 | "NEXT" ID+
 | "PRINT" print-list
+| "RETURN"
 | REM-COMMENT
 
 print-list : [expr [";" [print-list]]]
 
-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") expr]
+expr : comp-expr [("AND" | "OR") expr]
+
+comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
 
 sum : product [("+" | "-") sum]
 
 product : value [("*" | "/") product]
 
-value : ID ["(" expr* ")"]
+value : "(" expr ")"
+| ID
+| PROC "(" expr* ")"
 | INTEGER
 | STRING
 | REAL

beautiful-racket/br/demo/basic/tokenizer.rkt

@@ -12,9 +12,10 @@
        [(:seq "REM" (repetition 1 +inf.0 (char-complement "\n")))
         (token 'REM-COMMENT (format-datum '(comment "~v") lexeme))]
        [(repetition 1 +inf.0 "\n") (token 'CR "cr")]
-       [(union "PRINT" "FOR" "TO" "STEP" "IF" "THEN" "GOTO"
-               "INPUT" "LET" "NEXT" "GOSUB" "RETURN"
+       [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
+               "INPUT" "LET" "NEXT"  "RETURN"
                "CLEAR" "LIST" "RUN" "END") (string->symbol lexeme)]
+       [(union "THEN" "ELSE" "GOSUB") lexeme]
        
        ;; this only matches integers
        [(repetition 1 +inf.0 numeric) (token 'INTEGER (string->number lexeme))]
@@ -27,6 +28,7 @@
        [(union ";" "=" "(" ")") lexeme]
        [(union "+" "-" "*" "/"
                "<=" ">=" "<>" "><" "<" ">" "=" ) (string->symbol lexeme)]
+       [(union "RND" "INT" "TAB" "SIN" "ABS") (token 'PROC (string->symbol lexeme))]
        [(:seq (repetition 1 +inf.0 upper-case) (:? "$")) (token 'ID (string->symbol lexeme))]
        [upper-case (token 'UPPERCASE (string->symbol lexeme))]
        [whitespace (token 'WHITESPACE lexeme #:skip? #t)]