the tightening

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

@@ -1,46 +1,54 @@
 #lang br/quicklang
+(provide (rename-out [b-module-begin #%module-begin])
+         (matching-identifiers-out #rx"^b-" (all-defined-out)))
 
 (define-macro (b-module-begin (b-program LINE ...))
   (with-pattern ([(LINE-NUM ...)
-                  (filter-stx-prop 'b-line-number (syntax-flatten #'(LINE ...)))]
+                  (filter-stx-prop 'b-line-number (stx-flatten #'(LINE ...)))]
-                 [(LINE-ID ...) (syntax-map (λ (stx) (prefix-id "line-" stx)) #'(LINE-NUM ...))])
+                 [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))])
     #'(#%module-begin
        LINE ...
-       (define line-table (apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
+       (define line-table
+         (apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
        (run line-table))))
-(provide (rename-out [b-module-begin #%module-begin]))
 
-(define-macro (b-line LINE-NUMBER STATEMENT)
+(define-macro (b-line LINE-NUMBER STATEMENT ...)
   (with-pattern ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER
                                             #:source #'LINE-NUMBER)]
                  [ORIG-LOC caller-stx])
-    (syntax/loc caller-stx (define (LINE-NUMBER-ID #:srcloc? [srcloc #f])
+    (syntax/loc caller-stx
-                             (if srcloc
+      (define (LINE-NUMBER-ID #:srcloc? [srcloc #f])
-                                 (syntax-srcloc #'ORIG-LOC)
+        (if srcloc
-                                 STATEMENT)))))
+            (syntax-srcloc #'ORIG-LOC)
+            (begin STATEMENT ...))))))
 
-(define (b-statement stmt) stmt)
+(define b-rem void)
-(define (b-rem str) #f)
+(define (b-print [val ""]) (displayln val))
-(define (b-print str) (displayln str))
+(define (b-sum . nums) (apply + nums))
-(define (b-goto line-number) line-number)
+(define (b-expr expr)
+  (if (integer? expr) (inexact->exact expr) expr))
 
-(define-exn end-program-signal exn:fail)
+(struct $program-end-signal ())
-(define (b-end) (raise-end-program-signal))
+(define (b-end) (raise ($program-end-signal)))
 
-(provide b-line b-statement b-rem b-print b-goto b-end)
+(struct $change-line-signal (num))
+(define (b-goto expr) (raise ($change-line-signal expr)))
 
-(define-exn-srcloc line-not-found exn:fail)
+(define-exn line-not-found exn:fail)
 
 (define (run line-table)
   (define line-vec (list->vector (sort (hash-keys line-table) <)))
-  (with-handlers ([end-program-signal? void])
+  (with-handlers ([$program-end-signal? void])
     (for/fold ([line-idx 0])
               ([i (in-naturals)])
       (unless (< line-idx (vector-length line-vec)) (b-end))
       (define line-num (vector-ref line-vec line-idx))
       (define line-proc (hash-ref line-table line-num))
-      (define line-result (line-proc))
+      (with-handlers ([$change-line-signal?
-      (if (exact-positive-integer? line-result)
+                       (λ (cls)
-          (or (vector-member line-result line-vec)
+                         (or
-              (raise-line-not-found (line-proc #:srcloc? #t)))
+                          (and (exact-positive-integer? ($change-line-signal-num cls))
-          (add1 line-idx)))))
+                               (vector-member ($change-line-signal-num cls) line-vec))
+                          (raise-line-not-found (line-proc #:srcloc? #t))))])
+        (line-proc)
+        (add1 line-idx)))))

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

@@ -1,5 +1,5 @@
 #lang br/quicklang
-(require "parser.rkt" "tokenizer.rkt")
+(require "parser.rkt" "tokenizer.rkt" brag/support)
 
 (module+ reader (provide read-syntax))
 
@@ -8,7 +8,8 @@
   (define port+newline (input-port-append #f port (open-input-string "\n")))
   (port-count-lines! port+newline)
   (set-port-next-location! port+newline line col pos)
-  (define parse-tree (parse path (tokenize port+newline)))
+  (with-handlers ([exn:fail:parsing? (λ (exn) (displayln "Sorry!") (raise exn))])
-  (strip-bindings
+    (define parse-tree (parse path (make-tokenizer port+newline)))
-   #`(module basic-mod basic-demo/expander
+    (strip-bindings
-       #,parse-tree)))
+     #`(module basic-mod basic-demo/expander
+         #,parse-tree))))

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

@@ -1,20 +1,15 @@
 #lang brag
-
 b-program : b-line*
-
+b-line : @b-line-number b-statement (/":" b-statement)*
-b-line: @b-line-number b-statement
+b-line-number : INTEGER
-
+@b-statement : b-rem
-b-line-number : NUMBER
+            | b-print
-
+            | b-goto
-b-statement: b-rem
+            | b-end
-| b-print
-| b-goto
-| b-end
-
 b-rem : REM
-
+b-print : /"print" (STRING | b-expr)*
-b-print : /"print" STRING
+b-goto : /"goto" b-expr
-
+b-expr : b-sum
-b-goto : /"goto" NUMBER
+b-sum : (b-number /"+")* b-number
-
+@b-number : INTEGER | DECIMAL
 b-end : /"end"

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

@@ -1,8 +1,8 @@
 #lang basic-demo
-30 rem print "nope"
+30 rem print "statement ignored"
 40 end
-50 print "never"
+50 print "never gets here"
-60 print "second"
+60 print "two" : print 1.2 + 1.8
-70 goto 30
+70 goto 11 + 10.5 + 8.5
-10 print "first"
+10 print "one"
-20 goto 60
+20 print : goto 60 : end

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

@@ -6,12 +6,15 @@
   (lexer-srcloc
    [(eof) eof]
    [whitespace (token lexeme #:skip? #t)]
-   [(from/to "rem" "\n") (token 'REM (string-downcase lexeme))]
+   [(from/to "rem" "\n") (token 'REM lexeme)]
-   [(:or "print" "goto" "end") (token (string-downcase lexeme)
+   [(:or "print" "goto" "end" "+" ":") lexeme]
-                                      (string-downcase lexeme))]
+   [(:+ numeric) (token 'INTEGER (string->number lexeme))]
-   [(:+ numeric) (token 'NUMBER (string->number lexeme))]
+   [(:or (:seq (:+ numeric) ".")
+         (:seq (:* numeric) "." (:+ numeric)))
+    (token 'DECIMAL (string->number lexeme))]
    [(from/to "\"" "\"") (token 'STRING (trim-ends  "\"" lexeme "\""))]))
 
-(define (tokenize ip)
+(define (make-tokenizer ip)
   (port-count-lines! ip)
-  (λ () (basic-lexer ip)))
+  (define (next-token) (basic-lexer ip))
+  next-token)

beautiful-racket-lib/br/exception.rkt

@@ -3,13 +3,6 @@
 (provide (all-defined-out))
 
 (define-macro (define-exn EXN-ID BASE-EXN)
-  (with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
-    #'(begin
-        (struct EXN-ID BASE-EXN () #:transparent)
-        (define (RAISE-EXN-ID)
-          (raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks)))))))
-
-(define-macro (define-exn-srcloc EXN-ID BASE-EXN)
   (with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
     #'(begin
         (define-struct (EXN-ID BASE-EXN)

beautiful-racket-lib/br/main.rkt

@@ -1,9 +1,9 @@
 #lang racket/base
-(require racket/provide racket/list racket/string racket/format racket/match racket/port  racket/function
+(require racket/provide racket/list racket/string racket/format racket/match racket/port  racket/function racket/provide
          br/define br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/reader-utils
          (for-syntax racket/base racket/syntax br/syntax br/debug br/define br/datum))
 (provide (all-from-out racket/base)
-         (all-from-out racket/list racket/string racket/format racket/match racket/port racket/function
+         (all-from-out racket/list racket/string racket/format racket/match racket/port racket/function racket/provide
                        br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/define br/reader-utils)
          (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug br/datum))
          (for-syntax caller-stx with-shared-id)) ; from br/define

beautiful-racket-lib/br/syntax.rkt

@@ -10,9 +10,14 @@
          br/private/syntax-flatten)
 (provide (all-defined-out)
          syntax-flatten
+         stx-map
          (rename-out [strip-context strip-bindings]
                      [replace-context replace-bindings]
-                     [stx-map syntax-map]))
+                     [stx-map syntax-map]
+                     [syntax-flatten stx-flatten]
+                     [prefix-id prefix-ids]
+                     [suffix-id suffix-ids]
+                     [infix-id infix-ids]))
 
 (module+ test
   (require rackunit))