start demo 3

beautiful-racket-demo/basic-demo-3/colorer.rkt

@@ -1,22 +1,32 @@
 #lang br
 (require "lexer.rkt" brag/support)
-(provide color-basic)
+(provide basic-colorer)
 
-(define (color-basic port)
+(define (basic-colorer port)
-  (define srcloc-tok (basic-lexer port))
+  (define (handle-lexer-error excn)
+    (define excn-srclocs (exn:fail:read-srclocs excn))
+    (srcloc-token (token 'ERROR) (car excn-srclocs)))
+  (define srcloc-tok
+    (with-handlers ([exn:fail:read? handle-lexer-error])
+      (basic-lexer port)))
   (match srcloc-tok
     [(? eof-object?) (values srcloc-tok 'eof #f #f #f)]
-    [else ; reverse-engineer with `match-define`
+    [else
-     (match-define (srcloc-token (token-struct type val _ _ _ _ _)
+     (match-define
-                                 (srcloc _ _ _ pos span)) srcloc-tok)
+       (srcloc-token
-     (define (color cat [paren #f])
+        (token-struct type val _ _ _ _ _)
-       (values (or val "") cat paren pos (+ pos span)))
+        (srcloc _ _ _ posn span)) srcloc-tok)
+     (define start posn)
+     (define end (+ start span))
+     (match-define (list cat paren)
        (match type
-       ['STRING (color 'string)]
+         ['STRING '(string #f)]
-       ['REM (color 'comment)]
+         ['REM '(comment #f)]
+         ['ERROR '(error #f)]
          [else (match val
-               [(? number?) (color 'constant)]
+                 [(? number?)'(constant #f)]
-               [(? symbol?) (color 'symbol)]
+                 [(? symbol?) '(symbol #f)]
-               ["(" (color 'parenthesis '|(|)]
+                 ["(" '(parenthesis |(|)]
-               [")" (color 'parenthesis '|)|)]
+                 [")" '(parenthesis |)|)]
-               [else (color 'no-color)])])]))
+                 [else '(no-color #f)])]))
+     (values val cat paren start end)]))

beautiful-racket-demo/basic-demo-3/cond.rkt

@@ -0,0 +1,41 @@
+#lang br
+(require "go.rkt")
+(provide b-if b-or-expr b-and-expr b-not-expr b-comp-expr)
+
+(define (bool->int val) (if val 1 0))
+(define nonzero? (compose1 not zero?))
+
+(define-macro-cases b-or-expr
+  [(_ VAL) #'VAL]
+  [(_ LEFT "or" RIGHT)
+   #'(bool->int (or (nonzero? LEFT) (nonzero? RIGHT)))])
+
+(define-macro-cases b-and-expr
+  [(_ VAL) #'VAL]
+  [(_ LEFT "and" RIGHT)
+   #'(bool->int (and (nonzero? LEFT) (nonzero? RIGHT)))])
+
+(define-macro-cases b-not-expr
+  [(_ VAL) #'VAL]
+  [(_ "not" VAL) #'(if (nonzero? VAL) 0 1)])
+
+(define b= (compose1 bool->int =))
+(define b< (compose1 bool->int <))
+(define b> (compose1 bool->int >))
+(define b<> (compose1 bool->int not =))
+
+(define-macro-cases b-comp-expr
+  [(_ VAL) #'VAL]
+  [(_ LEFT "=" RIGHT) #'(b= LEFT RIGHT)]
+  [(_ LEFT "<" RIGHT) #'(b< LEFT RIGHT)]
+  [(_ LEFT ">" RIGHT) #'(b> LEFT RIGHT)]
+  [(_ LEFT "<>" RIGHT) #'(b<> LEFT RIGHT)])
+
+(define-macro-cases b-if
+  [(_ COND-EXPR THEN-EXPR) #'(b-if COND-EXPR THEN-EXPR (void))]
+  [(_ COND-EXPR THEN-EXPR ELSE-EXPR)
+   #'(let ([result (if (nonzero? COND-EXPR)
+                       THEN-EXPR
+                       ELSE-EXPR)])
+       (when (exact-positive-integer? result)
+         (b-goto result)))])

beautiful-racket-demo/basic-demo-3/elements.rkt

@@ -1,3 +1,6 @@
 #lang br
-(require "line.rkt" "go.rkt" "if.rkt" "expr.rkt" "for.rkt" "misc.rkt")
+(require "line.rkt" "go.rkt"
-(provide (all-from-out "line.rkt" "go.rkt" "if.rkt" "expr.rkt" "for.rkt" "misc.rkt"))
+         "expr.rkt" "misc.rkt" "cond.rkt")
+(provide
+ (all-from-out "line.rkt" "go.rkt"
+               "expr.rkt" "misc.rkt" "cond.rkt"))

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

@@ -1,7 +1,5 @@
 #lang br/quicklang
-(require "runtime.rkt"
+(require "struct.rkt" "run.rkt" "elements.rkt")
-         "run.rkt"
-         "elements.rkt")
 (provide (rename-out [b-module-begin #%module-begin])
          (all-from-out "elements.rkt"))
 
@@ -9,27 +7,26 @@
   (with-pattern
       ([((b-line NUM STMT ...) ...) #'(LINE ...)]
        [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))]
-       [(VAR-NAME ...) (find-unique-var-names #'(LINE ...))])
+       [(VAR-ID ...) (find-unique-var-ids #'(LINE ...))])
     #'(#%module-begin
        (module configure-runtime br
-         (require basic-demo-2/runtime)
+         (require basic-demo-3/runtime)
          (current-basic-port (current-output-port)))
-       (define VAR-NAME 0) ...
+       (define VAR-ID 0) ...
-       (provide VAR-NAME ...)
+       (provide VAR-ID ...)
        LINE ...
        (define line-table
          (apply hasheqv (append (list NUM LINE-FUNC) ...)))
        (void (parameterize ([current-output-port
                              (or (current-basic-port) (open-output-nowhere))])
-               (run line-table))))))
+               (void (run line-table)))))))
 
 (begin-for-syntax
   (require racket/list)
-  (define (find-unique-var-names stx)
+  (define (find-unique-var-ids line-stxs)
     (remove-duplicates
-     (for/list ([var-stx (in-list (syntax-flatten stx))]
+     (for/list ([stx (in-list (stx-flatten line-stxs))]
-                #:when (syntax-property var-stx 'b-id))
+                #:when (syntax-property stx 'b-id))
-               var-stx)
+       stx)
      #:key syntax->datum)))
 
-

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

@@ -1,26 +1,24 @@
 #lang br
-(provide (all-defined-out))
+(provide b-expr b-sum b-product b-neg b-expt)
+
+(define (b-expr expr)
+  (if (integer? expr) (inexact->exact expr) expr))
 
-;; b-sum : b-product (("+" | "-")  b-product)*
 (define-macro-cases b-sum
-  [(_ PROD) #'PROD]
+  [(_ VAL) #'VAL]
-  [(_ LEFT-PROD "+" RIGHT-PROD) #'(+ LEFT-PROD RIGHT-PROD)]
+  [(_ LEFT "+" RIGHT) #'(+ LEFT RIGHT)]
-  [(_ LEFT-PROD "-" RIGHT-PROD) #'(- LEFT-PROD RIGHT-PROD)])
+  [(_ LEFT "-" RIGHT) #'(- LEFT RIGHT)])
 
-;; b-product : [b-product ("*"|"/"|"%"|"^")] b-value
 (define-macro-cases b-product
   [(_ VAL) #'VAL]
   [(_ LEFT "*" RIGHT) #'(* LEFT RIGHT)]
   [(_ LEFT "/" RIGHT) #'(/ LEFT RIGHT 1.0)]
-  [(_ LEFT "^" RIGHT) #'(expt LEFT RIGHT)]
+  [(_ LEFT "mod" RIGHT) #'(modulo LEFT RIGHT)])
-  [(_ LEFT "%" RIGHT) #'(modulo LEFT RIGHT)])
-
-(define (b-expr expr)
-  (if (integer? expr) (inexact->exact expr) expr))
-
-(define (b-negative num) (- num))
 
-(define (b-not expr) (if (zero? expr) 1 0))
+(define-macro-cases b-neg
+  [(_ VAL) #'VAL]
+  [(_ "-" VAL) #'(- VAL)])
 
-(define-macro (b-def ID VAR EXPR)
+(define-macro-cases b-expt
-  #'(set! ID (λ (VAR) EXPR)))
+  [(_ VAL) #'VAL]
+  [(_ LEFT "^" RIGHT) #'(expt LEFT RIGHT)])

beautiful-racket-demo/basic-demo-3/go.rkt

@@ -1,19 +1,52 @@
 #lang br
-(require "structs.rkt" "line.rkt")
+(require "struct.rkt" "line.rkt" "misc.rkt")
-(provide b-goto b-gosub b-return)
+(provide b-end b-goto b-gosub b-return b-for b-next)
+
+(define (b-end) (raise (end-program-signal)))
 
 (define (b-goto num-expr)
   (raise (change-line-signal num-expr)))
 
-(define return-stack empty)
+(define return-ccs empty)
 
 (define (b-gosub num-expr)
-  (let/cc return-cc
+  (let/cc this-cc
-    (push! return-stack return-cc)
+    (push! return-ccs this-cc)
     (b-goto num-expr)))
 
 (define (b-return)
-  (unless (pair? return-stack)
+  (unless (not (empty? return-ccs))
     (raise-line-error "return without gosub"))
-  (define top-return-k (pop! return-stack))
+  (define top-cc (pop! return-ccs))
-  (top-return-k))
+  (top-cc (void)))
+
+(define next-funcs (make-hasheq))
+
+(define-macro-cases b-for
+  [(_ LOOP-ID START END) #'(b-for LOOP-ID START END 1)]
+  [(_ LOOP-ID START END STEP)
+   #'(b-let LOOP-ID
+            (let/cc loop-cc
+              (hash-set! next-funcs
+                         'LOOP-ID
+                         (λ ()
+                           (define next-val
+                             (+ LOOP-ID STEP))
+                           (if (next-val
+                                . in-closed-interval? .
+                                START END)
+                               (loop-cc next-val)
+                               (hash-remove! next-funcs
+                                             'LOOP-ID))))
+              START))])
+
+(define (in-closed-interval? x start end)
+  ((if (< start end) <= >=) start x end))
+
+(define-macro (b-next LOOP-ID)
+  #'(begin
+      (unless (hash-has-key? next-funcs 'LOOP-ID)
+        (raise-line-error
+         (format "`next ~a` without for" 'LOOP-ID)))
+      (define func (hash-ref next-funcs 'LOOP-ID))
+      (func)))

beautiful-racket-demo/basic-demo-3/if.rkt

@@ -1,27 +0,0 @@
-#lang br
-(require "go.rkt")
-(provide b-if b-comp-expr b-logic-expr)
-
-;; b-if : /"if" b-expr /"then" b-expr [/"else" b-expr]
-(define (b-if cond-expr then-expr [else-expr #f])
-  (cond
-    [(not (zero? cond-expr)) (b-goto then-expr)]
-    [else-expr => b-goto]))
-
-(define bool-int (λ (val) (if val 1 0)))
-(define bi= (compose1 bool-int =))
-(define bi< (compose1 bool-int <))
-(define bi> (compose1 bool-int >))
-
-;; b-comp-expr : b-cond-expr [("and" | "or") b-cond-expr]
-(define-macro-cases b-logic-expr
-  [(_ ARG) #'ARG]
-  [(_ LEFT "and" RIGHT) #'(and LEFT RIGHT)]
-  [(_ LEFT "or" RIGHT) #'(or LEFT RIGHT)])
-
-;; b-cond-expr : b-expr [("=" | "<" | ">") b-expr]
-(define-macro-cases b-comp-expr
-  [(_ ARG) #'ARG]
-  [(_ LEFT "=" RIGHT) #'(bi= LEFT RIGHT)]
-  [(_ LEFT "<" RIGHT) #'(bi< LEFT RIGHT)]
-  [(_ LEFT ">" RIGHT) #'(bi> LEFT RIGHT)])

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

@@ -3,15 +3,17 @@
 
 (define-lex-abbrev digits (:+ (char-set "0123456789")))
 
+(define-lex-abbrev reserved-terms (:or "print" "goto" "end" "+" ":" ";" "let" "=" "input" "-" "*" "/" "^" "mod" "(" ")" "def" "if" "then" "else" "<" ">" "<>" "and" "or" "not" "gosub" "return" "for" "to" "step" "next"))
+
 (define basic-lexer
   (lexer-srcloc
    [(eof) (return-without-srcloc eof)]
    ["\n" (token 'NEWLINE lexeme)]
    [whitespace (token lexeme #:skip? #t)]
    [(from/stop-before "rem" "\n") (token 'REM lexeme)]
-   [(:or "print" "goto" "end" "+" ":" "gosub" "return" "let" "=" "-" "for" "to" "step" "next"
+   [reserved-terms (token lexeme lexeme)]
-         "if" "then" "else" "and" "or" "<" ">" "*" "/" "(" ")" "^" "!" "%" "input" ";" "def") (token lexeme lexeme)]
+   [(:seq alphabetic (:* (:or alphabetic numeric "$")))
-   [(:seq (:+ alphabetic) (:* (:or alphabetic numeric "$"))) (token 'ID (string->symbol lexeme))]
+    (token 'ID (string->symbol lexeme))]
    [digits (token 'INTEGER (string->number lexeme))]
    [(:or (:seq (:? digits) "." digits)
          (:seq digits "."))

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

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

beautiful-racket-demo/basic-demo-3/main.rkt

@@ -7,13 +7,13 @@
 (define (read-syntax path port)
   (define parse-tree (parse path (make-tokenizer port path)))
   (strip-bindings
-   #`(module basic-mod basic-demo-2/expander
+   #`(module basic-mod basic-demo-3/expander
        #,parse-tree)))
 
 (define (get-info port mod line col pos)
     (define (handle-query key default)
       (case key
         [(color-lexer)
-         (dynamic-require 'basic-demo-2/colorer 'color-basic)]
+         (dynamic-require 'basic-demo-3/colorer 'basic-colorer)]
         [else default]))
     handle-query)

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

@@ -1,6 +1,6 @@
 #lang br
-(require "structs.rkt")
+(require "struct.rkt")
-(provide (all-defined-out))
+(provide b-rem b-print b-let b-input)
 
 (define (b-rem val) (void))
 
@@ -13,5 +13,3 @@
   #'(b-let ID (let* ([str (read-line)]
                      [num (string->number (string-trim str))])
                 (or num str))))
-
-(define (b-end) (raise (end-program-signal)))

beautiful-racket-demo/basic-demo-3/parse-only.rkt

@@ -0,0 +1,14 @@
+#lang br/quicklang
+(require "parser.rkt" "tokenizer.rkt")
+
+(define (read-syntax path port)
+  (define parse-tree (parse path (make-tokenizer port path)))
+  (strip-bindings
+   #`(module basic-parser-mod basic-demo-3/parse-only
+       #,parse-tree)))
+(module+ reader (provide read-syntax))
+
+(define-macro (parser-only-mb PARSE-TREE)
+  #'(#%module-begin
+     'PARSE-TREE))
+(provide (rename-out [parser-only-mb #%module-begin]))

beautiful-racket-demo/basic-demo-3/parse-stx.rkt

@@ -0,0 +1,15 @@
+#lang br/quicklang
+(require "parser.rkt" "tokenizer.rkt")
+
+(define (read-syntax path port)
+  (define parse-tree (parse path (make-tokenizer port path)))
+  (strip-bindings
+   #`(module basic-parser-mod basic-demo-3/parse-stx
+       #'#,parse-tree)))
+(module+ reader (provide read-syntax))
+
+(define-macro (parser-only-mb PARSE-STX)
+  #'(#%module-begin
+     PARSE-STX))
+(provide (rename-out [parser-only-mb #%module-begin]))
+(provide syntax)

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

@@ -1,37 +1,33 @@
 #lang brag
 ;; program & lines
 b-program : [b-line] (/NEWLINE [b-line])*
-b-line : b-line-num [b-statement] (/":" [b-statement])*
+b-line : b-line-num [b-statement] (/":" [b-statement])* [b-rem]
 @b-line-num : INTEGER
-
-;; statements
-@b-statement : b-rem | b-end | b-print | b-let | b-input | b-def
-             | b-goto | b-gosub | b-return | b-for | b-next | b-if
 b-rem : REM
+@b-statement : b-end | b-print | b-goto
+             | b-let | b-input | b-if
+             | b-gosub | b-return | b-for | b-next
 b-end : /"end"
-b-print : /"print" [STRING | b-expr] (/";" [STRING | b-expr])*
+b-print : /"print" [b-printable] (/";" [b-printable])*
+@b-printable : STRING | b-expr
 b-goto : /"goto" b-expr
-b-if : /"if" b-expr /"then" b-expr [/"else" b-expr]
+b-let : [/"let"] b-id /"=" (STRING | b-expr)
+b-if : /"if" b-expr /"then" (b-statement | b-expr)
+                   [/"else" (b-statement | b-expr)]
+b-input : /"input" b-id
+@b-id : ID
 b-gosub : /"gosub" b-expr
 b-return : /"return"
-b-input : /"input" b-id
-b-def :  /"def" b-id /"(" b-id /")" /"=" b-expr
-b-let : [/"let"] b-id /"=" [STRING | b-expr]
 b-for : /"for" b-id /"=" b-expr /"to" b-expr [/"step" b-expr]
-b-next : /"next" [b-id]
+b-next : /"next" b-id
-
+b-expr : b-or-expr
-;; expressions with precedence & order
+b-or-expr : [b-or-expr "or"] b-and-expr
-b-expr : b-logic-expr 
+b-and-expr : [b-and-expr "and"] b-not-expr
-b-logic-expr : [b-logic-expr ("and" | "or")] b-comp-expr
+b-not-expr : ["not"] b-comp-expr
-b-comp-expr : [b-comp-expr ("=" | "<" | ">")] b-sum
+b-comp-expr : [b-comp-expr ("="|"<"|">"|"<>")] b-sum
 b-sum : [b-sum ("+"|"-")] b-product
-b-product : [b-product ("*"|"/"|"%"|"^")] b-value
+b-product : [b-product ("*"|"/"|"mod")] b-neg
-
+b-neg : ["-"] b-expt
-;; values
+b-expt : [b-expt ("^")] b-value
-@b-value : b-id | b-number | /"(" b-expr /")" | b-not | b-func
+@b-value : b-number | b-id | /"(" b-expr /")"
-/b-func : b-id /"(" b-expr /")"
+@b-number : INTEGER | DECIMAL
-b-not : /"!" b-value
-@b-id : ID
-@b-number : b-positive | b-negative
-@b-positive : INTEGER | DECIMAL
-b-negative : /"-" b-positive

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

@@ -1,5 +1,5 @@
 #lang br
-(require "line.rkt" "structs.rkt")
+(require "line.rkt" "struct.rkt")
 (provide run)
 
 (define (run line-table)

beautiful-racket-demo/basic-demo-3/sample-cond.rkt

@@ -1,4 +1,4 @@
-#lang basic-demo-2
+#lang basic-demo-3
 10 rem all results should be 1
 20 a = 5
 30 b = 10

beautiful-racket-demo/basic-demo-3/sample-def.rkt

@@ -1,4 +1,4 @@
-#lang basic-demo-2
+#lang basic-demo-3
 10 rem all results should be 1
 20 def f(x) = x * x
 30 print f((1+2)*3) = 81

beautiful-racket-demo/basic-demo-3/sample-export.rkt

@@ -1,4 +1,4 @@
-#lang basic-demo-2
+#lang basic-demo-3
 10 a = 1 : a = 5
 20 gosub 150
 30 a = 25

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

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

beautiful-racket-demo/basic-demo-3/sample-gosub.rkt

@@ -1,4 +1,4 @@
-#lang basic-demo-2
+#lang basic-demo-3
 10 gosub 41
 20 print "world"
 30 gosub 100

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

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

beautiful-racket-demo/basic-demo-3/sample-input.rkt

@@ -1,4 +1,4 @@
-#lang basic-demo-2
+#lang basic-demo-3
 5 print "enter your name: "
 10 input A$
 20 print "hello, " ; A$ ; "!"

beautiful-racket-demo/basic-demo-3/sample-math.rkt

@@ -1,9 +1,9 @@
-#lang basic-demo-2
+#lang basic-demo-3
 10 rem all results should be 1
 20 print 1 - 2 * 3 + 4 * 5 - 6 = 9
 30 print (1 - 2) * (3 + 4) * (5 - 6) = 7
 40 print 1 / 4 = .25
 50 print 2 ^ 3 = 8
 60 print 9 ^ 0.5 = 3
-70 print 6 % 2 = 0
+70 print 6 mod 2 = 0
-80 print 5 % 2 = 1
+80 print 5 mod 2 = 1

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

@@ -1,9 +1,9 @@
-#lang basic-demo
+#lang basic-demo-3
 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
+70 goto 11. + 18.5 + .5 rem ignored
-10 print "one"
+10 print "o" ; "n" ; "e"
 20 print : goto 60.0 : end

beautiful-racket-demo/basic-demo-3/struct.rkt

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