diff --git a/beautiful-racket-demo/basic-demo/expander.rkt b/beautiful-racket-demo/basic-demo/expander.rkt index d7f466f..f9175ac 100644 --- a/beautiful-racket-demo/basic-demo/expander.rkt +++ b/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 - (define lines (sort (list LINE ...) #:key $line-number <)) - (unless (apply < (map $line-number lines)) - (raise-duplicate-line-number - ($line-srcloc (check-duplicates lines = #:key $line-number)))) - (run lines))) + (with-pattern ([(LINE-NUM ...) + (filter-stx-prop 'b-line-number (syntax-flatten #'(LINE ...)))] + [(LINE-ID ...) (syntax-map (λ (stx) (prefix-id "line-" stx)) #'(LINE-NUM ...))]) + #'(#%module-begin + LINE ... + (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]) - #'($line LINE-NUMBER (λ () STATEMENT) (syntax-srcloc #'CALLER-STX)))) + (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]) + (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 line-vec (list->vector lines)) - (define line-idx-table (for/hasheqv ([(line idx) (in-indexed line-vec)]) - (values ($line-number line) idx))) +(define (run line-table) + (define line-vec (list->vector (sort (hash-keys line-table) <))) (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 this-thunk ($line-thunk this-line)) - (define this-result (this-thunk)) - (if (exact-positive-integer? this-result) - (hash-ref line-idx-table this-result - (λ () (raise-line-not-found ($line-srcloc this-line)))) - (add1 line-idx))))) \ No newline at end of file + (define line-num (vector-ref line-vec line-idx)) + (define line-proc (hash-ref line-table line-num)) + (define line-result (line-proc)) + (if (exact-positive-integer? line-result) + (or (vector-member line-result line-vec) + (raise-line-not-found (line-proc #:srcloc? #t))) + (add1 line-idx))))) diff --git a/beautiful-racket-demo/basic-demo/foo.rkt b/beautiful-racket-demo/basic-demo/foo.rkt new file mode 100644 index 0000000..c620e9c --- /dev/null +++ b/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))) diff --git a/beautiful-racket-demo/basic-demo/parser.rkt b/beautiful-racket-demo/basic-demo/parser.rkt index 8fff621..cbd5c2f 100644 --- a/beautiful-racket-demo/basic-demo/parser.rkt +++ b/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 diff --git a/beautiful-racket-demo/basic-demo/sample.rkt b/beautiful-racket-demo/basic-demo/sample.rkt new file mode 100644 index 0000000..86efe99 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/beautiful-racket-lib/br/quicklang.rkt b/beautiful-racket-lib/br/quicklang.rkt index 11ec310..d52b4d5 100644 --- a/beautiful-racket-lib/br/quicklang.rkt +++ b/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 diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index c77bb49..db25fb0 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/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) - #'(if (syntax? X) - (syntax->datum X) - X)) +(define (->unsyntax x) + (if (syntax? x) (syntax->datum x) x)) -(define-macro (prefix-id PREFIX ... BASE-OR-BASES) - #'(let* ([bobs BASE-OR-BASES] - [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))] - [bases (if got-single? - (list bobs) - bobs)] - [result (syntax-case-map - bases () - [base (format-id #'base "~a~a" - (string-append (format "~a" (->unsyntax PREFIX)) ...) - (syntax-e #'base))])]) - (if got-single? (car result) result))) +(define (fix-base loc-arg prefixes base-or-bases suffixes) + (define single-mode? (and (not (list? base-or-bases)) (not (syntax->list base-or-bases)))) + (define bases (if single-mode? (list base-or-bases) (or (syntax->list base-or-bases) base-or-bases))) + (define (stx-join stxs) (apply string-append (map (compose1 ~a ->unsyntax) stxs))) + (define result (map (λ (base) (format-id base "~a~a~a" (stx-join prefixes) (syntax-e base) (stx-join suffixes) + #:source loc-arg)) bases)) + (if single-mode? (car result) result)) -(define-macro (infix-id PREFIX BASE-OR-BASES SUFFIX ...) - #'(let* ([bobs BASE-OR-BASES] - [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))] - [bases (if got-single? - (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 (prefix-id #:source [loc-arg #f] . args) + ((match-lambda + [(list prefixes ... base-or-bases) + (fix-base loc-arg prefixes base-or-bases empty)]) args)) +(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 ...) - #'(infix-id "" BASE-OR-BASES SUFFIX ...)) +(define (suffix-id #:source [loc-arg #f] . args) + ((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]))