handle negative numbers, for / next

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

@@ -1,39 +1,15 @@
 #lang br/quicklang
-(require (for-syntax racket/list sugar/debug))
-(provide (matching-identifiers-out #rx"^b-" (all-defined-out)))
-
-(struct line-error (msg))
-
-(define (handle-line-error num le)
-  (error (format "error in line ~a: ~a" num (line-error-msg le))))
-
-(define return-ks empty)
-
-(define (b-gosub num-expr)
-  (let/cc return-k
-    (push! return-ks return-k)
-    (b-goto num-expr)))
-
-(define (b-return)
-  (unless (pair? return-ks)
-    (raise (line-error "return without gosub")))
-  (define top-return-k (pop! return-ks))
-  (top-return-k))
-
-(define-macro (b-line NUM STATEMENT ...)
-  (with-pattern ([LINE-NUM (prefix-id "line-" #'NUM
-                                      #:source #'NUM)])
-    (syntax/loc caller-stx
-      (define (LINE-NUM)
-        (with-handlers ([line-error? (λ (le) (handle-line-error NUM le))])
-          (void) STATEMENT ...)))))
-
-(define-for-syntax (find-unique-var-names stx)
-  (remove-duplicates
-   (for/list ([var-stx (in-list (syntax-flatten stx))]
-              #:when (syntax-property var-stx 'b-id))
-             var-stx)
-   #:key syntax->datum))
+(require "runtime.rkt"
+         "run.rkt"
+         "line.rkt"
+         "expr.rkt"
+         "misc.rkt"
+         "flow.rkt")
+(provide (rename-out [b-module-begin #%module-begin])
+         (all-from-out "line.rkt"
+                       "expr.rkt"
+                       "misc.rkt"
+                       "flow.rkt"))
 
 (define-macro (b-module-begin (b-program LINE ...))
   (with-pattern
@@ -41,45 +17,25 @@
        [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))]
        [(VAR-NAME ...) (find-unique-var-names #'(LINE ...))])
     #'(#%module-begin
+       (module configure-runtime br
+         (require basic-demo-2/runtime)
+         (current-basic-port (current-output-port)))
        (define VAR-NAME 0) ...
+       (provide VAR-NAME ...)
        LINE ...
        (define line-table
          (apply hasheqv (append (list NUM LINE-FUNC) ...)))
-       (void (run line-table)))))
-(provide (rename-out [b-module-begin #%module-begin]))
-
-(define-macro (b-let ID VAL)
-  #'(set! ID VAL))
-
-(struct end-program-signal ())
-(struct change-line-signal (val))
+       (void (parameterize ([current-output-port
+                             (or (current-basic-port) (open-output-nowhere))])
+               (run line-table))))))
 
-(define (b-end) (raise (end-program-signal)))
-(define (b-goto num-expr) (raise (change-line-signal num-expr)))
+(begin-for-syntax
+  (require racket/list)
+  (define (find-unique-var-names stx)
+    (remove-duplicates
+     (for/list ([var-stx (in-list (syntax-flatten stx))]
+                #:when (syntax-property var-stx 'b-id))
+               var-stx)
+     #:key syntax->datum)))
 
-(define (run line-table)
-  (define line-vec
-    (list->vector (sort (hash-keys line-table) <)))
-  (with-handlers ([end-program-signal? (λ (exn-val) (void))])
-    (for/fold ([line-idx 0])
-              ([i (in-naturals)]
-               #:break (>= line-idx (vector-length line-vec)))
-      (define line-num (vector-ref line-vec line-idx))
-      (define line-func (hash-ref line-table line-num))
-      (with-handlers
-          ([change-line-signal?
-            (λ (cls)
-              (define clsv (change-line-signal-val cls))
-              (or
-               (and (exact-positive-integer? clsv)
-                    (vector-member clsv line-vec))
-               (error (format "error in line ~a: line ~a not found"
-                              line-num clsv))))])
-        (line-func)
-        (add1 line-idx)))))
 
-(define (b-rem val) (void))
-(define (b-print [val ""]) (displayln val))
-(define (b-sum . nums) (apply + nums))
-(define (b-num-expr expr)
-  (if (integer? expr) (inexact->exact expr) expr))

beautiful-racket-demo/basic-demo-2/expr.rkt

@@ -0,0 +1,9 @@
+#lang br
+(provide (matching-identifiers-out #rx"^b-" (all-defined-out)))
+
+(define (b-sum . nums) (apply + nums))
+
+(define (b-num-expr expr)
+  (if (integer? expr) (inexact->exact expr) expr))
+
+(define (b-negative num) (- num))

beautiful-racket-demo/basic-demo-2/flow.rkt

@@ -0,0 +1,56 @@
+#lang br
+(require "structs.rkt" "misc.rkt" "line.rkt")
+(provide (matching-identifiers-out #rx"^b-" (all-defined-out)))
+
+(define (b-end) (raise (end-program-signal)))
+(define (b-goto num-expr) (raise (change-line-signal num-expr)))
+
+(define gosub-ccs empty)
+
+(define (b-gosub num-expr)
+  (let/cc gosub-cc
+    (push! gosub-ccs gosub-cc)
+    (b-goto num-expr)))
+
+(define (b-return)
+  (unless (pair? gosub-ccs)
+    (raise (line-error "return without gosub")))
+  (define top-return-k (pop! gosub-ccs))
+  (top-return-k))
+
+(define (in-closed-interval? x left right)
+  (define cmp (if (< left right) <= >=))
+  (cmp left x right))
+
+(define-macro-cases b-for
+  [(_ ID START END) #'(b-for ID START END 1)]
+  [(_ ID START END STEP)
+   #'(b-let ID (let/cc top-of-loop-cc
+                 (push-thunk!
+                  (cons 'ID
+                        (λ ()
+                          (define next-val (+ ID STEP))
+                          (if (next-val . in-closed-interval? . START END)
+                              (top-of-loop-cc next-val)
+                              (remove-thunk! 'ID)))))
+                 START))])
+
+(define for-thunks (make-parameter empty))
+
+(define (push-thunk! thunk)
+  (for-thunks (cons thunk (for-thunks))))
+
+(define (remove-thunk! id-sym)
+  (for-thunks (remq (assq id-sym (for-thunks)) (for-thunks))))
+
+(define-macro (b-next ID ...) #'(do-next 'ID ...))
+
+(define (do-next [id-sym #f])
+  (when (empty? (for-thunks))
+    (raise-line-error "next without for"))
+  (define for-thunk
+    (cdr (if id-sym
+             (or (assq id-sym (for-thunks))
+                 (raise-line-error "next without for"))
+             (car (for-thunks)))))
+  (for-thunk))

beautiful-racket-demo/basic-demo-2/gosub.rkt

@@ -1,3 +0,0 @@
-#lang br
-(provide b-gosub b-return)
-

beautiful-racket-demo/basic-demo-2/lexer.rkt

@@ -9,7 +9,7 @@
    ["\n" (token 'NEWLINE lexeme)]
    [whitespace (token lexeme #:skip? #t)]
    [(from/stop-before "rem" "\n") (token 'REM lexeme)]
-   [(:or "print" "goto" "end" "+" ":" "gosub" "return" "let" "=") lexeme]
+   [(:or "print" "goto" "end" "+" ":" "gosub" "return" "let" "=" "-" "for" "to" "step" "next") lexeme]
    [(:seq (:+ alphabetic) (:* (:or alphabetic numeric))) (token 'ID (string->symbol lexeme))]
    [digits (token 'INTEGER (string->number lexeme))]
    [(:or (:seq (:? digits) "." digits)

beautiful-racket-demo/basic-demo-2/line.rkt

@@ -0,0 +1,19 @@
+#lang br
+(require "structs.rkt")
+(provide (all-defined-out))
+
+(define-macro (b-line NUM STATEMENT ...)
+  (with-pattern ([LINE-NUM (prefix-id "line-" #'NUM
+                                      #:source #'NUM)])
+    (syntax/loc caller-stx
+      (define (LINE-NUM)
+        (with-handlers ([line-error? (λ (le) (handle-line-error NUM le))])
+          (void) STATEMENT ...)))))
+
+(define (handle-line-error num le)
+  (error (format "error in line ~a: ~a" num (line-error-msg le))))
+
+(define (raise-line-error line-error-or-str)
+  (raise (if (string? line-error-or-str)
+             (line-error line-error-or-str)
+             line-error-or-str)))

beautiful-racket-demo/basic-demo-2/misc.rkt

@@ -0,0 +1,7 @@
+#lang br
+(provide (matching-identifiers-out #rx"^b-" (all-defined-out)))
+
+(define (b-rem val) (void))
+(define (b-print [val ""]) (displayln val))
+(define-macro (b-let ID VAL)
+  #'(set! ID VAL))

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

@@ -2,7 +2,8 @@
 b-program : [b-line] (/NEWLINE [b-line])*
 b-line : b-line-number [b-statement] (/":" [b-statement])*
 @b-line-number : INTEGER
-@b-statement : b-rem | b-end | b-print | b-goto | b-gosub | b-return | b-let
+@b-statement : b-rem | b-end | b-print | b-let
+             | b-goto | b-gosub | b-return | b-for | b-next
 b-rem : REM
 b-end : /"end"
 b-print : /"print" [STRING | b-num-expr]
@@ -10,8 +11,12 @@ b-goto : /"goto" b-num-expr
 b-gosub : /"gosub" b-num-expr
 b-return : /"return"
 b-let : [/"let"] b-id /"=" b-num-expr
+b-for : /"for" b-id /"=" b-num-expr /"to" b-num-expr [/"step" b-num-expr]
+b-next : /"next" [b-id]
 @b-id : ID
 b-num-expr : b-sum
-b-sum : b-value (/"+" b-value)*
+b-sum : (b-value /"+" b-value)*
 @b-value : b-id | b-number
-@b-number : INTEGER | DECIMAL
+@b-number : b-positive | b-negative
+@b-positive : INTEGER | DECIMAL
+b-negative : /"-" b-positive

beautiful-racket-demo/basic-demo-2/run.rkt

@@ -0,0 +1,24 @@
+#lang br
+(require "line.rkt" "structs.rkt")
+(provide run)
+
+(define (run line-table)
+  (define line-vec
+    (list->vector (sort (hash-keys line-table) <)))
+  (with-handlers ([end-program-signal? (λ (exn-val) (void))])
+    (for/fold ([line-idx 0])
+              ([i (in-naturals)]
+               #:break (>= line-idx (vector-length line-vec)))
+      (define line-num (vector-ref line-vec line-idx))
+      (define line-func (hash-ref line-table line-num))
+      (with-handlers
+          ([change-line-signal?
+            (λ (cls)
+              (define clsv (change-line-signal-val cls))
+              (or
+               (and (exact-positive-integer? clsv)
+                    (vector-member clsv line-vec))
+               (handle-line-error line-num
+                                  (line-error (format "line ~a not found" clsv)))))])
+        (line-func)
+        (add1 line-idx)))))

beautiful-racket-demo/basic-demo-2/runtime.rkt

@@ -0,0 +1,3 @@
+#lang br
+(provide current-basic-port)
+(define current-basic-port (make-parameter #f))

beautiful-racket-demo/basic-demo-2/sample-for.rkt

@@ -0,0 +1,8 @@
+#lang basic-demo-2
+10 for a = 1 to 3
+20 print a
+21 for b = 103 to 101 step -1
+22 print b
+23 next b
+30 next a
+40 print "yay"

beautiful-racket-demo/basic-demo-2/sample-import.rkt

@@ -0,0 +1,3 @@
+#lang br
+(require basic-demo-2/sample-var)
+(* a a)

beautiful-racket-demo/basic-demo-2/sample.rkt

@@ -0,0 +1,9 @@
+#lang basic-demo
+30 rem print 'ignored'
+35
+50 print "never gets here"
+40 end
+60 print 'three' : print 1.0 + 3
+70 goto 11. + 18.5 + .5
+10 print "one"
+20 print : goto 60.0 : end

beautiful-racket-demo/basic-demo-2/structs.rkt

@@ -0,0 +1,7 @@
+#lang br
+(provide (all-defined-out))
+
+(struct end-program-signal ())
+(struct change-line-signal (val))
+
+(struct line-error (msg))