better idea

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

@@ -1,21 +1,23 @@
 #lang br/quicklang
 
-(define-exn-srcloc duplicate-line-number exn:fail)
-
 (define-macro (b-module-begin (b-program LINE ...))
-  #'(#%module-begin
+  (with-pattern ([(LINE-NUM ...)
-     (define lines (sort (list LINE ...) #:key $line-number <))
+                  (filter-stx-prop 'b-line-number (syntax-flatten #'(LINE ...)))]
-     (unless (apply < (map $line-number lines))
+                 [(LINE-ID ...) (syntax-map (λ (stx) (prefix-id "line-" stx)) #'(LINE-NUM ...))])
-       (raise-duplicate-line-number
+    #'(#%module-begin
-        ($line-srcloc (check-duplicates lines = #:key $line-number))))
+       LINE ...
-     (run lines)))
+       (define line-table (apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
+       (run line-table))))
 (provide (rename-out [b-module-begin #%module-begin]))
 
-(struct $line (number thunk srcloc) #:transparent)
-
 (define-macro (b-line LINE-NUMBER STATEMENT)
-  (with-pattern ([CALLER-STX caller-stx])
+  (with-pattern ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER
-    #'($line LINE-NUMBER (λ () STATEMENT) (syntax-srcloc #'CALLER-STX))))
+                                            #:source #'LINE-NUMBER)]
+                 [ORIG-LOC caller-stx])
+    (syntax/loc caller-stx (define (LINE-NUMBER-ID #:srcloc? [srcloc #f])
+                             (if srcloc
+                                 (syntax-srcloc #'ORIG-LOC)
+                                 STATEMENT)))))
 
 (define (b-statement stmt) stmt)
 (define (b-rem str) #f)
@@ -29,18 +31,16 @@
 
 (define-exn-srcloc line-not-found exn:fail)
 
-(define (run lines)
+(define (run line-table)
-  (define line-vec (list->vector lines))
+  (define line-vec (list->vector (sort (hash-keys line-table) <)))
-  (define line-idx-table (for/hasheqv ([(line idx) (in-indexed line-vec)])
-                           (values ($line-number line) idx)))
   (with-handlers ([end-program-signal? void])
     (for/fold ([line-idx 0])
               ([i (in-naturals)])
       (unless (< line-idx (vector-length line-vec)) (b-end))
-      (define this-line (vector-ref line-vec line-idx))
+      (define line-num (vector-ref line-vec line-idx))
-      (define this-thunk ($line-thunk this-line))
+      (define line-proc (hash-ref line-table line-num))
-      (define this-result (this-thunk))
+      (define line-result (line-proc))
-      (if (exact-positive-integer? this-result)
+      (if (exact-positive-integer? line-result)
-          (hash-ref line-idx-table this-result
+          (or (vector-member line-result line-vec)
-                    (λ () (raise-line-not-found ($line-srcloc this-line))))
+              (raise-line-not-found (line-proc #:srcloc? #t)))
           (add1 line-idx)))))

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

@@ -0,0 +1,8 @@
+#lang br
+(provide (rename-out [my-app #%app]))
+(define-macro (my-app ID . ARGS)
+  (report caller-stx)
+  (if (number? (syntax->datum #'ID))
+      (with-pattern ([NEW-ID (report* #'ID (prefix-id "@" #'ID))])
+        #'(NEW-ID . ARGS))
+      #'(ID . ARGS)))

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

@@ -2,7 +2,9 @@
 
 b-program : b-line*
 
-b-line: NUMBER b-statement
+b-line: @b-line-number b-statement
+
+b-line-number : NUMBER
 
 b-statement: b-rem
 | b-print

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

@@ -0,0 +1,8 @@
+#lang basic-demo
+30 rem print "nope"
+40 end
+50 print "never"
+60 print "second"
+70 goto 30
+10 print "first"
+20 goto 60

beautiful-racket-lib/br/quicklang.rkt

@@ -1,7 +1,8 @@
 #lang br
 (require (for-syntax racket/list sugar/debug))
 (provide (except-out (all-from-out br) #%module-begin)
-         (rename-out [quicklang-mb #%module-begin]))
+         (rename-out [quicklang-mb #%module-begin])
+         (for-syntax (all-from-out sugar/debug)))
 
 (define-macro (quicklang-mb . EXPRS)
   (define-values

beautiful-racket-lib/br/syntax.rkt

@@ -1,14 +1,18 @@
 #lang racket/base
 (require (for-syntax racket/base racket/syntax)
          racket/list
+         racket/match
          racket/syntax
+         racket/format
+         syntax/stx
          syntax/strip-context
          br/define
          br/private/syntax-flatten)
 (provide (all-defined-out)
          syntax-flatten
          (rename-out [strip-context strip-bindings]
-                     [replace-context replace-bindings]))
+                     [replace-context replace-bindings]
+                     [stx-map syntax-map]))
 
 (module+ test
   (require rackunit))
@@ -55,45 +59,48 @@
 
 (define-macro (format-string FMT ID0 ID ...)
   #'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
+#|
+(define (format-string FMT ID0 . IDS)
+  (datum->syntax ID0 (apply format FMT (syntax->datum ID0) (map syntax->datum IDS))))
+|#
 
 
-(define-macro (->unsyntax X)
+(define (->unsyntax x)
-  #'(if (syntax? X)
+  (if (syntax? x) (syntax->datum x) x))
-        (syntax->datum X)
-        X))
 
 
-(define-macro (prefix-id PREFIX ... BASE-OR-BASES)
+(define (fix-base loc-arg prefixes base-or-bases suffixes)
-  #'(let* ([bobs BASE-OR-BASES]
+  (define single-mode? (and (not (list? base-or-bases)) (not (syntax->list base-or-bases))))
-           [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
+  (define bases (if single-mode? (list base-or-bases) (or (syntax->list base-or-bases) base-or-bases)))
-           [bases (if got-single?
+  (define (stx-join stxs) (apply string-append (map (compose1 ~a ->unsyntax) stxs)))
-                      (list bobs)
+  (define result (map (λ (base) (format-id base "~a~a~a" (stx-join prefixes) (syntax-e base) (stx-join suffixes)
-                      bobs)]
+                                           #:source loc-arg)) bases))
-           [result (syntax-case-map
+  (if single-mode? (car result) result))
-                    bases ()
-                    [base (format-id #'base "~a~a"
-                                     (string-append (format "~a" (->unsyntax PREFIX)) ...)
-                                     (syntax-e #'base))])])
-      (if got-single? (car result) result)))
 
 
-(define-macro (infix-id PREFIX BASE-OR-BASES SUFFIX ...)
+(define (prefix-id #:source [loc-arg #f] . args)
-  #'(let* ([bobs BASE-OR-BASES]
+  ((match-lambda
-           [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
+     [(list prefixes ... base-or-bases)
-           [bases (if got-single?
+      (fix-base loc-arg prefixes base-or-bases empty)]) args))
-                      (list bobs)
-                      bobs)]
-           [result (syntax-case-map
-                    bases ()
-                    [base (format-id #'base "~a~a~a"
-                                     (->unsyntax PREFIX)
-                                     (syntax-e #'base)
-                                     (string-append (format "~a" (->unsyntax SUFFIX)) ...))])])
-      (if got-single? (car result) result)))
 
+(define (infix-id #:source [loc-arg #f] . args)
+  ((match-lambda
+     [(list prefix base-or-bases suffixes ...)
+      (fix-base loc-arg (list prefix) base-or-bases suffixes)]) args))
 
-(define-macro (suffix-id BASE-OR-BASES SUFFIX ...)
+(define (suffix-id #:source [loc-arg #f] . args)
-  #'(infix-id "" BASE-OR-BASES SUFFIX ...))
+  ((match-lambda
+     [(list base-or-bases suffixes ...)
+      (fix-base loc-arg empty base-or-bases suffixes)]) args))
+
+(module+ test
+  (define-check (check-stx-equal? stx1 stx2)
+    (define stxs (list stx1 stx2))
+    (apply equal? (map syntax->datum stxs))) 
+  (check-stx-equal? (prefix-id "foo" "bar" #'id) #'foobarid)
+  (check-stx-equal? (infix-id "foo" #'id "bar" "zam") #'fooidbarzam)
+  (check-stx-equal? (suffix-id #'id "foo" "bar" "zam") #'idfoobarzam)
+  (for-each check-stx-equal? (suffix-id #'(this that) "@") (list #'this@ #'that@)))
 
 
 (define-macro-cases syntax-property*
@@ -110,6 +117,23 @@
   [(_ STX ['PROP0 VAL0 . PRESERVED0] ['PROP VAL . PRESERVED] ...) ; write multiple
    #'(syntax-property* (syntax-property STX 'PROP0 VAL0 . PRESERVED0) ['PROP VAL . PRESERVED] ...)])
 
+#|
+(define (syntax-property* . args)
+  ((match-lambda*
+     [(list x) x]
+     [(list stx (list prop val others ...)) ; write one
+      (apply syntax-property stx prop val others)]
+     [(list stx (list prop val others ...) args ...) ; write multiple
+      #'(apply syntax-property* (apply syntax-property stx prop val others) args)]
+     [(list stx prop) ; read one
+      (syntax-property stx prop)]
+     [(list stx prop0 props ...) ; read multiple
+      (map (λ (prop) (syntax-property stx prop)) (cons prop0 props))]
+     [else 'huh]) args))
+|#
+
+(define (filter-stx-prop prop stxs)
+  (filter (λ (stx) (syntax-property stx prop)) stxs))
 
 (module+ test
   (define x (syntax-property* #'foo ['bar #t] ['zam 'boni]))