diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss index af222ed97f..04c0f32927 100644 --- a/collects/redex/private/term.ss +++ b/collects/redex/private/term.ss @@ -2,7 +2,7 @@ (require (for-syntax scheme/base "term-fn.ss" - syntax/private/util/misc) + unstable/syntax) "matcher.ss") (provide term term-let term-let/error-name term-let-fn term-define-fn hole in-hole) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index 421e0a0afd..04606397c5 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -4,7 +4,7 @@ syntax/stx syntax/id-table syntax/keyword - syntax/private/util/misc + unstable/syntax "rep-data.ss" "rep.ss" "codegen-data.ss" diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index 2089749bb6..230e43a710 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -7,7 +7,7 @@ syntax/id-table syntax/stx syntax/keyword - syntax/private/util/misc + unstable/syntax "../util.ss" "rep-data.ss" "codegen-data.ss") diff --git a/collects/syntax/private/stxparse/runtime-prose.ss b/collects/syntax/private/stxparse/runtime-prose.ss index fb5fe1a945..7aa46a6933 100644 --- a/collects/syntax/private/stxparse/runtime-prose.ss +++ b/collects/syntax/private/stxparse/runtime-prose.ss @@ -8,7 +8,7 @@ (for-syntax syntax/stx) (for-syntax scheme/private/sc) (for-syntax "rep-data.ss") - (for-syntax "../util/error.ss") + (for-syntax "../util.ss") "runtime.ss") (provide syntax-patterns-fail current-failure-handler diff --git a/collects/syntax/private/util.ss b/collects/syntax/private/util.ss index 6dd0a3e5ba..de9206009c 100644 --- a/collects/syntax/private/util.ss +++ b/collects/syntax/private/util.ss @@ -1,9 +1,5 @@ #lang scheme/base -(require "util/error.ss" - "util/expand.ss" - "util/misc.ss" - "util/struct.ss") -(provide (all-from-out "util/error.ss") - (all-from-out "util/expand.ss") - (all-from-out "util/misc.ss") - (all-from-out "util/struct.ss")) +(require unstable/syntax + unstable/struct) +(provide (all-from-out unstable/syntax) + (all-from-out unstable/struct)) diff --git a/collects/syntax/private/util/error.ss b/collects/syntax/private/util/error.ss deleted file mode 100644 index 391c42a161..0000000000 --- a/collects/syntax/private/util/error.ss +++ /dev/null @@ -1,16 +0,0 @@ -#lang scheme/base -(provide wrong-syntax - current-syntax-context) - -(define current-syntax-context (make-parameter #f)) - -(define (wrong-syntax stx #:extra [extras null] format-string . args) - (unless (or (eq? stx #f) (syntax? stx)) - (raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args))) - (let* ([ctx (current-syntax-context)] - [blame (and (syntax? ctx) (syntax-property ctx 'report-errors-as))]) - (raise-syntax-error (if (symbol? blame) blame #f) - (apply format format-string args) - ctx - stx - extras))) diff --git a/collects/syntax/private/util/misc.ss b/collects/syntax/private/util/misc.ss deleted file mode 100644 index e92246fd9c..0000000000 --- a/collects/syntax/private/util/misc.ss +++ /dev/null @@ -1,241 +0,0 @@ -#lang scheme/base -(require syntax/kerncase - syntax/stx - (for-syntax scheme/base - scheme/private/sc)) - -(provide unwrap-syntax - - define-pattern-variable - - with-temporaries - generate-temporary - generate-n-temporaries - - current-caught-disappeared-uses - with-catching-disappeared-uses - with-disappeared-uses - syntax-local-value/catch - record-disappeared-uses - - format-symbol - - in-stx-list - in-stx-list/unwrap - - #| - parse-kw-options - extract-kw-option - chunk-kw-seq/no-dups - chunk-kw-seq/no-dups/eol - chunk-kw-seq - reject-duplicate-chunks - check-id - check-nat/f - check-string - check-idlist - |#) - -;; Unwrapping syntax - -;; unwrap-syntax : any #:stop-at (any -> boolean) -> any -(define (unwrap-syntax stx #:stop-at [stop-at (lambda (x) #f)]) - (let loop ([x stx]) - (cond [(stop-at x) x] - [(syntax? x) (loop (syntax-e x))] - [(pair? x) (cons (loop (car x)) (loop (cdr x)))] - [(vector? x) (apply vector-immutable (loop (vector->list x)))] - [(box? x) (box-immutable (loop (unbox x)))] - [(prefab-struct-key x) - => (lambda (key) - (apply make-prefab-struct key - (loop (cdr (vector->list (struct->vector x))))))] - [else x]))) - -;; Defining pattern variables - -(define-syntax-rule (define-pattern-variable name expr) - (begin (define var expr) - (define-syntax name (make-syntax-mapping '0 (quote-syntax var))))) - -;; Statics and disappeared uses - -(define current-caught-disappeared-uses (make-parameter #f)) - -(define-syntax-rule (with-catching-disappeared-uses . body) - (parameterize ((current-caught-disappeared-uses null)) - (let ([result (let () . body)]) - (values result (current-caught-disappeared-uses))))) - -(define-syntax-rule (with-disappeared-uses stx-expr) - (let-values ([(stx disappeared-uses) - (with-catching-disappeared-uses stx-expr)]) - (syntax-property stx - 'disappeared-use - (append (or (syntax-property stx 'disappeared-use) null) - disappeared-uses)))) - -(define (syntax-local-value/catch id pred) - (let ([value (syntax-local-value id (lambda () #f))]) - (and (pred value) - (begin (record-disappeared-uses (list id)) - value)))) - -(define (record-disappeared-uses ids) - (let ([uses (current-caught-disappeared-uses)]) - (when uses - (current-caught-disappeared-uses (append ids uses))))) - -;; Generating temporaries - -;; with-temporaries -(define-syntax-rule (with-temporaries (temp-name ...) . body) - (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) - . body)) - -;; generate-temporary : any -> identifier -(define (generate-temporary [stx 'g]) - (car (generate-temporaries (list stx)))) - -;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier) -(define (generate-n-temporaries n) - (generate-temporaries - (for/list ([i (in-range n)]) - (string->symbol (format "g~sx" i))))) - -;; Symbol Formatting - -(define (format-symbol fmt . args) - (let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))]) - (string->symbol (apply format fmt args)))) - -;; Syntax list sequence - -(define (in-stx-list x) - (let ([l (stx->list x)]) - (unless l - (raise-type-error 'in-stx-list "syntax list" x)) - (in-list l))) - -(define (in-stx-list/unwrap x) - (let ([l (stx->list x)]) - (unless l - (raise-type-error 'in-stx-list "syntax list" x)) - (in-list (map syntax-e l)))) - -;; Parsing keyword arguments - -;; parse-kw-options : ... -(define (parse-kw-options stx table extractions #:context [ctx #f]) - (let ([chunks (chunk-kw-seq/no-dups/eol stx table #:context ctx)]) - (for/list ([ex extractions]) - (extract-kw-option chunks ex)))) - -;; extract-kw-option : ... -(define (extract-kw-option chunks ex) - (let ([entry (assq (car ex) chunks)]) - (if entry - (cddr entry) - (cdr ex)))) - -;; chunk-kw-seq/no-dups/eol : ... -(define (chunk-kw-seq/no-dups/eol stx kws #:context [ctx #f] #:only [only #f]) - (let-values ([(chunks rest) (chunk-kw-seq/no-dups stx kws #:context ctx #:only only)]) - (unless (stx-null? rest) - (raise-syntax-error #f "unexpected terms after keyword arguments" ctx stx)) - chunks)) - -;; chunk-kw-seq/no-dups : syntax -;; alist[keyword => (listof (stx -> any))] -;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) -(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f] #:only [only #f]) - (let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)]) - (reject-duplicate-chunks chunks #:context ctx #:only only) - (values chunks rest))) - -;; chunk-kw-seq : stx -;; alist[keyword => (listof (stx -> any)) -;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) -(define (chunk-kw-seq stx kws #:context [ctx #f]) - (define (loop stx rchunks) - (syntax-case stx () - [(kw . more) - (and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws)) - (let* ([kw-value (syntax-e #'kw)] - [arity (cdr (assq kw-value kws))] - [args+rest (stx-split #'more arity)]) - (if args+rest - (loop (cdr args+rest) - (cons (list* kw-value #'kw (car args+rest)) rchunks)) - (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))] - [(kw . more) - (keyword? (syntax-e #'kw)) - (raise-syntax-error #f - (format "unexpected keyword, expected one of ~s" (map car kws)) - ctx - #'kw)] - [_ - (values (reverse rchunks) stx)])) - (loop stx null)) - -;; reject-duplicate-chunks : (listof (cons kw (cons stx(kw) (listof any)))) -> void -(define (reject-duplicate-chunks chunks - #:context [ctx #f] - #:only [only #f]) - (define kws (make-hasheq)) - (define (loop chunks) - (when (pair? chunks) - (let ([kw (caar chunks)]) - (when (or (not only) (memq kw only)) - (when (hash-ref kws kw #f) - (raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx)) - (hash-set! kws kw #t))) - (loop (cdr chunks)))) - (loop chunks)) - -;; alist-select : (listof (cons A B)) A -> (listof B) -(define (alist-select alist key) - (cond [(pair? alist) - (if (eq? (caar alist) key) - (cons (cdar alist) (alist-select (cdr alist) key)) - (alist-select (cdr alist) key))] - [else null])) - -;; stx-split : stx nat -> (cons (listof stx) stx) -(define (stx-split stx procs) - (define (loop stx procs acc) - (cond [(null? procs) - (cons (reverse acc) stx)] - [(stx-pair? stx) - (loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))] - [else #f])) - (loop stx procs null)) - -;; check-id : stx -> identifier -(define (check-id stx) - (unless (identifier? stx) - (raise-syntax-error 'pattern "expected identifier" stx)) - stx) - -;; check-string : stx -> stx -(define (check-string stx) - (unless (string? (syntax-e stx)) - (raise-syntax-error #f "expected string" stx)) - stx) - -;; nat/f : any -> boolean -(define (nat/f x) - (or (not x) (exact-nonnegative-integer? x))) - -;; check-nat/f : stx -> stx -(define (check-nat/f stx) - (let ([d (syntax-e stx)]) - (unless (nat/f d) - (raise-syntax-error #f "expected exact nonnegative integer or #f" stx)) - stx)) - -;; check-idlist : stx -> (listof identifier) -(define (check-idlist stx) - (unless (and (stx-list? stx) (andmap identifier? (stx->list stx))) - (raise-syntax-error #f "expected list of identifiers" stx)) - (stx->list stx)) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index dae537c7ba..f576dc1d61 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -10,7 +10,7 @@ scheme/contract (for-syntax scheme/list - (only-in syntax/private/util/misc generate-temporary) + (only-in unstable/syntax generate-temporary) scheme/match (except-in syntax/parse id identifier keyword) scheme/base diff --git a/collects/typed-scheme/utils/stxclass-util.ss b/collects/typed-scheme/utils/stxclass-util.ss index 94a75f5f57..cb2372680a 100644 --- a/collects/typed-scheme/utils/stxclass-util.ss +++ b/collects/typed-scheme/utils/stxclass-util.ss @@ -3,7 +3,7 @@ (require (except-in syntax/parse id keyword) (for-syntax syntax/parse scheme/base - (only-in syntax/private/util/misc generate-temporary))) + (only-in unstable/syntax generate-temporary))) (provide (except-out (all-defined-out) id keyword) (rename-out [id id*] [keyword keyword*])) diff --git a/collects/unstable/scribblings/struct.scrbl b/collects/unstable/scribblings/struct.scrbl new file mode 100644 index 0000000000..2480f3facd --- /dev/null +++ b/collects/unstable/scribblings/struct.scrbl @@ -0,0 +1,28 @@ +#lang scribble/manual +@(require scribble/eval + (for-label unstable/struct + scheme/contract + scheme/base)) + +@title[#:tag "struct"]{Structs} + +@(define the-eval (make-base-eval)) +@(the-eval '(require unstable/struct)) + +@defmodule[unstable/struct] + +@defform[(make struct-id expr ...)]{ + +Creates an instance of @scheme[struct-id], which must be bound as a +struct name. The number of @scheme[expr]s is statically checked +against the number of fields associated with @scheme[struct-id]. If +they are different, or if the number of fields is not known, an error +is raised at compile time. + +@examples[#:eval the-eval + (define-struct triple (a b c)) + (make triple 3 4 5) + (make triple 2 4) +] + +} diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl new file mode 100644 index 0000000000..bde7cea404 --- /dev/null +++ b/collects/unstable/scribblings/syntax.scrbl @@ -0,0 +1,194 @@ +#lang scribble/manual +@(require scribble/struct + scribble/decode + scribble/eval + (for-label scheme/base + scheme/contract + unstable/syntax)) + +@(define the-eval (make-base-eval)) +@(the-eval '(require unstable/syntax)) +@(the-eval '(require (for-syntax scheme/base unstable/syntax))) + +@title[#:tag "syntax"]{Syntax} + +@defmodule[unstable/syntax] + +@defparam[current-syntax-context stx (or/c syntax? false/c)]{ + +The current contextual syntax object, defaulting to @scheme[#f]. It +determines the special form name that prefixes syntax errors created +by @scheme[wrong-syntax]. + +@;{ +If it is a syntax object with a @scheme['report-error-as] syntax +property whose value is a symbol, then that symbol is used as the +special form name. Otherwise, the same rules apply as in +@scheme[raise-syntax-error]. +} + +} + +@defproc[(wrong-syntax [stx syntax?] [format-string string?] [v any/c] ...) + any]{ + +Raises a syntax error using the result of +@scheme[(current-syntax-context)] as the ``major'' syntax object and +the provided @scheme[stx] as the specific syntax object. (The latter, +@scheme[stx], is usually the one highlighted by DrScheme.) The error +message is constructed using the format string and arguments, and it +is prefixed with the special form name as described under +@scheme[current-syntax-context]. + +@examples[#:eval the-eval +(wrong-syntax #'here "expected ~s" 'there) +(parameterize ((current-syntax-context #'(look over here))) + (wrong-syntax #'here "expected ~s" 'there)) +] + +A macro using @scheme[wrong-syntax] might set the syntax context at the very +beginning of its transformation as follows: +@SCHEMEBLOCK[ +(define-syntax (my-macro stx) + (parameterize ((current-syntax-context stx)) + (syntax-case stx () + ___))) +] +Then any calls to @scheme[wrong-syntax] during the macro's +transformation will refer to @scheme[my-macro] (more precisely, the name that +referred to @scheme[my-macro] where the macro was used, which may be +different due to renaming, prefixing, etc). + +@;{ +A macro that expands into a helper macro can insert its own name into +syntax errors raised by the helper macro by installing a +@scheme['report-error-as] syntax property on the helper macro +expression. + +@examples[#:eval the-eval +(define-syntax (public-macro stx) + (syntax-case stx () + [(public-macro stuff) + (syntax-property #'(private-macro stuff) + 'report-error-as + (syntax-e #'public-macro))])) +(define-syntax (private-macro stx) + (parameterize ((current-syntax-context stx)) + (syntax-case stx () + [(private-macro arg) + (wrong-syntax #'arg "just no good")]))) +(public-macro 5) +] +} + +} + +@;{----} + +@defform[(define-pattern-variable id expr)]{ + +Evaluates @scheme[expr] and binds it to @scheme[id] as a pattern +variable, so @scheme[id] can be used in subsequent @scheme[syntax] +patterns. + +@examples[#:eval the-eval + (define-pattern-variable name #'Alice) + #'(hello name) +] + +} + +@;{----} + +@defform[(with-temporaries (temp-id ...) . body)]{ + +Evaluates @scheme[body] with each @scheme[temp-id] bound as a pattern +variable to a freshly generated identifier. + +@examples[#:eval the-eval + (with-temporaries (x) #'(lambda (x) x)) +] + +} + +@defproc[(generate-temporary [name-base any/c 'g]) identifier?]{ + +Generates one fresh identifier. Singular form of +@scheme[generate-temporaries]. If @scheme[name-base] is supplied, it +is used as the basis for the identifier's name. + +} + +@defproc[(generate-n-temporaries [n exact-nonnegative-integer?]) + (listof identifier?)]{ + +Generates a list of @scheme[n] fresh identifiers. + +} + +@;{----} + +@defparam[current-caught-disappeared-uses ids + (or/c (listof identifier?) false/c)]{ + +Parameter for tracking disappeared uses. Tracking is ``enabled'' when +the parameter has a non-false value. This is done automatically by +forms like @scheme[with-disappeared-uses]. + +} + +@defform[(with-disappeared-uses stx-expr) + #:contracts ([stx-expr syntax?])]{ + +Evaluates the @scheme[stx-expr], catching identifiers looked up using +@scheme[syntax-local-value/catch]. Adds the caught identifiers to the +@scheme['disappeared-uses] syntax property of the resulting syntax +object. + +} + +@defform[(with-catching-disappeared-uses body-expr)]{ + +Evaluates the @scheme[body-expr], catching identifiers looked up using +@scheme[syntax-local-value/catch]. Returns two values: the result of +@scheme[body-expr] and the list of caught identifiers. + +} + +@defproc[(syntax-local-value/catch [id identifier?] [predicate (-> any/c boolean?)]) + any/c]{ + +Looks up @scheme[id] in the syntactic environment (as +@scheme[syntax-local-value]). If the lookup succeeds and returns a +value satisfying the predicate, the value is returned and @scheme[id] +is recorded (``caught'') as a disappeared use. If the lookup fails or +if the value does not satisfy the predicate, @scheme[#f] is returned +and the identifier is not recorded as a disappeared use. + +If not used within the extent of a @scheme[with-disappeared-uses] form +or similar, has no effect. + +} + +@defproc[(record-disappeared-uses [ids (listof identifier?)]) + void?]{ + +Add @scheme[ids] to the current disappeared uses. + +If not used within the extent of a @scheme[with-disappeared-uses] form +or similar, has no effect. + +} + +@;{----} + +@defproc[(format-symbol [fmt string?] [v any/c] ...) + symbol?]{ + +Like @scheme[format], but produces a symbol. + +@examples[#:eval the-eval + (format-symbol "make-~s" 'triple) +] + +} diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 96fd95e919..ea345570f8 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -78,6 +78,8 @@ Keep documentation and tests up to date. @include-section["net.scrbl"] @include-section["path.scrbl"] @include-section["string.scrbl"] +@include-section["struct.scrbl"] +@include-section["syntax.scrbl"] @;{--------} diff --git a/collects/syntax/private/util/struct.ss b/collects/unstable/struct.ss similarity index 98% rename from collects/syntax/private/util/struct.ss rename to collects/unstable/struct.ss index 5073815048..ecd20380f7 100644 --- a/collects/syntax/private/util/struct.ss +++ b/collects/unstable/struct.ss @@ -1,7 +1,7 @@ #lang scheme/base +;; owner: ryanc (require (for-syntax scheme/base scheme/struct-info)) - (provide make) ;; (make struct-name field-expr ...) diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss new file mode 100644 index 0000000000..87c4a23c2d --- /dev/null +++ b/collects/unstable/syntax.ss @@ -0,0 +1,113 @@ +#lang scheme/base +;; owner: ryanc +(require syntax/kerncase + syntax/stx + (for-syntax scheme/base + scheme/private/sc)) + +(provide unwrap-syntax + + define-pattern-variable + + with-temporaries + generate-temporary + generate-n-temporaries + + current-caught-disappeared-uses + with-catching-disappeared-uses + with-disappeared-uses + syntax-local-value/catch + record-disappeared-uses + + format-symbol + + current-syntax-context + wrong-syntax) + +;; Unwrapping syntax + +;; unwrap-syntax : any #:stop-at (any -> boolean) -> any +(define (unwrap-syntax stx #:stop-at [stop-at (lambda (x) #f)]) + (let loop ([x stx]) + (cond [(stop-at x) x] + [(syntax? x) (loop (syntax-e x))] + [(pair? x) (cons (loop (car x)) (loop (cdr x)))] + [(vector? x) (apply vector-immutable (loop (vector->list x)))] + [(box? x) (box-immutable (loop (unbox x)))] + [(prefab-struct-key x) + => (lambda (key) + (apply make-prefab-struct key + (loop (cdr (vector->list (struct->vector x))))))] + [else x]))) + +;; Defining pattern variables + +(define-syntax-rule (define-pattern-variable name expr) + (begin (define var expr) + (define-syntax name (make-syntax-mapping '0 (quote-syntax var))))) + +;; Statics and disappeared uses + +(define current-caught-disappeared-uses (make-parameter #f)) + +(define-syntax-rule (with-catching-disappeared-uses . body) + (parameterize ((current-caught-disappeared-uses null)) + (let ([result (let () . body)]) + (values result (current-caught-disappeared-uses))))) + +(define-syntax-rule (with-disappeared-uses stx-expr) + (let-values ([(stx disappeared-uses) + (with-catching-disappeared-uses stx-expr)]) + (syntax-property stx + 'disappeared-use + (append (or (syntax-property stx 'disappeared-use) null) + disappeared-uses)))) + +(define (syntax-local-value/catch id pred) + (let ([value (syntax-local-value id (lambda () #f))]) + (and (pred value) + (begin (record-disappeared-uses (list id)) + value)))) + +(define (record-disappeared-uses ids) + (let ([uses (current-caught-disappeared-uses)]) + (when uses + (current-caught-disappeared-uses (append ids uses))))) + +;; Generating temporaries + +;; with-temporaries +(define-syntax-rule (with-temporaries (temp-name ...) . body) + (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) + . body)) + +;; generate-temporary : any -> identifier +(define (generate-temporary [stx 'g]) + (car (generate-temporaries (list stx)))) + +;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier) +(define (generate-n-temporaries n) + (generate-temporaries + (for/list ([i (in-range n)]) + (string->symbol (format "g~sx" i))))) + +;; Symbol Formatting + +(define (format-symbol fmt . args) + (let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))]) + (string->symbol (apply format fmt args)))) + +;; Error reporting + +(define current-syntax-context (make-parameter #f)) + +(define (wrong-syntax stx #:extra [extras null] format-string . args) + (unless (or (eq? stx #f) (syntax? stx)) + (raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args))) + (let* ([ctx (current-syntax-context)] + [blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))]) + (raise-syntax-error (if (symbol? blame) blame #f) + (apply format format-string args) + ctx + stx + extras)))