diff --git a/collects/tests/unstable/syntax.rkt b/collects/tests/unstable/syntax.rkt index 3857a1439b..2804963ee0 100644 --- a/collects/tests/unstable/syntax.rkt +++ b/collects/tests/unstable/syntax.rkt @@ -30,28 +30,6 @@ (test-case "identifiers to symbols" (check-equal? (syntax-map syntax-e #'(a b c)) '(a b c))))) - (test-suite "Syntax Conversions" - - (test-suite "to-syntax" - (test-case "symbol + context = identifier" - (check bound-identifier=? - (to-syntax #:stx #'context 'id) - #'id))) - - (test-suite "to-datum" - (test-case "syntax" - (check-equal? (to-datum #'((a b) () (c))) - '((a b) () (c)))) - (test-case "non-syntax" - (check-equal? (to-datum '((a b) () (c))) - '((a b) () (c)))) - (test-case "nested syntax" - (let* ([stx-ab #'(a b)] - [stx-null #'()] - [stx-c #'(c)]) - (check-equal? (to-datum (list stx-ab stx-null stx-c)) - (list stx-ab stx-null stx-c)))))) - (test-suite "Syntax Source Locations" (test-suite "syntax-source-file-name" @@ -70,22 +48,6 @@ (check-equal? (syntax-source-directory (datum->syntax #f 'fail)) #f)))) - (test-suite "Transformers" - - (test-suite "redirect-transformer" - (test (check-equal? - (syntax->datum ((redirect-transformer #'x) #'y)) - 'x)) - (test (check-equal? - (syntax->datum ((redirect-transformer #'x) #'(y z))) - '(x z)))) - - (test-suite "head-expand") - - (test-suite "trampoline-transformer") - - (test-suite "quote-transformer")) - (test-suite "Pattern Bindings" (test-suite "with-syntax*" diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index 6074474063..0ff4f4d2ce 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -20,24 +20,6 @@ @;{----} -@defform[(with-temporaries (temp-id ...) . body)]{ - -Evaluates @racket[body] with each @racket[temp-id] bound as a pattern -variable to a freshly generated identifier. - -@examples[#:eval the-eval - (with-temporaries (x) #'(lambda (x) x)) -] -} - -@defproc[(generate-n-temporaries [n exact-nonnegative-integer?]) - (listof identifier?)]{ - -Generates a list of @racket[n] fresh identifiers. -} - -@;{----} - @margin-note{This binding was added by Vincent St-Amour.} @defproc[(format-unique-id [lctx (or/c syntax? #f)] [#:source src (or/c syntax? #f) #f] @@ -71,44 +53,8 @@ is equivalent to @scheme[(syntax->list (syntax (template ...)))]. #:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax) (with-syntax ([(x ...) (syntax (1 2 3))]) (syntax-list x ...)) ] - } -@defproc[(to-syntax [datum any/c] - [#:stx stx (or/c false/c syntax?) #f] - [#:src src src/c stx] - [#:ctxt ctxt (or/c false/c syntax?) stx] - [#:prop prop (or/c false/c syntax?) stx] - [#:cert cert (or/c false/c syntax?) stx]) - syntax?]{ - -A wrapper for @scheme[datum->syntax] with keyword arguments. - -The "master" keyword @scheme[#:stx] sets all attributes from a single syntax -object, defaulting to @scheme[#f] for unadorned syntax objects. - -The individual keywords @scheme[#:src], @scheme[#:ctxt], @scheme[#:prop], and -@scheme[#:cert] override @scheme[#:stx] for individual syntax object -attributes. They control source src information, lexical context -information, syntax object properties, and syntax certificates, respectively. - -@defexamples[ -#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax) -(define blank-stx (to-syntax 'car)) -blank-stx -(syntax-e blank-stx) -(free-identifier=? blank-stx #'car) -(define full-stx (to-syntax 'car #:stx #'here)) -full-stx -(syntax-e full-stx) -(free-identifier=? full-stx #'car) -(define partial-stx (to-syntax 'car #:ctxt #'here)) -partial-stx -(syntax-e partial-stx) -(free-identifier=? partial-stx #'car) -] - -} @section{Syntax Object Source Locations} @@ -133,101 +79,6 @@ with a path. (syntax-source-directory stx2) (syntax-source-directory stx2) ] - -} - -@section{Macro Transformers} - -@defproc[(redirect-transformer [id identifier?]) (-> syntax? syntax?)]{ - -Constructs a function that behaves like a rename transformer; it does not -cooperate with @scheme[syntax-local-value] like a rename transformer does, but -unlike a rename transformer it may be used as a function to transform a syntax -object referring to one identifier into a syntax object referring to another. - -@defexamples[ -#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax) -((redirect-transformer #'x) #'a) -((redirect-transformer #'y) #'(a b c)) -] - -} - -@defproc[(head-expand [stx syntax?] - [stop-list (listof identifier?) null] - [intdef-ctx (or/c internal-definitions-context? - (non-empty-listof internal-definitions-context?) - #f)]) - syntax?]{ - -This function performs head expansion on @scheme[stx]. In other words, it uses -@scheme[local-expand] to expand @scheme[stx] until its head identifier is a core -form (a member of @scheme[(kernel-form-identifier-list)]) or a member of -@scheme[stop-list], or until it can not be expanded further (e.g. due to error). - -It is equivalent to @scheme[(local-expand stx (syntax-local-context) (append -stop-ids (kernel-form-identifier-list) intdef-ctx))]. - -} - -@defproc[(trampoline-transformer - [f (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?)]) - (-> syntax? syntax?)]{ - -Produces a transformer that can emit multiple results during macro expansion, to -be spliced together via @scheme[begin]. This can be useful for compound -expansion that relies on transformer definitions, as well as on expansion state -that is difficult to marshall. - -Specifically, @scheme[f] is invoked with three arguments. The first is the -function used to emit intermediate results (other than the last one). The -second applies the @tech[#:doc '(lib -"scribblings/reference/reference.scrbl")]{syntax mark} used for the entire -expansion; @scheme[syntax-local-introduce] will not be reliable during this -process. The third is the syntax object to expand. - -@defexamples[ -#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax) -(define-syntax magic-begin - (trampoline-transformer - (lambda (emit intro stx) - (syntax-case stx () - [(_ term ...) - (let loop ([terms (syntax->list #'(term ...))]) - (cond - [(null? terms) #'(begin)] - [(null? (cdr terms)) (car terms)] - [else - (printf "Presto: ~s!\n" - (syntax->datum (car terms))) - (emit (car terms)) - (loop (cdr terms))]))])))) -(magic-begin - (define x 1) - (define y 2) - (+ x y)) -] - -} - -@defproc[(quote-transformer [x any/c]) syntax?]{ - -Produces a syntax object representing an expression that reconstructs @scheme[x] -when executed, including faithfully reconstructing any syntax objects contained -in @scheme[x]. Note that @scheme[quote] normally converts syntax objects to -non-syntax data, and @scheme[quote-syntax] does the opposite. - -@defexamples[ -#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax) -(define-for-syntax x (list 1 #'(2 3) 4)) -(define-syntax (the-many-faces-of-x stx) - (with-syntax ([x x] [qx (quote-transformer x)]) - #'(list (quote x) - (quote-syntax x) - qx))) -(the-many-faces-of-x) -] - } @close-eval[the-eval] diff --git a/collects/unstable/syntax.rkt b/collects/unstable/syntax.rkt index 0c8cf52420..c34bbbb18b 100644 --- a/collects/unstable/syntax.rkt +++ b/collects/unstable/syntax.rkt @@ -1,68 +1,19 @@ #lang racket/base ;; owner: ryanc (and cce and stamourv, where noted) (require racket/syntax - syntax/kerncase - syntax/stx - unstable/struct - unstable/srcloc - (for-syntax racket/base) - (for-template racket/base unstable/private/expand)) + syntax/stx) -(provide unwrap-syntax - with-temporaries - syntax-map +(provide (rename-out [stx-map syntax-map]) + syntax-list ;; by cce: - to-syntax - to-datum - syntax-source-file-name syntax-source-directory - trampoline-transformer - quote-transformer - redirect-transformer - head-expand - - syntax-list - ;; by stamourv: - - format-unique-id - ) - -;; Unwrapping syntax - -;; unwrap-syntax : any #:stop (any -> boolean) -> any -(define (unwrap-syntax stx #:stop [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 (struct->list x))))] - [else x]))) -;; Eli: Is there any difference between this (with the default) and -;; `syntax->datum'? If not, then maybe add the optional (or keyword) to -;; there instead? -;; Ryan: syntax->datum errors if its arg is not syntax. - -;; Generating temporaries - -;; with-temporaries -(define-syntax-rule (with-temporaries (temp-name ...) . body) - (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) - . body)) -;; Eli: +1 to this, not sure about the next two - -(define (syntax-map f . stxls) - (apply map f (map syntax->list stxls))) + format-unique-id) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -79,31 +30,6 @@ (define-syntax-rule (syntax-list template ...) (syntax->list (syntax (template ...)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Syntax Conversions -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (to-syntax datum - #:stx [stx #f] - #:src [src stx] - #:ctxt [ctxt stx] - #:prop [prop stx] - #:cert [cert stx]) - (datum->syntax ctxt - datum - (if (srcloc? src) (build-source-location-list src) src) - prop - cert)) - -;; Slightly different from unwrap-syntax, -;; in that it doesn't traverse anything that isn't immediately syntax. -;; At some point we should pick one of the other or a combination, -;; both is probably overkill. -(define (to-datum v) - (if (syntax? v) (syntax->datum v) v)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Syntax Locations @@ -124,82 +50,7 @@ (and (path-string? f) (let-values ([(base file dir?) (split-path f)]) file)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Transformer Patterns -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define ((redirect-transformer id) stx) - (cond - [(identifier? stx) id] - [(and (stx-pair? stx) (identifier? (stx-car stx))) - (to-syntax (cons id (stx-cdr stx)) #:stx stx)] - [else - (wrong-syntax - stx - "expected an identifier (alone or in application position); cannot redirect to ~a" - (syntax-e id))])) - -(define (head-expand stx [stop-ids null] [intdef-ctx #f]) - (local-expand stx - (syntax-local-context) - (append stop-ids (kernel-form-identifier-list)) - intdef-ctx)) -;; Ryan: added intdef-ctx optional arg - -(define (quote-transformer datum) - #`(quasiquote - #,(let loop ([datum datum]) - (cond - [(syntax? datum) #`(unquote (quote-syntax #,datum))] - [(pair? datum) #`#,(cons (loop (car datum)) (loop (cdr datum)))] - [(vector? datum) - #`#,(apply vector-immutable (map loop (vector->list datum)))] - [(box? datum) #`#,(box (loop (unbox datum)))] - [(hash? datum) - #`#,((cond [(hash-eqv? datum) make-immutable-hasheqv] - [(hash-eq? datum) make-immutable-hasheq] - [else make-immutable-hash]) - (hash-map datum (lambda (k v) (cons k (loop v)))))] - [(prefab-struct-key datum) => - (lambda (key) - #`#,(apply make-prefab-struct - key - (for/list ([i (in-vector (struct->vector datum) 1)]) - (loop i))))] - [else #`#,datum])))) - -(define trampoline-prompt-tag - (make-continuation-prompt-tag 'trampoline)) - -(define ((trampoline-transformer transform) stx) - - (define intro (make-syntax-introducer)) - - (define (body) - (syntax-local-introduce - (intro - (transform (trampoline-evaluator intro) - intro - (intro (syntax-local-introduce stx)))))) - - (call-with-continuation-prompt body trampoline-prompt-tag)) - -(define ((trampoline-evaluator intro) stx) - - (define ((wrap continue)) - (call-with-continuation-prompt continue trampoline-prompt-tag)) - - (define ((expander continue)) - #`(begin #,(syntax-local-introduce (intro stx)) - (#%trampoline #,(wrap continue)))) - - (define (body continue) - (abort-current-continuation trampoline-prompt-tag (expander continue))) - - (call-with-composable-continuation body trampoline-prompt-tag) - (void)) +;; by stamourv: (define (format-unique-id lctx #:source [src #f]