unstable/syntax: renamed syntax-local-values/{catch -> record}, changed uses
also added comments to some unstable/syntax functions
This commit is contained in:
parent
a91e9e7bf6
commit
8c42006ad7
|
@ -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)
|
||||
|
|
|
@ -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")])))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))].
|
||||
|
||||
}
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user