From 7c029b42ceb09339dc4391c33fd18174d36c3ccb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 22 Nov 2006 00:06:01 +0000 Subject: [PATCH] reformatted svn: r4916 original commit: 11debcdcdc813483c781df57c20601548c3a1e6a --- collects/mzlib/etc.ss | 560 ++++++++++++++++++++++-------------------- 1 file changed, 288 insertions(+), 272 deletions(-) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 31e603b..d266038 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -4,52 +4,52 @@ (require (lib "main-collects.ss" "setup")) (require-for-syntax (lib "kerncase.ss" "syntax") - (lib "stx.ss" "syntax") - (lib "name.ss" "syntax") - (lib "context.ss" "syntax") + (lib "stx.ss" "syntax") + (lib "name.ss" "syntax") + (lib "context.ss" "syntax") (lib "main-collects.ss" "setup") "private/stxset.ss") - - (provide true false - boolean=? symbol=? - identity - compose - - build-string - build-vector - build-list - - loop-until - - opt-lambda - - local - recur - rec - evcase - nor - nand - let+ - namespace-defined? - this-expression-source-directory + (provide true false + boolean=? symbol=? + identity + compose + + build-string + build-vector + build-list + + loop-until + + opt-lambda + + local + recur + rec + evcase + nor + nand + let+ + + namespace-defined? + this-expression-source-directory this-expression-file-name - define-syntax-set - + define-syntax-set + hash-table - begin-with-definitions + begin-with-definitions + + begin-lifted) - begin-lifted) - (define true #t) (define false #f) - + (define identity (lambda (x) x)) - + (define compose - (case-lambda + (case-lambda [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))] [(f g) (let ([f (compose f)] @@ -188,7 +188,7 @@ (let ([d (local-expand defn expand-context - (kernel-form-identifier-list + (kernel-form-identifier-list (quote-syntax here)))] [check-ids (lambda (ids) (for-each @@ -240,7 +240,7 @@ (define-syntax (recur stx) (syntax-case stx () [(_ . rest) (syntax/loc stx (let . rest))])) - + ;; define a recursive value ;; implementation by Jens Axel Soegaard (define-syntax (rec stx) @@ -261,180 +261,186 @@ (raise-syntax-error #f "expects either a variable followed by an expresion, or a (possibly dotted) sequence of variables followed by a body" stx)])) - (define-syntax (evcase 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)) - (module-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 stx) - (syntax-case stx () - [(_ expr ...) (syntax/loc stx (not (or expr ...)))])) - - (define-syntax (nand stx) - (syntax-case stx () - [(_ expr ...) (syntax/loc stx (not (and expr ...)))])) - - (define-syntax (let+ stx) - (syntax-case stx () - [(_ [clause ...] body1 body ...) - (let ([clauses (syntax->list (syntax (clause ...)))] - [bad (lambda (c n) + (define-syntax (evcase 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)) + (module-identifier=? (quote-syntax else) + (car tests))) (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))])))))])) + #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 ns-undefined (gensym)) + (define-syntax (nor stx) + (syntax-case stx () + [(_ expr ...) (syntax/loc stx (not (or expr ...)))])) - (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 (nand stx) + (syntax-case stx () + [(_ expr ...) (syntax/loc stx (not (and expr ...)))])) - (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))))])) + (define-syntax (let+ 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-syntax (this-expression-file-name stx) - (syntax-case stx () - [(_) - (let* ([f (syntax-source stx)] - [f (and f (path? f) (file-exists? f) - (let-values ([(base file dir?) (split-path f)]) file))]) - (if f - (with-syntax ([f (path->bytes f)]) #'(bytes->path f)) - #'#f))])) + (define ns-undefined (gensym)) - ;; 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))) + (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))) - ;; 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 (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))))])) + + (define-syntax (this-expression-file-name stx) + (syntax-case stx () + [(_) + (let* ([f (syntax-source stx)] + [f (and f (path? f) (file-exists? f) + (let-values ([(base file dir?) (split-path f)]) file))]) + (if f + (with-syntax ([f (path->bytes f)]) #'(bytes->path f)) + #'#f))])) + + ;; 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 (quote) @@ -455,77 +461,87 @@ ;; `(define-values () ... (values))' as needed, and add a (void) ;; at the end if needed. (let* ([def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))] - [kernel-forms (kernel-form-identifier-list - (quote-syntax here))] - [init-exprs (let ([v (syntax->list stx)]) - (unless v - (raise-syntax-error #f "bad syntax" stx)) - (cdr v))] - [exprs (let loop ([exprs init-exprs]) - (apply - append - (map (lambda (expr) - (let ([expr (local-expand - expr - ctx - kernel-forms - def-ctx)]) - (syntax-case expr (begin define-syntaxes define-values) - [(begin . rest) - (loop (syntax->list #'rest))] - [(define-syntaxes (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([rhs (local-transformer-expand - #'rhs - 'expression - null)]) - (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) - (list #'(define-syntaxes (id ...) rhs)))] - [(define-values (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (let ([ids (syntax->list #'(id ...))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (list expr))] - [else - (list expr)]))) - exprs)))]) - (let loop ([exprs exprs][prev-stx-defns null][prev-defns null][prev-exprs null]) - (cond - [(null? exprs) - #`(letrec-syntaxes+values - #,(map stx-cdr (reverse prev-stx-defns)) - #,(map stx-cdr (reverse prev-defns)) - #,@(if (null? prev-exprs) - (list #'(void)) - (reverse prev-exprs)))] - [(and (stx-pair? (car exprs)) - (identifier? (stx-car (car exprs))) - (module-identifier=? #'define-syntaxes (stx-car (car exprs)))) - (loop (cdr exprs) (cons (car exprs) prev-stx-defns) prev-defns prev-exprs)] - [(and (stx-pair? (car exprs)) - (identifier? (stx-car (car exprs))) - (module-identifier=? #'define-values (stx-car (car exprs)))) - (loop (cdr exprs) - prev-stx-defns - (cons (car exprs) - (append - (map (lambda (expr) - #`(define-values () (begin #,expr (values)))) - prev-exprs) - prev-defns)) - null)] - [else - (loop (cdr exprs) prev-stx-defns prev-defns (cons (car exprs) prev-exprs))])))) + [ctx (list (gensym 'intdef))] + [kernel-forms (kernel-form-identifier-list + (quote-syntax here))] + [init-exprs (let ([v (syntax->list stx)]) + (unless v + (raise-syntax-error #f "bad syntax" stx)) + (cdr v))] + [exprs (let loop ([exprs init-exprs]) + (apply + append + (map (lambda (expr) + (let ([expr (local-expand + expr + ctx + kernel-forms + def-ctx)]) + (syntax-case expr (begin define-syntaxes define-values) + [(begin . rest) + (loop (syntax->list #'rest))] + [(define-syntaxes (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (syntax-local-bind-syntaxes + (syntax->list #'(id ...)) + #'rhs def-ctx) + (list #'(define-syntaxes (id ...) rhs)))] + [(define-values (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #f def-ctx) + (list expr))] + [else + (list expr)]))) + exprs)))]) + (let loop ([exprs exprs] + [prev-stx-defns null] + [prev-defns null] + [prev-exprs null]) + (cond + [(null? exprs) + #`(letrec-syntaxes+values + #,(map stx-cdr (reverse prev-stx-defns)) + #,(map stx-cdr (reverse prev-defns)) + #,@(if (null? prev-exprs) + (list #'(void)) + (reverse prev-exprs)))] + [(and (stx-pair? (car exprs)) + (identifier? (stx-car (car exprs))) + (module-identifier=? #'define-syntaxes (stx-car (car exprs)))) + (loop (cdr exprs) + (cons (car exprs) prev-stx-defns) + prev-defns + prev-exprs)] + [(and (stx-pair? (car exprs)) + (identifier? (stx-car (car exprs))) + (module-identifier=? #'define-values (stx-car (car exprs)))) + (loop (cdr exprs) + prev-stx-defns + (cons (car exprs) + (append + (map (lambda (expr) + #`(define-values () (begin #,expr (values)))) + prev-exprs) + prev-defns)) + null)] + [else (loop (cdr exprs) + prev-stx-defns + prev-defns + (cons (car exprs) prev-exprs))])))) (define-syntax (begin-lifted stx) (syntax-case stx () [(_ expr0 expr ...) (let ([name (syntax-local-name)]) - (if name - (with-syntax ([name name]) - (syntax-local-lift-expression - #'(let ([name (begin expr0 expr ...)]) - name))) - (syntax-local-lift-expression - #'(begin expr0 expr ...))))]))) + (if name + (with-syntax ([name name]) + (syntax-local-lift-expression + #'(let ([name (begin expr0 expr ...)]) + name))) + (syntax-local-lift-expression + #'(begin expr0 expr ...))))])))