diff --git a/beautiful-racket-lib/br/cond.rkt b/beautiful-racket-lib/br/cond.rkt new file mode 100644 index 0000000..dd1de32 --- /dev/null +++ b/beautiful-racket-lib/br/cond.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require (for-syntax racket/base)) +(provide (all-defined-out)) + +(define-syntax-rule (until COND EXPR ...) + (let loop () + (unless COND + EXPR ... + (loop)))) + +(define-syntax-rule (while COND EXPR ...) + (let loop () + (when COND + EXPR ... + (loop)))) + +(define-syntax (forever stx) + (syntax-case stx () + [(_ . EXPRS) + ;; todo: would be better with a syntax parameter + (with-syntax ([stop (datum->syntax #'EXPRS 'stop)]) + #'(let/ec stop + (while #t + . EXPRS)))])) + +(module+ test + (require rackunit) + (check-equal? (let ([x 5]) + (until (zero? x) + (set! x (- x 1))) + x) 0) + (check-equal? (let ([x 5]) + (while (positive? x) + (set! x (- x 1))) + x) 0)) + diff --git a/beautiful-racket-lib/br/conditional.rkt b/beautiful-racket-lib/br/conditional.rkt deleted file mode 100644 index c28b561..0000000 --- a/beautiful-racket-lib/br/conditional.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base)) -(provide (all-defined-out)) - -(define-syntax-rule (until cond expr ...) - (let loop () - (unless cond - expr ... - (loop)))) - -(define-syntax-rule (while cond expr ...) - (let loop () - (when cond - expr ... - (loop)))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/datum.rkt b/beautiful-racket-lib/br/datum.rkt index 66cf650..714f6f0 100644 --- a/beautiful-racket-lib/br/datum.rkt +++ b/beautiful-racket-lib/br/datum.rkt @@ -23,13 +23,16 @@ (syntax->datum arg) arg)) (list ...)))))]))) +(define (datum? x) (or (list? x) (symbol? x))) + (define (format-datum datum-template . args) (string->datum (apply format (format "~a" datum-template) (map (λ(arg) (if (syntax? arg) (syntax->datum arg) arg)) args)))) -(define (format-datums datum-template args) - (map (λ(arg) (format-datum datum-template arg)) args)) +;; todo: rephrase errors from `format` or `map` in terms of `format-datums` +(define (format-datums datum-template . argss) + (apply map (λ args (apply format-datum datum-template args)) argss)) (module+ test (require rackunit syntax/datum) diff --git a/beautiful-racket-lib/br/debug.rkt b/beautiful-racket-lib/br/debug.rkt index 3788e04..fb4dbc3 100644 --- a/beautiful-racket-lib/br/debug.rkt +++ b/beautiful-racket-lib/br/debug.rkt @@ -4,23 +4,24 @@ (define-syntax (report stx) (syntax-case stx () - [(_ expr) #'(report expr expr)] - [(_ expr name) - #'(let ([expr-result expr]) - (eprintf "~a = ~v\n" 'name expr-result) + [(_ EXPR) #'(report EXPR EXPR)] + [(_ EXPR NAME) + #'(let ([expr-result EXPR]) + (eprintf "~a = ~v\n" 'NAME expr-result) expr-result)])) (define-syntax (report-datum stx) (syntax-case stx () - [(_ stx-expr) (with-syntax ([datum (syntax->datum #'stx-expr)]) - #'(report-datum stx-expr datum))] - [(_ stx-expr name) + [(_ STX-EXPR) + (with-syntax ([datum (syntax->datum #'STX-EXPR)]) + #'(report-datum STX-EXPR datum))] + [(_ STX-EXPR NAME) #'(let () - (eprintf "~a = ~v\n" 'name (syntax->datum stx-expr)) - stx-expr)])) + (eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR)) + STX-EXPR)])) -(define-syntax-rule (define-multi-version multi-name name) - (define-syntax-rule (multi-name x (... ...)) - (begin (name x) (... ...)))) +(define-syntax-rule (define-multi-version MULTI-NAME NAME) + (define-syntax-rule (MULTI-NAME x (... ...)) + (begin (NAME x) (... ...)))) (define-multi-version report* report) \ No newline at end of file diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt index 41e16fe..33255a3 100644 --- a/beautiful-racket-lib/br/main.rkt +++ b/beautiful-racket-lib/br/main.rkt @@ -1,10 +1,10 @@ #lang racket/base (require racket/provide racket/list racket/string racket/format racket/match racket/port - br/define br/syntax br/datum br/debug br/conditional racket/function + br/define br/syntax br/datum br/debug br/cond racket/function (for-syntax racket/base racket/syntax br/syntax br/debug br/define)) (provide (except-out (all-from-out racket/base) define) (all-from-out racket/list racket/string racket/format racket/match racket/port - br/syntax br/datum br/debug br/conditional racket/function) + br/syntax br/datum br/debug br/cond racket/function) (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug)) (for-syntax caller-stx shared-syntax with-shared-id with-calling-site-id) ; from br/define (filtered-out