diff --git a/collects/redex/private/term.rkt b/collects/redex/private/term.rkt index bda4c28747..b932b72809 100644 --- a/collects/redex/private/term.rkt +++ b/collects/redex/private/term.rkt @@ -54,7 +54,7 @@ [(metafunc-name arg ...) (and (identifier? (syntax metafunc-name)) (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) - (rewrite-application (term-fn-get-id (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t))) + (rewrite-application (term-fn-get-id (syntax-local-value/record (syntax metafunc-name) (λ (x) #t))) (syntax/loc stx (arg ...)) depth)] [f @@ -64,7 +64,7 @@ [x (and (identifier? (syntax x)) (term-id? (syntax-local-value (syntax x) (λ () #f)))) - (let ([id (syntax-local-value/catch (syntax x) (λ (x) #t))]) + (let ([id (syntax-local-value/record (syntax x) (λ (x) #t))]) (values (datum->syntax (term-id-id id) (syntax-e (term-id-id id)) (syntax x)) (term-id-depth id)))] [(unquote x) diff --git a/collects/syntax/private/stxparse/rep-data.rkt b/collects/syntax/private/stxparse/rep-data.rkt index 97ddd9c02b..dea6735990 100644 --- a/collects/syntax/private/stxparse/rep-data.rkt +++ b/collects/syntax/private/stxparse/rep-data.rkt @@ -260,7 +260,7 @@ DeclEntry = (define config (stxclass-lookup-config)) (if (eq? config 'no) (make-dummy-stxclass id) - (cond [(syntax-local-value/catch id stxclass?) => values] + (cond [(syntax-local-value/record id stxclass?) => values] [(eq? config 'try) (make-dummy-stxclass id)] [else (wrong-syntax id "not defined as syntax class")]))) diff --git a/collects/syntax/private/stxparse/rep.rkt b/collects/syntax/private/stxparse/rep.rkt index 7f849a324d..16b81895b7 100644 --- a/collects/syntax/private/stxparse/rep.rkt +++ b/collects/syntax/private/stxparse/rep.rkt @@ -1054,7 +1054,7 @@ ;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase^2)) (define (check-literal-set-entry stx ctx) (define (elaborate litset-id lctx phase) - (let ([litset (syntax-local-value/catch litset-id literalset?)]) + (let ([litset (syntax-local-value/record litset-id literalset?)]) (unless litset (raise-syntax-error #f "expected identifier defined as a literal-set" ctx litset-id)) @@ -1093,7 +1093,7 @@ ;; returns (cons Conventions (listof syntax)) (define (check-conventions stx ctx) (define (elaborate conventions-id args) - (let ([cs (syntax-local-value/catch conventions-id conventions?)]) + (let ([cs (syntax-local-value/record conventions-id conventions?)]) (unless cs (raise-syntax-error #f "expected identifier defined as a conventions" ctx conventions-id)) diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index 6c899cc2df..6aa7b20fda 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -146,7 +146,7 @@ Generates a list of @racket[n] fresh identifiers. @;{----} -@defparam[current-caught-disappeared-uses ids +@defparam[current-recorded-disappeared-uses ids (or/c (listof identifier?) false/c)]{ Parameter for tracking disappeared uses. Tracking is ``enabled'' when @@ -165,33 +165,22 @@ object. } -@defform[(with-catching-disappeared-uses body-expr)]{ - -Evaluates the @racket[body-expr], catching identifiers looked up using -@racket[syntax-local-value/catch]. Returns two values: the result of -@racket[body-expr] and the list of caught identifiers. - -} - -@defproc[(syntax-local-value/catch [id identifier?] [predicate (-> any/c boolean?)]) +@defproc[(syntax-local-value/record [id identifier?] [predicate (-> any/c boolean?)]) any/c]{ Looks up @racket[id] in the syntactic environment (as @racket[syntax-local-value]). If the lookup succeeds and returns a value satisfying the predicate, the value is returned and @racket[id] -is recorded (``caught'') as a disappeared use. If the lookup fails or -if the value does not satisfy the predicate, @racket[#f] is returned -and the identifier is not recorded as a disappeared use. - -If not used within the extent of a @racket[with-disappeared-uses] form -or similar, has no effect. +is recorded as a disappeared use. If the lookup fails or if the value +does not satisfy the predicate, @racket[#f] is returned and the +identifier is not recorded as a disappeared use. } @defproc[(record-disappeared-uses [ids (listof identifier?)]) void?]{ -Add @racket[ids] to the current disappeared uses. +Add @racket[ids] to @racket[(current-recorded-disappeared-uses)]. If not used within the extent of a @racket[with-disappeared-uses] form or similar, has no effect. @@ -408,7 +397,12 @@ object referring to one identifier into a syntax object referring to another. } -@defproc[(head-expand [stx syntax?] [stop-list (listof identifier?)]) syntax?]{ +@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 @@ -416,7 +410,7 @@ 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) #f))]. +stop-ids (kernel-form-identifier-list) intdef-ctx))]. } diff --git a/collects/unstable/syntax.rkt b/collects/unstable/syntax.rkt index dc5adb4d12..ec2fbc0f60 100644 --- a/collects/unstable/syntax.rkt +++ b/collects/unstable/syntax.rkt @@ -17,10 +17,9 @@ generate-temporary generate-n-temporaries - current-caught-disappeared-uses - with-catching-disappeared-uses + current-recorded-disappeared-uses with-disappeared-uses - syntax-local-value/catch + syntax-local-value/record record-disappeared-uses format-symbol @@ -54,8 +53,8 @@ ;; Unwrapping syntax -;; unwrap-syntax : any #:stop-at (any -> boolean) -> any -(define (unwrap-syntax stx #:stop-at [stop-at (lambda (x) #f)]) +;; 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))] @@ -70,6 +69,7 @@ ;; 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. ;; Defining pattern variables @@ -79,31 +79,28 @@ ;; 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 current-recorded-disappeared-uses (make-parameter #f)) (define-syntax-rule (with-disappeared-uses stx-expr) (let-values ([(stx disappeared-uses) - (with-catching-disappeared-uses stx-expr)]) + (parameterize ((current-recorded-disappeared-uses null)) + (let ([result stx-expr]) + (values result (current-recorded-disappeared-uses))))]) (syntax-property stx 'disappeared-use (append (or (syntax-property stx 'disappeared-use) null) disappeared-uses)))) -(define (syntax-local-value/catch id pred) +(define (syntax-local-value/record 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)]) + (let ([uses (current-recorded-disappeared-uses)]) (when uses - (current-caught-disappeared-uses (append ids uses))))) + (current-recorded-disappeared-uses (append ids uses))))) ;; Generating temporaries @@ -152,23 +149,6 @@ ;; single syntax among its inputs, and will use it for the context etc, or ;; throw an error if there's more or less than 1. -#| -(define (id-append #:source [src #f] - #:props [props #f] - #:cert [cert #f] - . args) - (define stxs (filter syntax? args)) - (define lctx - (cond [(and (pair? stxs) (null? (cdr stxs))) - (car stxs)] - [(error 'id-append "expected exactly one identifier in arguments: ~e" args)])) - (define (convert x) (->atom x 'id-append)) - (define sym (string->symbol (apply string-append (map convert args)))) - (datum->syntax lctx sym src props cert)) -;; Eli: Yes, that looks nice (with the same comments as above on the keyword -;; args). It makes more sense with the restriction on the format string. -|# - (define (restricted-format-string? fmt) (regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt)) @@ -205,6 +185,7 @@ extras))) ;; Eli: The `report-error-as' thing seems arbitrary to me. +;; Applies the renaming of intdefs to stx. (define (internal-definition-context-apply intdefs stx) (let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)]) (with-syntax ([(q astx) qastx]) #'astx))) @@ -244,6 +225,7 @@ (define-syntax pvar (make-syntax-mapping 'depth (quote-syntax valvar))) ...)))])) +;; Ryan: alternative name: define/syntax-pattern ?? ;; auxiliary macro (define-syntax (pvar-value stx) @@ -342,11 +324,12 @@ "expected an identifier (alone or in application position); cannot redirect to ~a" (syntax-e id))])) -(define (head-expand stx [stop-ids null]) +(define (head-expand stx [stop-ids null] [intdef-ctx #f]) (local-expand stx (syntax-local-context) (append stop-ids (kernel-form-identifier-list)) - #f)) + intdef-ctx)) +;; Ryan: added intdef-ctx optional arg (define (quote-transformer datum) #`(quasiquote