diff --git a/collects/frtime/frlibs/etc.rkt b/collects/frtime/frlibs/etc.rkt index 2b4cbc3379..c7345aeb81 100644 --- a/collects/frtime/frlibs/etc.rkt +++ b/collects/frtime/frlibs/etc.rkt @@ -1,40 +1,32 @@ (module etc frtime/frtime-lang-only (require setup/main-collects) - (require (for-syntax - racket/base - syntax/kerncase - syntax/stx - syntax/name - syntax/context - setup/main-collects - mzlib/private/stxset)) - - (provide true false - boolean=? symbol=? - identity - compose - - ;build-string - ;build-vector - build-list - - loop-until - + (require (for-syntax racket/base + syntax/kerncase + syntax/stx + syntax/name + syntax/context + setup/main-collects + mzlib/private/stxset)) + + (provide true + false + boolean=? symbol=? + identity + compose + build-list + loop-until opt-lambda - - local - recur - rec - evcase - nor - nand - let+ - - namespace-defined? - this-expression-source-directory - define-syntax-set - + local + recur + rec + evcase + nor + nand + let+ + namespace-defined? + this-expression-source-directory + define-syntax-set hash-table) (define true #t) @@ -64,9 +56,7 @@ [(f . more) (let ([m (apply compose more)]) (compose f m))])) - - -#| + #| (define build-string (lambda (n fcn) (unless (and (integer? n) (exact? n) (>= n 0)) @@ -85,8 +75,7 @@ ;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i). ;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1. ;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3) - -#| + #| (define build-vector (lambda (n fcn) (unless (and (integer? n) (exact? n) (>= n 0)) @@ -102,21 +91,21 @@ |# (define build-list (lambda (n fcn) - (unless (and (integer? n) (exact? n) (>= n 0)) - (error 'build-list "~s must be an exact integer >= 0" n)) - (unless (procedure? fcn) - (error 'build-list "~s must be a procedure" fcn)) - (let loop ([i (sub1 n)] [p '()]) - (if (>= i 0) - (loop (sub1 i) (cons (fcn i) p)) - p)))) - + (unless (and (integer? n) (exact? n) (>= n 0)) + (error 'build-list "~s must be an exact integer >= 0" n)) + (unless (procedure? fcn) + (error 'build-list "~s must be a procedure" fcn)) + (let loop ([i (sub1 n)] [p '()]) + (if (>= i 0) + (loop (sub1 i) (cons (fcn i) p)) + p)))) + (define loop-until (lambda (start done? next body) - (let loop ([i start]) - (unless (done? i) - (body i) - (loop (next i)))))) + (let loop ([i start]) + (unless (done? i) + (body i) + (loop (next i)))))) (define boolean=? (lambda (x y) @@ -129,360 +118,360 @@ (define (symbol=? x y) (unless (and (symbol? x) - (symbol? y)) + (symbol? y)) (raise-type-error 'symbol=? "symbol" - (if (symbol? x) y x))) + (if (symbol? x) y x))) (eq? x y)) - - (define-syntax opt-lambda - (lambda (stx) - (with-syntax ([name (or (syntax-local-infer-name stx) - (quote-syntax opt-lambda-proc))]) - (syntax-case stx () - [(_ args body1 body ...) - (let ([clauses (let loop ([pre-args null] - [args (syntax args)] - [needs-default? #f]) - (syntax-case args () - [id - (identifier? (syntax id)) - (with-syntax ([(pre-arg ...) pre-args]) - (syntax ([(pre-arg ... . id) - body1 body ...])))] - [() - (with-syntax ([(pre-arg ...) pre-args]) - (syntax ([(pre-arg ...) - body1 body ...])))] - [(id . rest) - (identifier? (syntax id)) - (begin - (when needs-default? - (raise-syntax-error - #f - "default value missing" - stx - (syntax id))) - (loop (append pre-args (list (syntax id))) - (syntax rest) - #f))] - [([id default] . rest) - (identifier? (syntax id)) - (with-syntax ([rest (loop (append pre-args (list (syntax id))) - (syntax rest) - #t)] - [(pre-arg ...) pre-args]) - (syntax ([(pre-arg ...) (name pre-arg ... default)] - . rest)))] - [(bad . rest) - (raise-syntax-error - #f - "not an identifier or identifier with default" - stx - (syntax bad))] - [else - (raise-syntax-error - #f - "bad identifier sequence" - stx - (syntax args))]))]) - (with-syntax ([clauses clauses]) - (syntax/loc stx - (letrec ([name - (case-lambda - . clauses)]) - name))))])))) - - (define-syntax local - (lambda (stx) - (syntax-case stx () - [(_ (defn ...) body1 body ...) - (let ([defs (let ([expand-context (generate-expand-context)]) - (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([d (local-expand - defn - expand-context - (kernel-form-identifier-list))] - [check-ids (lambda (ids) - (for-each - (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "not an identifier for definition" - stx - id))) - ids))]) - (syntax-case d (define-values define-syntaxes begin) - [(begin defn ...) - (loop (syntax->list (syntax (defn ...))))] - [(define-values (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-values . rest) - (raise-syntax-error - #f - "ill-formed definition" - stx - d)] - [(define-syntaxes (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-syntaxes . rest) - (raise-syntax-error - #f - "ill-formed definition" - stx - d)] - [_else - (raise-syntax-error - #f - "not a definition" - stx - defn)]))) - defns))))]) - (let ([ids (apply append - (map - (lambda (d) - (syntax-case d () - [(_ ids . __) - (syntax->list (syntax ids))])) - defs))]) - (let ([dup (check-duplicate-identifier ids)]) - (when dup - (raise-syntax-error - #f - "duplicate identifier" - stx - dup))) - (with-syntax ([(def ...) defs]) - (syntax/loc - stx - (let () - def ... - (let () - body1 - body ...))))))] - [(_ x body1 body ...) - (raise-syntax-error - #f - "not a definition sequence" - stx - (syntax x))]))) - - ;; recur is another name for 'let' in a named let - (define-syntax recur - (lambda (stx) - (syntax-case stx () - [(_ . rest) - (syntax/loc stx (let . rest))]))) - - ;; define a recursive value - (define-syntax rec - (lambda (stx) - (syntax-case stx () - [(_ name expr) - (begin - (unless (identifier? (syntax name)) - (raise-syntax-error - #f - "not an identifier" - stx - (syntax name))) - (syntax/loc stx - (letrec ([name expr]) - name)))]))) - - (define-syntax evcase - (lambda (stx) - (syntax-case stx () - [(_ val [test body ...] ...) - (let ([tests (syntax->list (syntax (test ...)))]) - (with-syntax ([(a-test ...) - (map - (lambda (t) - (syntax-case t (else) - [else (syntax #t)] - [_else (with-syntax ([t t]) - (syntax (eqv? evcase-v t)))])) - tests)]) - ;; Make sure else is last: - (unless (null? tests) - (let loop ([tests tests]) - (unless (null? (cdr tests)) - (when (and (identifier? (car tests)) - (free-identifier=? (quote-syntax else) (car tests))) - (raise-syntax-error - #f - "else is not in last clause" - stx - (car tests))) - (loop (cdr tests))))) - (syntax/loc stx - (let ([evcase-v val]) - (cond - [a-test - (begin body ...)] - ...)))))] - [(_ val something ...) - ;; Provide a good error message: - (for-each - (lambda (s) - (syntax-case s () - [(t a ...) - (raise-syntax-error - #f - "invalid clause" - stx - s)])) - (syntax->list (syntax (something ...))))]))) - - (define-syntax nor - (lambda (stx) - (syntax-case stx () - [(_ expr ...) - (syntax/loc stx (not (or expr ...)))]))) - - (define-syntax nand - (lambda (stx) - (syntax-case stx () - [(_ expr ...) - (syntax/loc stx (not (and expr ...)))]))) - - (define-syntax let+ - (lambda (stx) - (syntax-case stx () - [(_ [clause ...] body1 body ...) - (let ([clauses (syntax->list (syntax (clause ...)))] - [bad (lambda (c n) - (raise-syntax-error - #f - (format "illegal use of ~a for a clause" n) - stx - c))] - [var? (lambda (x) - (or (identifier? x) - (let ([l (syntax->list x)]) - (and l - (pair? l) - (eq? (syntax-e (car l)) 'values) - (andmap identifier? (cdr l))))))] - [normal-var (lambda (x) - (if (identifier? x) - (list x) - (cdr (syntax-e x))))]) - ;; syntax checks - (for-each - (lambda (clause) - (syntax-case* clause (val rec vals recs _) (lambda (a b) - (eq? (syntax-e b) - (syntax-e a))) - [(val var expr) - (var? (syntax var)) - 'ok] - [(rec var expr) - (var? (syntax var)) - 'ok] - [(vals (var expr) ...) - (andmap var? (syntax->list (syntax (var ...)))) - 'ok] - [(recs (var expr) ...) - (andmap var? (syntax->list (syntax (var ...)))) - 'ok] - [(_ expr0 expr ...) - 'ok] - [(val . __) (bad clause "val")] - [(rec . __) (bad clause "rec")] - [(vals . __) (bad clause "vals")] - [(recs . __) (bad clause "recs")] - [(_ . __) (bad clause "_")] - [_else (raise-syntax-error #f "bad clause" stx clause)])) - clauses) - ;; result - (let loop ([clauses clauses]) - (if (null? clauses) - (syntax (let () body1 body ...)) - (with-syntax ([rest (loop (cdr clauses))]) - (syntax-case* (car clauses) (val rec vals recs _) (lambda (a b) - (eq? (syntax-e b) - (syntax-e a))) - [(val var expr) - (with-syntax ([vars (normal-var (syntax var))]) - (syntax (let-values ([vars expr]) rest)))] - [(rec var expr) - (with-syntax ([vars (normal-var (syntax var))]) - (syntax (letrec-values ([vars expr]) rest)))] - [(vals (var expr) ...) - (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) - (syntax (let-values ([vars expr] ...) rest)))] - [(recs (var expr) ...) - (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) - (syntax (letrec-values ([vars expr] ...) rest)))] - [(_ expr0 expr ...) - (syntax (begin expr0 expr ... rest))])))))]))) - - (define ns-undefined (gensym)) - - (define (namespace-defined? n) - (unless (symbol? n) - (raise-type-error 'namespace-defined? "symbol" n)) - (not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) ns-undefined))) - - (define-syntax (this-expression-source-directory stx) - (syntax-case stx () - [(_) - (let* ([source (syntax-source stx)] - [source (and (path? source) source)] - [local (or (current-load-relative-directory) (current-directory))] - [dir (path->main-collects-relative - (or (and source (file-exists? source) - (let-values ([(base file dir?) (split-path source)]) - (and (path? base) - (path->complete-path base local)))) - local))]) - (if (and (pair? dir) (eq? 'collects (car dir))) - (with-syntax ([d dir]) - #'(main-collects-relative->path 'd)) - (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))]) - #'(bytes->path d))))])) - - ;; This is a macro-generating macro that wants to expand - ;; expressions used in the generated macro. So it's weird, - ;; and we put much of the work in a helper macro, - ;; `finish-syntax-set'. - (define-syntax (define-syntax-set stx) - (syntax-case stx () - [(_ (id ...) defn ...) - (let ([ids (syntax->list (syntax (id ...)))]) - ;; Check ids ------------------------------ - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "not an identifier or two identifier in parentheses" - stx - id))) - ids) - (let ([dup (check-duplicate-identifier ids)]) - (when dup - (raise-syntax-error - #f - "duplicate identifier" - stx - dup))) - - ;; We'd like to check the `defns', but that requires - ;; and expansion in a different phase. So we move - ;; into that phase using `finish-syntax-set': - (with-syntax ([orig-stx stx]) - (syntax/loc stx - (define-syntaxes (id ...) - (finish-syntax-set orig-stx)))))])) + + (define-syntax opt-lambda + (lambda (stx) + (with-syntax ([name (or (syntax-local-infer-name stx) + (quote-syntax opt-lambda-proc))]) + (syntax-case stx () + [(_ args body1 body ...) + (let ([clauses (let loop ([pre-args null] + [args (syntax args)] + [needs-default? #f]) + (syntax-case args () + [id + (identifier? (syntax id)) + (with-syntax ([(pre-arg ...) pre-args]) + (syntax ([(pre-arg ... . id) + body1 body ...])))] + [() + (with-syntax ([(pre-arg ...) pre-args]) + (syntax ([(pre-arg ...) + body1 body ...])))] + [(id . rest) + (identifier? (syntax id)) + (begin + (when needs-default? + (raise-syntax-error + #f + "default value missing" + stx + (syntax id))) + (loop (append pre-args (list (syntax id))) + (syntax rest) + #f))] + [([id default] . rest) + (identifier? (syntax id)) + (with-syntax ([rest (loop (append pre-args (list (syntax id))) + (syntax rest) + #t)] + [(pre-arg ...) pre-args]) + (syntax ([(pre-arg ...) (name pre-arg ... default)] + . rest)))] + [(bad . rest) + (raise-syntax-error + #f + "not an identifier or identifier with default" + stx + (syntax bad))] + [else + (raise-syntax-error + #f + "bad identifier sequence" + stx + (syntax args))]))]) + (with-syntax ([clauses clauses]) + (syntax/loc stx + (letrec ([name + (case-lambda + . clauses)]) + name))))])))) + + (define-syntax local + (lambda (stx) + (syntax-case stx () + [(_ (defn ...) body1 body ...) + (let ([defs (let ([expand-context (generate-expand-context)]) + (let loop ([defns (syntax->list (syntax (defn ...)))]) + (apply + append + (map + (lambda (defn) + (let ([d (local-expand + defn + expand-context + (kernel-form-identifier-list))] + [check-ids (lambda (ids) + (for-each + (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier for definition" + stx + id))) + ids))]) + (syntax-case d (define-values define-syntaxes begin) + [(begin defn ...) + (loop (syntax->list (syntax (defn ...))))] + [(define-values (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-values . rest) + (raise-syntax-error + #f + "ill-formed definition" + stx + d)] + [(define-syntaxes (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-syntaxes . rest) + (raise-syntax-error + #f + "ill-formed definition" + stx + d)] + [_else + (raise-syntax-error + #f + "not a definition" + stx + defn)]))) + defns))))]) + (let ([ids (apply append + (map + (lambda (d) + (syntax-case d () + [(_ ids . __) + (syntax->list (syntax ids))])) + defs))]) + (let ([dup (check-duplicate-identifier ids)]) + (when dup + (raise-syntax-error + #f + "duplicate identifier" + stx + dup))) + (with-syntax ([(def ...) defs]) + (syntax/loc + stx + (let () + def ... + (let () + body1 + body ...))))))] + [(_ x body1 body ...) + (raise-syntax-error + #f + "not a definition sequence" + stx + (syntax x))]))) + + ;; recur is another name for 'let' in a named let + (define-syntax recur + (lambda (stx) + (syntax-case stx () + [(_ . rest) + (syntax/loc stx (let . rest))]))) + + ;; define a recursive value + (define-syntax rec + (lambda (stx) + (syntax-case stx () + [(_ name expr) + (begin + (unless (identifier? (syntax name)) + (raise-syntax-error + #f + "not an identifier" + stx + (syntax name))) + (syntax/loc stx + (letrec ([name expr]) + name)))]))) + + (define-syntax evcase + (lambda (stx) + (syntax-case stx () + [(_ val [test body ...] ...) + (let ([tests (syntax->list (syntax (test ...)))]) + (with-syntax ([(a-test ...) + (map + (lambda (t) + (syntax-case t (else) + [else (syntax #t)] + [_else (with-syntax ([t t]) + (syntax (eqv? evcase-v t)))])) + tests)]) + ;; Make sure else is last: + (unless (null? tests) + (let loop ([tests tests]) + (unless (null? (cdr tests)) + (when (and (identifier? (car tests)) + (free-identifier=? (quote-syntax else) (car tests))) + (raise-syntax-error + #f + "else is not in last clause" + stx + (car tests))) + (loop (cdr tests))))) + (syntax/loc stx + (let ([evcase-v val]) + (cond + [a-test + (begin body ...)] + ...)))))] + [(_ val something ...) + ;; Provide a good error message: + (for-each + (lambda (s) + (syntax-case s () + [(t a ...) + (raise-syntax-error + #f + "invalid clause" + stx + s)])) + (syntax->list (syntax (something ...))))]))) + + (define-syntax nor + (lambda (stx) + (syntax-case stx () + [(_ expr ...) + (syntax/loc stx (not (or expr ...)))]))) + + (define-syntax nand + (lambda (stx) + (syntax-case stx () + [(_ expr ...) + (syntax/loc stx (not (and expr ...)))]))) + + (define-syntax let+ + (lambda (stx) + (syntax-case stx () + [(_ [clause ...] body1 body ...) + (let ([clauses (syntax->list (syntax (clause ...)))] + [bad (lambda (c n) + (raise-syntax-error + #f + (format "illegal use of ~a for a clause" n) + stx + c))] + [var? (lambda (x) + (or (identifier? x) + (let ([l (syntax->list x)]) + (and l + (pair? l) + (eq? (syntax-e (car l)) 'values) + (andmap identifier? (cdr l))))))] + [normal-var (lambda (x) + (if (identifier? x) + (list x) + (cdr (syntax-e x))))]) + ;; syntax checks + (for-each + (lambda (clause) + (syntax-case* clause (val rec vals recs _) (lambda (a b) + (eq? (syntax-e b) + (syntax-e a))) + [(val var expr) + (var? (syntax var)) + 'ok] + [(rec var expr) + (var? (syntax var)) + 'ok] + [(vals (var expr) ...) + (andmap var? (syntax->list (syntax (var ...)))) + 'ok] + [(recs (var expr) ...) + (andmap var? (syntax->list (syntax (var ...)))) + 'ok] + [(_ expr0 expr ...) + 'ok] + [(val . __) (bad clause "val")] + [(rec . __) (bad clause "rec")] + [(vals . __) (bad clause "vals")] + [(recs . __) (bad clause "recs")] + [(_ . __) (bad clause "_")] + [_else (raise-syntax-error #f "bad clause" stx clause)])) + clauses) + ;; result + (let loop ([clauses clauses]) + (if (null? clauses) + (syntax (let () body1 body ...)) + (with-syntax ([rest (loop (cdr clauses))]) + (syntax-case* (car clauses) (val rec vals recs _) (lambda (a b) + (eq? (syntax-e b) + (syntax-e a))) + [(val var expr) + (with-syntax ([vars (normal-var (syntax var))]) + (syntax (let-values ([vars expr]) rest)))] + [(rec var expr) + (with-syntax ([vars (normal-var (syntax var))]) + (syntax (letrec-values ([vars expr]) rest)))] + [(vals (var expr) ...) + (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) + (syntax (let-values ([vars expr] ...) rest)))] + [(recs (var expr) ...) + (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) + (syntax (letrec-values ([vars expr] ...) rest)))] + [(_ expr0 expr ...) + (syntax (begin expr0 expr ... rest))])))))]))) + + (define ns-undefined (gensym)) + + (define (namespace-defined? n) + (unless (symbol? n) + (raise-type-error 'namespace-defined? "symbol" n)) + (not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) ns-undefined))) + + (define-syntax (this-expression-source-directory stx) + (syntax-case stx () + [(_) + (let* ([source (syntax-source stx)] + [source (and (path? source) source)] + [local (or (current-load-relative-directory) (current-directory))] + [dir (path->main-collects-relative + (or (and source (file-exists? source) + (let-values ([(base file dir?) (split-path source)]) + (and (path? base) + (path->complete-path base local)))) + local))]) + (if (and (pair? dir) (eq? 'collects (car dir))) + (with-syntax ([d dir]) + #'(main-collects-relative->path 'd)) + (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))]) + #'(bytes->path d))))])) + + ;; This is a macro-generating macro that wants to expand + ;; expressions used in the generated macro. So it's weird, + ;; and we put much of the work in a helper macro, + ;; `finish-syntax-set'. + (define-syntax (define-syntax-set stx) + (syntax-case stx () + [(_ (id ...) defn ...) + (let ([ids (syntax->list (syntax (id ...)))]) + ;; Check ids ------------------------------ + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier or two identifier in parentheses" + stx + id))) + ids) + (let ([dup (check-duplicate-identifier ids)]) + (when dup + (raise-syntax-error + #f + "duplicate identifier" + stx + dup))) + + ;; We'd like to check the `defns', but that requires + ;; and expansion in a different phase. So we move + ;; into that phase using `finish-syntax-set': + (with-syntax ([orig-stx stx]) + (syntax/loc stx + (define-syntaxes (id ...) + (finish-syntax-set orig-stx)))))])) (define-syntax (hash-table stx) (syntax-case stx ()