From 93715a33e1d95e3c041266db3c21cb27b7718e71 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 1 Jul 2003 16:23:56 +0000 Subject: [PATCH] . original commit: 9bfb826b9cc49b5a347a2ded32e759c8f637d2d9 --- collects/mzlib/etc.ss | 102 +++++++++++++++--------------- collects/mzlib/private/sigutil.ss | 8 ++- collects/mzlib/private/stxset.ss | 8 ++- collects/mzlib/unit.ss | 4 +- 4 files changed, 65 insertions(+), 57 deletions(-) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 1aae44f..3b3e34b 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -4,6 +4,7 @@ (require-for-syntax (lib "kerncase.ss" "syntax") (lib "stx.ss" "syntax") (lib "name.ss" "syntax") + (lib "context.ss" "syntax") "private/stxset.ss") (provide true false @@ -196,56 +197,57 @@ (lambda (stx) (syntax-case stx () [(_ (defn ...) body1 body ...) - (let ([defs (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([d (local-expand - defn - 'internal-define - (kernel-form-identifier-list - (quote-syntax here)))] - [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 ([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 + (quote-syntax here)))] + [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) diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index 20717f5..000e2da 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -4,7 +4,8 @@ ;; (needs an overhaul, too) (require (lib "stx.ss" "syntax") - (lib "struct.ss" "syntax")) + (lib "struct.ss" "syntax") + (lib "context.ss" "syntax")) (require "sigmatch.ss") (require "../unit.ss") @@ -600,7 +601,8 @@ swapped-renames) (loop (cdr e)) (cons (car e) (loop (cdr e)))))))] - [local-vars (append renamed-internals filtered-exported-names imported-names)]) + [local-vars (append renamed-internals filtered-exported-names imported-names)] + [expand-context (generate-expand-context)]) (let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null]) (cond [(and (null? pre-lines) (not port) (null? lines)) @@ -623,7 +625,7 @@ (if (eof-object? s) s (local-expand s - 'internal-define + expand-context (append user-stx-forms local-vars))))] diff --git a/collects/mzlib/private/stxset.ss b/collects/mzlib/private/stxset.ss index 9439a4d..d19b603 100644 --- a/collects/mzlib/private/stxset.ss +++ b/collects/mzlib/private/stxset.ss @@ -1,7 +1,8 @@ (module stxset mzscheme - (require-for-syntax (lib "kerncase.ss" "syntax")) + (require-for-syntax (lib "kerncase.ss" "syntax") + (lib "context.ss" "syntax")) (provide finish-syntax-set) @@ -19,7 +20,8 @@ id (string->symbol (format "~a/proc" (syntax-e id))) id)) - ids)]) + ids)] + [expand-context (generate-expand-context)]) ;; Check defns (requires expand) --------- (let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))]) (apply @@ -28,7 +30,7 @@ (lambda (defn) (let ([defn (local-expand defn - 'internal-define + expand-context (kernel-form-identifier-list (quote-syntax here)))]) (syntax-case defn (define-values define-syntaxes begin) [(define-values (id ...) expr) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index fdf3dac..113f1dd 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -5,6 +5,7 @@ (require-for-syntax (lib "kerncase.ss" "syntax") (lib "stx.ss" "syntax") (lib "name.ss" "syntax") + (lib "context.ss" "syntax") "list.ss" "private/unitidmap.ss") @@ -60,6 +61,7 @@ "export is not an identifier or renamed identifier" stx v)]))] + [expand-context (generate-expand-context)] [ivars (syntax->list (syntax (ivar ...)))] [evars (syntax->list (syntax (evar ...)))]) (for-each check-id ivars) @@ -100,7 +102,7 @@ (lambda (defn-or-expr) (local-expand defn-or-expr - 'internal-define + expand-context (append (kernel-form-identifier-list (quote-syntax here)) declared-names)))