From 65af0d3f3bd5c5b209b7aa506bfac3a0b7b55210 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 4 Nov 2008 14:24:12 +0000 Subject: [PATCH] change contracts to reflect context via #%variable-reference instead of syntax objects; add id-less #%variable-reference form; drop link to unneeded CPort objects in delayed thunks; streamline some modules that tend to show up in deep phases svn: r12231 original commit: 95bedb17fbed95c3288ad8befd94c1c7e26c07e2 --- collects/mzlib/private/stxset.ss | 201 +++++++++++++++---------------- 1 file changed, 100 insertions(+), 101 deletions(-) diff --git a/collects/mzlib/private/stxset.ss b/collects/mzlib/private/stxset.ss index e4b8610..b1bd074 100644 --- a/collects/mzlib/private/stxset.ss +++ b/collects/mzlib/private/stxset.ss @@ -1,103 +1,102 @@ +#lang scheme/base +(require (for-syntax scheme/base + syntax/kerncase + syntax/context)) -(module stxset mzscheme +(provide finish-syntax-set) - (require-for-syntax syntax/kerncase - syntax/context) - - (provide finish-syntax-set) - - ;; Used in the expansion of `define-syntax-set' from "etc.ss" - (define-syntax (finish-syntax-set stx) - (syntax-case stx () - [(_ stx) - (let ([stx (syntax stx)]) - (syntax-case stx () - [(_ (id ...) defn ...) - ;; The ids have already been checked -------------------- - (let ([ids (syntax->list (syntax (id ...)))]) - (let ([internal-ids (map (lambda (id) - (datum->syntax-object - id - (string->symbol (format "~a/proc" (syntax-e id))) - id)) - ids)] - [expand-context (generate-expand-context)]) - ;; Check defns (requires expand) --------- - (let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([defn (local-expand - defn - expand-context - (kernel-form-identifier-list))]) - (syntax-case defn (define-values define-syntaxes begin) - [(define-values (id ...) expr) - (andmap identifier? (syntax->list (syntax (id ...)))) - (list defn)] - [(define-values . _) - (raise-syntax-error - #f - "bad definition" - stx - defn)] - [(define-syntaxes (id ...) expr) - (andmap identifier? (syntax->list (syntax (id ...)))) - (list defn)] - [(define-syntaxes . _) - (raise-syntax-error - #f - "bad definition" - stx - defn)] - [(begin defn ...) - (loop (syntax->list (syntax (defn ...))))] - [(begin . _) - (raise-syntax-error - #f - "bad `begin'" - stx - defn)] - [else - (raise-syntax-error - #f - "not a definition" - stx - defn)]))) - defns)))] - - [def-ids (apply append (map (lambda (defn) - (syntax-case defn () - [(_ (id ...) expr) - (syntax->list (syntax (id ...)))])) - defns))] - [val-ids (apply append (map (lambda (defn) - (syntax-case defn (define-values) - [(define-values (id ...) expr) - (syntax->list (syntax (id ...)))] - [_else null])) - defns))]) - (let ([dup (check-duplicate-identifier def-ids)]) - (when dup - (raise-syntax-error - #f - "duplicate defined identifier" - stx - dup))) - ;; Check that declared are defined --------- - (for-each (lambda (id) - (unless (check-duplicate-identifier (cons id val-ids)) - (raise-syntax-error - #f - "expected identifier is not defined" - stx - id))) - internal-ids) - ;; Produce result ------------------------------ - (with-syntax ([(defn ...) defns] - [(internal-id ...) internal-ids]) - (syntax/loc stx - (let () - defn ... - (values internal-id ...)))))))]))]))) +;; Used in the expansion of `define-syntax-set' from "etc.ss" +(define-syntax (finish-syntax-set stx) + (syntax-case stx () + [(_ stx) + (let ([stx (syntax stx)]) + (syntax-case stx () + [(_ (id ...) defn ...) + ;; The ids have already been checked -------------------- + (let ([ids (syntax->list (syntax (id ...)))]) + (let ([internal-ids (map (lambda (id) + (datum->syntax + id + (string->symbol (format "~a/proc" (syntax-e id))) + id)) + ids)] + [expand-context (generate-expand-context)]) + ;; Check defns (requires expand) --------- + (let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))]) + (apply + append + (map + (lambda (defn) + (let ([defn (local-expand + defn + expand-context + (kernel-form-identifier-list))]) + (syntax-case defn (define-values define-syntaxes begin) + [(define-values (id ...) expr) + (andmap identifier? (syntax->list (syntax (id ...)))) + (list defn)] + [(define-values . _) + (raise-syntax-error + #f + "bad definition" + stx + defn)] + [(define-syntaxes (id ...) expr) + (andmap identifier? (syntax->list (syntax (id ...)))) + (list defn)] + [(define-syntaxes . _) + (raise-syntax-error + #f + "bad definition" + stx + defn)] + [(begin defn ...) + (loop (syntax->list (syntax (defn ...))))] + [(begin . _) + (raise-syntax-error + #f + "bad `begin'" + stx + defn)] + [else + (raise-syntax-error + #f + "not a definition" + stx + defn)]))) + defns)))] + + [def-ids (apply append (map (lambda (defn) + (syntax-case defn () + [(_ (id ...) expr) + (syntax->list (syntax (id ...)))])) + defns))] + [val-ids (apply append (map (lambda (defn) + (syntax-case defn (define-values) + [(define-values (id ...) expr) + (syntax->list (syntax (id ...)))] + [_else null])) + defns))]) + (let ([dup (check-duplicate-identifier def-ids)]) + (when dup + (raise-syntax-error + #f + "duplicate defined identifier" + stx + dup))) + ;; Check that declared are defined --------- + (for-each (lambda (id) + (unless (check-duplicate-identifier (cons id val-ids)) + (raise-syntax-error + #f + "expected identifier is not defined" + stx + id))) + internal-ids) + ;; Produce result ------------------------------ + (with-syntax ([(defn ...) defns] + [(internal-id ...) internal-ids]) + (syntax/loc stx + (let () + defn ... + (values internal-id ...)))))))]))]))