rearrangements

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

@@ -1,35 +1,22 @@
 #lang br/quicklang
-(provide (rename-out [b-module-begin #%module-begin])
-         (matching-identifiers-out #rx"^b-" (all-defined-out)))
+(provide (matching-identifiers-out #rx"^b-" (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) (void) STATEMENT ...))))
 
 (define-macro (b-module-begin (b-program LINE ...))
   (with-pattern
-      ([(LINE-NUM ...)
-        (filter-stx-prop 'b-line-number
-                         (stx-flatten #'(LINE ...)))]
-       [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))])
+      ([((NAME NUM STMT ...) ...) #'(LINE ...)]
+       [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))])
     #'(#%module-begin
        LINE ...
        (define line-table
-         (apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
+         (apply hasheqv (append (list NUM LINE-FUNC) ...)))
        (run line-table))))
-
-(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? [loc #f])
-        (if loc
-            (syntax-srcloc #'ORIG-LOC)
-            (begin (void) STATEMENT ...))))))
-
-(define b-rem 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))
+(provide (rename-out [b-module-begin #%module-begin]))
 
 (struct $program-end-signal ())
 (define (b-end) (raise ($program-end-signal)))
@@ -37,8 +24,6 @@
 (struct $change-line-signal (val))
 (define (b-goto expr) (raise ($change-line-signal expr)))
 
-(define-exn line-not-found exn:fail)
-
 (define (run line-table)
   (define line-vec
     (list->vector (sort (hash-keys line-table) <)))
@@ -55,7 +40,13 @@
               (or
                (and (exact-positive-integer? clsv)
                     (vector-member clsv line-vec))
-               (raise-line-not-found
-                (line-proc #:srcloc? #t))))])
+               (error (format "error in line ~a: line ~a not found"
+                              line-num clsv))))])
         (line-proc)
         (add1 line-idx)))))
+
+(define b-rem 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/expander0.rkt

@@ -0,0 +1,61 @@
+#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
+                         (stx-flatten #'(LINE ...)))]
+       [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))])
+    #'(#%module-begin
+       LINE ...
+       (define line-table
+         (apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
+       (run line-table))))
+
+(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? [loc #f])
+        (if loc
+            (syntax-srcloc #'ORIG-LOC)
+            (begin (void) STATEMENT ...))))))
+
+(define b-rem 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))
+
+(struct $program-end-signal ())
+(define (b-end) (raise ($program-end-signal)))
+
+(struct $change-line-signal (val))
+(define (b-goto expr) (raise ($change-line-signal expr)))
+
+(define-exn line-not-found exn:fail)
+
+(define (run line-table)
+  (define line-vec
+    (list->vector (sort (hash-keys line-table) <)))
+  (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))
+      (with-handlers
+          ([$change-line-signal?
+            (λ (cls)
+              (define clsv ($change-line-signal-val cls))
+              (or
+               (and (exact-positive-integer? clsv)
+                    (vector-member clsv line-vec))
+               (raise-line-not-found
+                (line-proc #:srcloc? #t))))])
+        (line-proc)
+        (add1 line-idx)))))

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

@@ -1,10 +1,11 @@
 #lang br/quicklang
 (require "parser.rkt" "tokenizer.rkt")
 
-(module+ reader (provide read-syntax))
-
 (define (read-syntax path port)
   (define parse-tree (parse path (make-tokenizer port path)))
   (strip-bindings
    #`(module basic-mod basic-demo/expander
-       #,parse-tree)))
+       #,parse-tree)))
+
+(module+ reader
+  (provide read-syntax))

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

@@ -0,0 +1,8 @@
+(define (30) (rem print "'ignored'"))
+(define (35) (void))
+(define (50) (print "never gets here"))
+(define (40) (end))
+(define (60) (print "three") (print (+ 1.0 3)))
+(define (70) (goto (+ 11 18.5 0.5)))
+(define (10) (print "one"))
+(define (20) (print) (goto 60) (end))