add some missing syntax-protects
Add `syntax-protect` to some macro expansions, especially macros in contex where unsafe operations are imported, which means that a combination of `local-expand` and `datum->syntaxa could provide access to the unsafe bindings absent `syntax-protect`.
This commit is contained in:
Matthew Flatt
parent
685a1ff040
commit
1c299e99db
|
|
@ -12,24 +12,29 @@
|
|||
(define-syntax (case stx)
|
||||
(syntax-case stx (else)
|
||||
;; Empty case
|
||||
[(_ v) (syntax/loc stx (#%expression (begin v (void))))]
|
||||
[(_ v)
|
||||
(syntax-protect
|
||||
(syntax/loc stx (#%expression (begin v (void)))))]
|
||||
|
||||
;; Else-only case
|
||||
[(_ v [else e es ...])
|
||||
(syntax/loc stx (#%expression (begin v (let-values () e es ...))))]
|
||||
(syntax-protect
|
||||
(syntax/loc stx (#%expression (begin v (let-values () e es ...)))))]
|
||||
|
||||
;; If we have a syntactically correct form without an 'else' clause,
|
||||
;; add the default 'else' and try again.
|
||||
[(self v [(k ...) e1 e2 ...] ...)
|
||||
(syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)]))]
|
||||
(syntax-protect
|
||||
(syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)])))]
|
||||
|
||||
;; The general case
|
||||
[(_ v [(k ...) e1 e2 ...] ... [else x1 x2 ...])
|
||||
(if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*)
|
||||
(syntax/loc stx (let ([tmp v])
|
||||
(case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))
|
||||
(syntax/loc stx (let ([tmp v])
|
||||
(case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...]))))]
|
||||
(syntax-protect
|
||||
(if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*)
|
||||
(syntax/loc stx (let ([tmp v])
|
||||
(case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))
|
||||
(syntax/loc stx (let ([tmp v])
|
||||
(case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))))]
|
||||
|
||||
;; Error cases
|
||||
[(_ v clause ...)
|
||||
|
|
@ -83,23 +88,27 @@
|
|||
(define-syntax (case/sequential stx)
|
||||
(syntax-case stx (else)
|
||||
[(_ v [(k ...) es ...] arms ... [else xs ...])
|
||||
#'(if (case/sequential-test v (k ...))
|
||||
(let-values () es ...)
|
||||
(case/sequential v arms ... [else xs ...]))]
|
||||
(syntax-protect
|
||||
#'(if (case/sequential-test v (k ...))
|
||||
(let-values () es ...)
|
||||
(case/sequential v arms ... [else xs ...])))]
|
||||
[(_ v [(k ...) es ...] [else xs ...])
|
||||
#'(if (case/sequential-test v (k ...))
|
||||
(let-values () es ...)
|
||||
(let-values () xs ...))]
|
||||
(syntax-protect
|
||||
#'(if (case/sequential-test v (k ...))
|
||||
(let-values () es ...)
|
||||
(let-values () xs ...)))]
|
||||
[(_ v [else xs ...])
|
||||
#'(let-values () xs ...)]))
|
||||
(syntax-protect
|
||||
#'(let-values () xs ...))]))
|
||||
|
||||
(define-syntax (case/sequential-test stx)
|
||||
(syntax-case stx ()
|
||||
[(_ v ()) #'#f]
|
||||
[(_ v (k)) #`(equal? v 'k)]
|
||||
[(_ v (k ks ...)) #`(if (equal? v 'k)
|
||||
#t
|
||||
(case/sequential-test v (ks ...)))]))
|
||||
(syntax-protect
|
||||
(syntax-case stx ()
|
||||
[(_ v ()) #'#f]
|
||||
[(_ v (k)) #`(equal? v 'k)]
|
||||
[(_ v (k ks ...)) #`(if (equal? v 'k)
|
||||
#t
|
||||
(case/sequential-test v (ks ...)))])))
|
||||
|
||||
;; Triple-dispatch case:
|
||||
;; (1) From the type of the value to a type-specific mechanism for
|
||||
|
|
@ -109,29 +118,30 @@
|
|||
(define-syntax (case/dispatch stx)
|
||||
(syntax-case stx (else)
|
||||
[(_ v [(k ...) es ...] ... [else xs ...])
|
||||
#`(let ([index
|
||||
#,(let* ([ks (partition-constants #'((k ...) ...))]
|
||||
[exp #'0]
|
||||
[exp (if (null? (consts-other ks))
|
||||
exp
|
||||
(dispatch-other #'v (consts-other ks) exp))]
|
||||
[exp (if (null? (consts-char ks))
|
||||
exp
|
||||
#`(if (char? v)
|
||||
#,(dispatch-char #'v (consts-char ks))
|
||||
#,exp))]
|
||||
[exp (if (null? (consts-symbol ks))
|
||||
exp
|
||||
#`(if #,(test-for-symbol #'v (consts-symbol ks))
|
||||
#,(dispatch-symbol #'v (consts-symbol ks) #'0)
|
||||
#,exp))]
|
||||
[exp (if (null? (consts-fixnum ks))
|
||||
exp
|
||||
#`(if (fixnum? v)
|
||||
#,(dispatch-fixnum #'v (consts-fixnum ks))
|
||||
#,exp))])
|
||||
exp)])
|
||||
#,(index-binary-search #'index #'([xs ...] [es ...] ...)))]))
|
||||
(syntax-protect
|
||||
#`(let ([index
|
||||
#,(let* ([ks (partition-constants #'((k ...) ...))]
|
||||
[exp #'0]
|
||||
[exp (if (null? (consts-other ks))
|
||||
exp
|
||||
(dispatch-other #'v (consts-other ks) exp))]
|
||||
[exp (if (null? (consts-char ks))
|
||||
exp
|
||||
#`(if (char? v)
|
||||
#,(dispatch-char #'v (consts-char ks))
|
||||
#,exp))]
|
||||
[exp (if (null? (consts-symbol ks))
|
||||
exp
|
||||
#`(if #,(test-for-symbol #'v (consts-symbol ks))
|
||||
#,(dispatch-symbol #'v (consts-symbol ks) #'0)
|
||||
#,exp))]
|
||||
[exp (if (null? (consts-fixnum ks))
|
||||
exp
|
||||
#`(if (fixnum? v)
|
||||
#,(dispatch-fixnum #'v (consts-fixnum ks))
|
||||
#,exp))])
|
||||
exp)])
|
||||
#,(index-binary-search #'index #'([xs ...] [es ...] ...))))]))
|
||||
|
||||
|
||||
(begin-for-syntax
|
||||
|
|
|
|||
|
|
@ -32,52 +32,53 @@
|
|||
;; needed for Typed Racket
|
||||
(protect-out do-make-object find-method/who))
|
||||
(define-syntax (provide-public-names stx)
|
||||
(datum->syntax
|
||||
stx
|
||||
'(provide class class* class/derived
|
||||
define-serializable-class define-serializable-class*
|
||||
class?
|
||||
mixin
|
||||
interface interface* interface?
|
||||
object% object? externalizable<%> printable<%> writable<%> equal<%>
|
||||
object=? object-or-false=? object=-hash-code
|
||||
new make-object instantiate
|
||||
send send/apply send/keyword-apply send* send+ dynamic-send
|
||||
class-field-accessor class-field-mutator with-method
|
||||
get-field set-field! field-bound? field-names
|
||||
dynamic-get-field dynamic-set-field!
|
||||
private* public* pubment*
|
||||
override* overment*
|
||||
augride* augment*
|
||||
public-final* override-final* augment-final*
|
||||
define/private define/public define/pubment
|
||||
define/override define/overment
|
||||
define/augride define/augment
|
||||
define/public-final define/override-final define/augment-final
|
||||
define-local-member-name define-member-name
|
||||
member-name-key generate-member-key
|
||||
member-name-key? member-name-key=? member-name-key-hash-code
|
||||
generic make-generic send-generic
|
||||
is-a? subclass? implementation? interface-extension?
|
||||
object-interface object-info object->vector
|
||||
object-method-arity-includes?
|
||||
method-in-interface? interface->method-names class->interface class-info
|
||||
(struct-out exn:fail:object)
|
||||
make-primitive-class
|
||||
class/c ->m ->*m ->dm case->m object/c instanceof/c
|
||||
dynamic-object/c
|
||||
class-seal class-unseal
|
||||
|
||||
;; "keywords":
|
||||
private public override augment
|
||||
pubment overment augride
|
||||
public-final override-final augment-final
|
||||
field init init-field init-rest
|
||||
rename-super rename-inner inherit inherit/super inherit/inner inherit-field
|
||||
this this% super inner
|
||||
super-make-object super-instantiate super-new
|
||||
inspect absent abstract)
|
||||
stx))
|
||||
(class-syntax-protect
|
||||
(datum->syntax
|
||||
stx
|
||||
'(provide class class* class/derived
|
||||
define-serializable-class define-serializable-class*
|
||||
class?
|
||||
mixin
|
||||
interface interface* interface?
|
||||
object% object? externalizable<%> printable<%> writable<%> equal<%>
|
||||
object=? object-or-false=? object=-hash-code
|
||||
new make-object instantiate
|
||||
send send/apply send/keyword-apply send* send+ dynamic-send
|
||||
class-field-accessor class-field-mutator with-method
|
||||
get-field set-field! field-bound? field-names
|
||||
dynamic-get-field dynamic-set-field!
|
||||
private* public* pubment*
|
||||
override* overment*
|
||||
augride* augment*
|
||||
public-final* override-final* augment-final*
|
||||
define/private define/public define/pubment
|
||||
define/override define/overment
|
||||
define/augride define/augment
|
||||
define/public-final define/override-final define/augment-final
|
||||
define-local-member-name define-member-name
|
||||
member-name-key generate-member-key
|
||||
member-name-key? member-name-key=? member-name-key-hash-code
|
||||
generic make-generic send-generic
|
||||
is-a? subclass? implementation? interface-extension?
|
||||
object-interface object-info object->vector
|
||||
object-method-arity-includes?
|
||||
method-in-interface? interface->method-names class->interface class-info
|
||||
(struct-out exn:fail:object)
|
||||
make-primitive-class
|
||||
class/c ->m ->*m ->dm case->m object/c instanceof/c
|
||||
dynamic-object/c
|
||||
class-seal class-unseal
|
||||
|
||||
;; "keywords":
|
||||
private public override augment
|
||||
pubment overment augride
|
||||
public-final override-final augment-final
|
||||
field init init-field init-rest
|
||||
rename-super rename-inner inherit inherit/super inherit/inner inherit-field
|
||||
this this% super inner
|
||||
super-make-object super-instantiate super-new
|
||||
inspect absent abstract)
|
||||
stx)))
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; keyword setup
|
||||
|
|
@ -104,9 +105,10 @@
|
|||
(if (identifier? e)
|
||||
e
|
||||
(syntax-property e 'taint-mode 'transparent)))])
|
||||
(syntax-property (syntax/loc stx (internal-id elem ...))
|
||||
'taint-mode
|
||||
'transparent))]))
|
||||
(class-syntax-protect
|
||||
(syntax-property (syntax/loc stx (internal-id elem ...))
|
||||
'taint-mode
|
||||
'transparent)))]))
|
||||
|
||||
(define-syntax provide-renaming-class-keyword
|
||||
(syntax-rules ()
|
||||
|
|
@ -140,9 +142,10 @@
|
|||
(syntax-case stx ()
|
||||
[(_ elem ...)
|
||||
(with-syntax ([internal-id internal-id])
|
||||
(syntax-property (syntax/loc stx (internal-id elem ...))
|
||||
'taint-mode
|
||||
'transparent))]))
|
||||
(class-syntax-protect
|
||||
(syntax-property (syntax/loc stx (internal-id elem ...))
|
||||
'taint-mode
|
||||
'transparent)))]))
|
||||
|
||||
(define-syntax provide-naming-class-keyword
|
||||
(syntax-rules ()
|
||||
|
|
@ -1530,6 +1533,7 @@
|
|||
#'(current-inspector))]
|
||||
[deserialize-id-expr deserialize-id-expr]
|
||||
[private-field-names private-field-names])
|
||||
(class-syntax-protect
|
||||
(add-decl-props
|
||||
(quasisyntax/loc stx
|
||||
(detect-field-unsafe-undefined
|
||||
|
|
@ -1712,7 +1716,7 @@
|
|||
;; Extra argument added here by `detect-field-unsafe-undefined`
|
||||
#; check-undef?
|
||||
;; Not primitive:
|
||||
#f))))))))))))))))
|
||||
#f)))))))))))))))))
|
||||
|
||||
;; The class* and class entry points:
|
||||
(values
|
||||
|
|
@ -1772,36 +1776,39 @@
|
|||
#`((runtime-require (submod "." deserialize-info))
|
||||
(module+ deserialize-info (provide #,deserialize-name-info)))
|
||||
#'())])
|
||||
#'(begin
|
||||
(define-values (name deserialize-name-info)
|
||||
(class/derived orig-stx [name
|
||||
super-expression
|
||||
(interface-expr ...)
|
||||
#'deserialize-name-info]
|
||||
defn-or-expr ...))
|
||||
provision ...)))]))
|
||||
(class-syntax-protect
|
||||
#'(begin
|
||||
(define-values (name deserialize-name-info)
|
||||
(class/derived orig-stx [name
|
||||
super-expression
|
||||
(interface-expr ...)
|
||||
#'deserialize-name-info]
|
||||
defn-or-expr ...))
|
||||
provision ...))))]))
|
||||
|
||||
(define-syntax (define-serializable-class* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name super-expression (interface-expr ...)
|
||||
defn-or-expr ...)
|
||||
(with-syntax ([orig-stx stx])
|
||||
#'(-define-serializable-class orig-stx
|
||||
name
|
||||
super-expression
|
||||
(interface-expr ...)
|
||||
defn-or-expr ...))]))
|
||||
(class-syntax-protect
|
||||
#'(-define-serializable-class orig-stx
|
||||
name
|
||||
super-expression
|
||||
(interface-expr ...)
|
||||
defn-or-expr ...)))]))
|
||||
|
||||
(define-syntax (define-serializable-class stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name super-expression
|
||||
defn-or-expr ...)
|
||||
(with-syntax ([orig-stx stx])
|
||||
#'(-define-serializable-class orig-stx
|
||||
name
|
||||
super-expression
|
||||
()
|
||||
defn-or-expr ...))]))
|
||||
(class-syntax-protect
|
||||
#'(-define-serializable-class orig-stx
|
||||
name
|
||||
super-expression
|
||||
()
|
||||
defn-or-expr ...)))]))
|
||||
|
||||
(define-syntaxes (private* public* pubment* override* overment* augride* augment*
|
||||
public-final* override-final* augment-final*)
|
||||
|
|
@ -1833,11 +1840,12 @@
|
|||
(with-syntax ([(name ...) (map car name-exprs)]
|
||||
[(expr ...) (map cdr name-exprs)]
|
||||
[decl-form decl-form])
|
||||
(syntax
|
||||
(begin
|
||||
(decl-form name ...)
|
||||
(define name expr)
|
||||
...)))))])))])
|
||||
(class-syntax-protect
|
||||
(syntax
|
||||
(begin
|
||||
(decl-form name ...)
|
||||
(define name expr)
|
||||
...))))))])))])
|
||||
(values
|
||||
(mk 'private* (syntax private))
|
||||
(mk 'public* (syntax public))
|
||||
|
|
@ -1863,10 +1871,11 @@
|
|||
"use of a class keyword is not in a class top-level"
|
||||
stx))
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda #f #t)])
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(#,decl-form #,id)
|
||||
(define #,id #,rhs))))))])
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(#,decl-form #,id)
|
||||
(define #,id #,rhs)))))))])
|
||||
(values
|
||||
(mk #'private)
|
||||
(mk #'public)
|
||||
|
|
@ -1910,11 +1919,12 @@
|
|||
(define-syntaxes (id ...)
|
||||
(values (make-private-name (quote-syntax id) (quote-syntax gen-id))
|
||||
...)))])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-values (gen-id ...)
|
||||
(values (generate-local-member-name 'id) ...))
|
||||
stx-defs))))))]))
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-values (gen-id ...)
|
||||
(values (generate-local-member-name 'id) ...))
|
||||
stx-defs)))))))]))
|
||||
|
||||
(define-syntax (define-member-name stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -1932,9 +1942,10 @@
|
|||
(define-syntax id
|
||||
(make-private-name (quote-syntax id)
|
||||
((syntax-local-certifier) (quote-syntax member-name)))))])
|
||||
#'(begin
|
||||
(define member-name (check-member-key 'id expr))
|
||||
stx-def)))]))
|
||||
(class-syntax-protect
|
||||
#'(begin
|
||||
(define member-name (check-member-key 'id expr))
|
||||
stx-def))))]))
|
||||
|
||||
(define (generate-local-member-name id)
|
||||
(string->uninterned-symbol
|
||||
|
|
@ -1965,7 +1976,8 @@
|
|||
[(_ id)
|
||||
(identifier? #'id)
|
||||
(with-syntax ([id (localize #'id)])
|
||||
(syntax/loc stx (make-member-key `id)))]
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx (make-member-key `id))))]
|
||||
[(_ x)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
|
|
@ -3087,15 +3099,15 @@ An example
|
|||
(with-syntax ([name (datum->syntax #f name #f)]
|
||||
[(var ...) (map localize vars)]
|
||||
[((v c) ...) (filter (λ (p) (cadr p)) (map list vars ctcs))])
|
||||
(syntax/loc
|
||||
stx
|
||||
(compose-interface
|
||||
'name
|
||||
(list interface-expr ...)
|
||||
`(var ...)
|
||||
(make-immutable-hash (list (cons 'v c) ...))
|
||||
(list prop ...)
|
||||
(list prop-val ...)))))])))
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx
|
||||
(compose-interface
|
||||
'name
|
||||
(list interface-expr ...)
|
||||
`(var ...)
|
||||
(make-immutable-hash (list (cons 'v c) ...))
|
||||
(list prop ...)
|
||||
(list prop-val ...))))))])))
|
||||
|
||||
(define-syntax (_interface stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -3310,8 +3322,9 @@ An example
|
|||
(syntax-case stx ()
|
||||
[(_ cls (id arg) ...)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(quasisyntax/loc stx
|
||||
(instantiate cls () (id arg) ...))]
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(instantiate cls () (id arg) ...)))]
|
||||
[(_ cls (id arg) ...)
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
|
|
@ -3334,21 +3347,24 @@ An example
|
|||
(syntax-case stx ()
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(quasisyntax/loc stx
|
||||
(make-object/proc (current-contract-region)))]
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(make-object/proc (current-contract-region))))]
|
||||
[(_ class arg ...)
|
||||
(quasisyntax/loc stx
|
||||
(do-make-object
|
||||
(current-contract-region)
|
||||
class (list arg ...) (list)))]
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(do-make-object
|
||||
(current-contract-region)
|
||||
class (list arg ...) (list))))]
|
||||
[(_) (raise-syntax-error 'make-object "expected class" stx)]))))
|
||||
|
||||
(define-syntax (instantiate stx)
|
||||
(syntax-case stx ()
|
||||
[(form class (arg ...) . x)
|
||||
(with-syntax ([orig-stx stx])
|
||||
(quasisyntax/loc stx
|
||||
(-instantiate do-make-object orig-stx #t (class) (list arg ...) . x)))]))
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(-instantiate do-make-object orig-stx #t (class) (list arg ...) . x))))]))
|
||||
|
||||
;; Helper; used by instantiate and super-instantiate
|
||||
(define-syntax -instantiate
|
||||
|
|
@ -3358,12 +3374,13 @@ An example
|
|||
(andmap identifier? (syntax->list (syntax (kw ...))))
|
||||
(with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))]
|
||||
[(blame ...) (if (syntax-e #'first?) #'((current-contract-region)) null)])
|
||||
(syntax/loc stx
|
||||
(do-make-object blame ...
|
||||
maker-arg ...
|
||||
args
|
||||
(list (cons `kw arg)
|
||||
...))))]
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx
|
||||
(do-make-object blame ...
|
||||
maker-arg ...
|
||||
args
|
||||
(list (cons `kw arg)
|
||||
...)))))]
|
||||
[(_ super-make-object orig-stx first? (make-arg ...) args kwarg ...)
|
||||
;; some kwarg must be bad:
|
||||
(for-each (lambda (kwarg)
|
||||
|
|
@ -3744,22 +3761,23 @@ An example
|
|||
(set! let-bindings (cons #`[#,var #,x] let-bindings))]))
|
||||
(set! arg-list (reverse arg-list))
|
||||
(set! let-bindings (reverse let-bindings))
|
||||
|
||||
(syntax-property
|
||||
(quasisyntax/loc stx
|
||||
(let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
|
||||
[(receiver) (unsyntax obj)]
|
||||
[(method) (find-method/who '(unsyntax form) receiver sym)])
|
||||
(let (#,@(if kw-args
|
||||
(list #`[kw-arg-tmp #,(cadr kw-args)])
|
||||
(list))
|
||||
#,@let-bindings)
|
||||
(unsyntax
|
||||
(make-method-call-to-possibly-wrapped-object
|
||||
stx kw-args/var arg-list rest-arg?
|
||||
#'sym #'method #'receiver
|
||||
(quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym)))))))
|
||||
'feature-profile:send-dispatch #t)))
|
||||
|
||||
(class-syntax-protect
|
||||
(syntax-property
|
||||
(quasisyntax/loc stx
|
||||
(let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
|
||||
[(receiver) (unsyntax obj)]
|
||||
[(method) (find-method/who '(unsyntax form) receiver sym)])
|
||||
(let (#,@(if kw-args
|
||||
(list #`[kw-arg-tmp #,(cadr kw-args)])
|
||||
(list))
|
||||
#,@let-bindings)
|
||||
(unsyntax
|
||||
(make-method-call-to-possibly-wrapped-object
|
||||
stx kw-args/var arg-list rest-arg?
|
||||
#'sym #'method #'receiver
|
||||
(quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym)))))))
|
||||
'feature-profile:send-dispatch #t))))
|
||||
|
||||
(define (core-send apply? kws?)
|
||||
(lambda (stx)
|
||||
|
|
@ -3830,18 +3848,19 @@ An example
|
|||
(define-syntax (send* stx)
|
||||
(syntax-case stx ()
|
||||
[(form obj clause ...)
|
||||
(quasisyntax/loc stx
|
||||
(let* ([o obj])
|
||||
(unsyntax-splicing
|
||||
(map
|
||||
(lambda (clause-stx)
|
||||
(syntax-case clause-stx ()
|
||||
[(meth . args)
|
||||
(quasisyntax/loc stx
|
||||
(send o meth . args))]
|
||||
[_ (raise-syntax-error
|
||||
#f "bad method call" stx clause-stx)]))
|
||||
(syntax->list (syntax (clause ...)))))))]))
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(let* ([o obj])
|
||||
(unsyntax-splicing
|
||||
(map
|
||||
(lambda (clause-stx)
|
||||
(syntax-case clause-stx ()
|
||||
[(meth . args)
|
||||
(quasisyntax/loc stx
|
||||
(send o meth . args))]
|
||||
[_ (raise-syntax-error
|
||||
#f "bad method call" stx clause-stx)]))
|
||||
(syntax->list (syntax (clause ...))))))))]))
|
||||
|
||||
;; functional chained send
|
||||
(define-syntax (send+ stx)
|
||||
|
|
@ -3850,10 +3869,12 @@ An example
|
|||
(pattern [name:id . args]))
|
||||
(syntax-parse stx
|
||||
[(_ obj:expr clause-0:send-clause clause:send-clause ...)
|
||||
(quasisyntax/loc stx
|
||||
(let ([o (send obj clause-0.name . clause-0.args)])
|
||||
(send+ o clause ...)))]
|
||||
[(_ obj:expr) (syntax/loc stx obj)]))
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(let ([o (send obj clause-0.name . clause-0.args)])
|
||||
(send+ o clause ...))))]
|
||||
[(_ obj:expr) (class-syntax-protect
|
||||
(syntax/loc stx obj))]))
|
||||
|
||||
;; find-method/who : symbol[top-level-form/proc-name]
|
||||
;; any[object]
|
||||
|
|
@ -4019,17 +4040,18 @@ An example
|
|||
[flat-stx (if proper? args-stx (flatten-args args-stx))])
|
||||
(with-syntax ([(gen obj)
|
||||
(generate-temporaries (syntax (generic object)))])
|
||||
(quasisyntax/loc stx
|
||||
(let* ([obj object]
|
||||
[gen generic])
|
||||
;(check-generic gen)
|
||||
(unsyntax
|
||||
(make-method-call-to-possibly-wrapped-object
|
||||
stx #f flat-stx (not proper?)
|
||||
#'(generic-name gen)
|
||||
#'((generic-applicable gen) obj)
|
||||
#'obj
|
||||
#'((generic-applicable gen) obj)))))))]))
|
||||
(class-syntax-protect
|
||||
(quasisyntax/loc stx
|
||||
(let* ([obj object]
|
||||
[gen generic])
|
||||
;(check-generic gen)
|
||||
(unsyntax
|
||||
(make-method-call-to-possibly-wrapped-object
|
||||
stx #f flat-stx (not proper?)
|
||||
#'(generic-name gen)
|
||||
#'((generic-applicable gen) obj)
|
||||
#'obj
|
||||
#'((generic-applicable gen) obj))))))))]))
|
||||
|
||||
(define (check-generic gen)
|
||||
(unless (generic? gen)
|
||||
|
|
@ -4050,7 +4072,8 @@ An example
|
|||
name))
|
||||
(with-syntax ([name (localize name)]
|
||||
[make make])
|
||||
(syntax/loc stx (make class-expr `name))))]
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx (make class-expr `name)))))]
|
||||
[(_ class-expr)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
|
|
@ -4067,7 +4090,8 @@ An example
|
|||
[(_ name obj val)
|
||||
(identifier? #'name)
|
||||
(with-syntax ([localized (localize #'name)])
|
||||
(syntax/loc stx (set-field!/proc `localized obj val)))]
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx (set-field!/proc `localized obj val))))]
|
||||
[(_ name obj val)
|
||||
(raise-syntax-error
|
||||
'set-field! "expected a field name as first argument"
|
||||
|
|
@ -4121,7 +4145,8 @@ An example
|
|||
[(_ name obj)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([localized (localize (syntax name))])
|
||||
(syntax/loc stx (get-field/proc `localized obj)))]
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx (get-field/proc `localized obj))))]
|
||||
[(_ name obj)
|
||||
(raise-syntax-error
|
||||
'get-field "expected a field name as first argument"
|
||||
|
|
@ -4175,7 +4200,8 @@ An example
|
|||
[(_ name obj)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([localized (localize (syntax name))])
|
||||
(syntax (field-bound?/proc `localized obj)))]
|
||||
(class-syntax-protect
|
||||
(syntax (field-bound?/proc `localized obj))))]
|
||||
[(_ name obj)
|
||||
(raise-syntax-error
|
||||
'field-bound? "expected a field name as first argument"
|
||||
|
|
@ -4223,19 +4249,20 @@ An example
|
|||
(with-syntax ([(method ...) (generate-temporaries ids)]
|
||||
[(method-obj ...) (generate-temporaries ids)]
|
||||
[(name ...) (map localize names)])
|
||||
(syntax/loc stx (let-values ([(method method-obj)
|
||||
(let ([obj obj-expr])
|
||||
(values (find-method/who 'with-method obj `name)
|
||||
obj))]
|
||||
...)
|
||||
(letrec-syntaxes+values ([(id) (make-with-method-map
|
||||
(quote-syntax set!)
|
||||
(quote-syntax id)
|
||||
(quote-syntax method)
|
||||
(quote-syntax method-obj))]
|
||||
...)
|
||||
()
|
||||
body0 body1 ...)))))]
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx (let-values ([(method method-obj)
|
||||
(let ([obj obj-expr])
|
||||
(values (find-method/who 'with-method obj `name)
|
||||
obj))]
|
||||
...)
|
||||
(letrec-syntaxes+values ([(id) (make-with-method-map
|
||||
(quote-syntax set!)
|
||||
(quote-syntax id)
|
||||
(quote-syntax method)
|
||||
(quote-syntax method-obj))]
|
||||
...)
|
||||
()
|
||||
body0 body1 ...))))))]
|
||||
;; Error cases:
|
||||
[(_ (clause ...) . body)
|
||||
(begin
|
||||
|
|
@ -4783,16 +4810,16 @@ An example
|
|||
(λ (super%)
|
||||
(check-mixin-super mixin-name super% (list from-ids ...))
|
||||
class-expr))])
|
||||
|
||||
;; Finally, build the complete mixin expression:
|
||||
(syntax/loc stx
|
||||
(let ([from-ids from] ...)
|
||||
(let ([to-ids to] ...)
|
||||
(check-mixin-from-interfaces (list from-ids ...))
|
||||
(check-mixin-to-interfaces (list to-ids ...))
|
||||
(check-interface-includes (list (quasiquote super-vars) ...)
|
||||
(list from-ids ...))
|
||||
mixin-expr)))))))]))
|
||||
(class-syntax-protect
|
||||
(syntax/loc stx
|
||||
(let ([from-ids from] ...)
|
||||
(let ([to-ids to] ...)
|
||||
(check-mixin-from-interfaces (list from-ids ...))
|
||||
(check-mixin-to-interfaces (list to-ids ...))
|
||||
(check-interface-includes (list (quasiquote super-vars) ...)
|
||||
(list from-ids ...))
|
||||
mixin-expr))))))))]))
|
||||
|
||||
(define externalizable<%>
|
||||
(_interface () externalize internalize))
|
||||
|
|
|
|||
|
|
@ -466,4 +466,5 @@
|
|||
make-method-call-to-possibly-wrapped-object
|
||||
do-localize make-private-name
|
||||
generate-super-call generate-inner-call
|
||||
generate-class-expand-context class-top-level-context?))
|
||||
generate-class-expand-context class-top-level-context?
|
||||
class-syntax-protect))
|
||||
|
|
|
|||
|
|
@ -515,8 +515,10 @@
|
|||
(if (struct-type? the-super)
|
||||
the-super
|
||||
(check-struct-type 'fm the-super)))))]
|
||||
[prune (lambda (stx) (identifier-prune-lexical-context stx
|
||||
(list (syntax-e stx) '#%top)))]
|
||||
[prune (lambda (stx)
|
||||
(syntax-protect
|
||||
(identifier-prune-lexical-context stx
|
||||
(list (syntax-e stx) '#%top))))]
|
||||
[reflect-name-expr (if reflect-name-expr
|
||||
(syntax-case reflect-name-expr (quote)
|
||||
[(quote id)
|
||||
|
|
|
|||
|
|
@ -1442,20 +1442,23 @@
|
|||
(cond
|
||||
[(null? l)
|
||||
;; No #:break form
|
||||
#'(inner-recur fold-vars (let-values () expr ...) (if final?-id break-k next-k))]
|
||||
(syntax-protect
|
||||
#'(inner-recur fold-vars (let-values () expr ...) (if final?-id break-k next-k)))]
|
||||
[(eq? '#:break (syntax-e (car l)))
|
||||
;; Found a #:break form
|
||||
#`(let-values ()
|
||||
#,@(reverse pre-accum)
|
||||
(if #,(cadr l)
|
||||
break-k
|
||||
(push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?-id)))]
|
||||
(syntax-protect
|
||||
#`(let-values ()
|
||||
#,@(reverse pre-accum)
|
||||
(if #,(cadr l)
|
||||
break-k
|
||||
(push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?-id))))]
|
||||
[(eq? '#:final (syntax-e (car l)))
|
||||
;; Found a #:final form
|
||||
#`(let-values ()
|
||||
#,@(reverse pre-accum)
|
||||
(let ([final? (or #,(cadr l) final?-id)])
|
||||
(push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?)))]
|
||||
(syntax-protect
|
||||
#`(let-values ()
|
||||
#,@(reverse pre-accum)
|
||||
(let ([final? (or #,(cadr l) final?-id)])
|
||||
(push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?))))]
|
||||
[else (loop (cdr l) (cons (car l) pre-accum))]))]))
|
||||
|
||||
(define-syntax (for/foldX/derived stx)
|
||||
|
|
@ -1465,15 +1468,18 @@
|
|||
expr1 expr ...)
|
||||
(if (syntax-e #'inner-recur)
|
||||
;; General, non-nested-loop approach:
|
||||
#`(let ([fold-var fold-init] ...)
|
||||
(push-under-break inner-recur (fold-var ...) [expr1 expr ...] next-k break-k final?-id))
|
||||
(syntax-protect
|
||||
#`(let ([fold-var fold-init] ...)
|
||||
(push-under-break inner-recur (fold-var ...) [expr1 expr ...] next-k break-k final?-id)))
|
||||
;; Nested-loop approach (which is slightly faster when it works):
|
||||
#`(let ([fold-var fold-init] ...)
|
||||
(let-values ([(fold-var ...) (let () expr1 expr ...)])
|
||||
(values fold-var ...))))]
|
||||
(syntax-protect
|
||||
#`(let ([fold-var fold-init] ...)
|
||||
(let-values ([(fold-var ...) (let () expr1 expr ...)])
|
||||
(values fold-var ...)))))]
|
||||
;; Switch-to-emit case (no more clauses to generate):
|
||||
[(_ [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id () . body)
|
||||
#`(for/foldX/derived [orig-stx inner-recur nested? #t binds] fold-bind next-k break-k final?-id () . body)]
|
||||
(syntax-protect
|
||||
#`(for/foldX/derived [orig-stx inner-recur nested? #t binds] fold-bind next-k break-k final?-id () . body))]
|
||||
;; Emit case:
|
||||
[(_ [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id rest expr1 . body)
|
||||
(with-syntax ([(([outer-binding ...]
|
||||
|
|
@ -1484,37 +1490,38 @@
|
|||
pre-guard
|
||||
post-guard
|
||||
[loop-arg ...]) ...) (reverse (syntax->list #'binds))])
|
||||
(quasisyntax/loc #'orig-stx
|
||||
(let-values (outer-binding ... ...)
|
||||
outer-check ...
|
||||
#,(quasisyntax/loc #'orig-stx
|
||||
(let for-loop ([fold-var fold-init] ...
|
||||
loop-binding ... ...)
|
||||
(if (and pos-guard ...)
|
||||
(let-values (inner-binding ... ...)
|
||||
(if (and pre-guard ...)
|
||||
#,(if (syntax-e #'inner-recur)
|
||||
;; The general non-nested-loop approach:
|
||||
#'(let ([post-guard-var (lambda (fold-var ...) (and post-guard ...))])
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...)
|
||||
(if (post-guard-var fold-var ...)
|
||||
(for-loop fold-var ... loop-arg ... ...)
|
||||
next-k)
|
||||
break-k final?-id
|
||||
rest expr1 . body))
|
||||
;; The specialized nested-loop approach, which is
|
||||
;; slightly faster when it works:
|
||||
#'(let-values ([(fold-var ...)
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...)
|
||||
next-k break-k final?-id
|
||||
rest expr1 . body)])
|
||||
(if (and post-guard ... (not final?-id))
|
||||
(for-loop fold-var ... loop-arg ... ...)
|
||||
next-k)))
|
||||
next-k))
|
||||
next-k))))))]
|
||||
(syntax-protect
|
||||
(quasisyntax/loc #'orig-stx
|
||||
(let-values (outer-binding ... ...)
|
||||
outer-check ...
|
||||
#,(quasisyntax/loc #'orig-stx
|
||||
(let for-loop ([fold-var fold-init] ...
|
||||
loop-binding ... ...)
|
||||
(if (and pos-guard ...)
|
||||
(let-values (inner-binding ... ...)
|
||||
(if (and pre-guard ...)
|
||||
#,(if (syntax-e #'inner-recur)
|
||||
;; The general non-nested-loop approach:
|
||||
#'(let ([post-guard-var (lambda (fold-var ...) (and post-guard ...))])
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...)
|
||||
(if (post-guard-var fold-var ...)
|
||||
(for-loop fold-var ... loop-arg ... ...)
|
||||
next-k)
|
||||
break-k final?-id
|
||||
rest expr1 . body))
|
||||
;; The specialized nested-loop approach, which is
|
||||
;; slightly faster when it works:
|
||||
#'(let-values ([(fold-var ...)
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...)
|
||||
next-k break-k final?-id
|
||||
rest expr1 . body)])
|
||||
(if (and post-guard ... (not final?-id))
|
||||
(for-loop fold-var ... loop-arg ... ...)
|
||||
next-k)))
|
||||
next-k))
|
||||
next-k)))))))]
|
||||
;; Bad body cases:
|
||||
[(_ [orig-stx . _] fold-bind next-k break-k final?-id ())
|
||||
(raise-syntax-error
|
||||
|
|
@ -1524,43 +1531,49 @@
|
|||
#f "bad syntax (illegal use of `.') after sequence bindings" #'orig-stx)]
|
||||
;; Guard case, no pending emits:
|
||||
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:when expr . rest) . body)
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(if expr
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final?-id rest . body)
|
||||
next-k))]
|
||||
(syntax-protect
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(if expr
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final?-id rest . body)
|
||||
next-k)))]
|
||||
;; Negative guard case, no pending emits:
|
||||
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:unless expr . rest) . body)
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(if expr
|
||||
(if final?-id break-k next-k)
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final?-id rest . body)))]
|
||||
(syntax-protect
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(if expr
|
||||
(if final?-id break-k next-k)
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final?-id rest . body))))]
|
||||
;; Break case, no pending emits:
|
||||
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:break expr . rest) . body)
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(if expr
|
||||
break-k
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final?-id rest . body)))]
|
||||
(syntax-protect
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(if expr
|
||||
break-k
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final?-id rest . body))))]
|
||||
;; Final case, no pending emits:
|
||||
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:final expr . rest) . body)
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(let ([final? (or expr final?-id)])
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final? rest . body)))]
|
||||
(syntax-protect
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(let ([final? (or expr final?-id)])
|
||||
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||
([fold-var fold-var] ...) next-k break-k final? rest . body))))]
|
||||
;; Keyword case, pending emits need to be flushed first
|
||||
[(frm [orig-stx inner-recur nested? #f binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body)
|
||||
(or (eq? (syntax-e #'kw) '#:when)
|
||||
(eq? (syntax-e #'kw) '#:unless)
|
||||
(eq? (syntax-e #'kw) '#:break)
|
||||
(eq? (syntax-e #'kw) '#:final))
|
||||
#'(frm [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body)]
|
||||
(syntax-protect
|
||||
#'(frm [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body))]
|
||||
;; Convert single-value form to multi-value form:
|
||||
[(_ [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id ([id rhs] . rest) . body)
|
||||
(identifier? #'id)
|
||||
#'(for/foldX/derived [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id
|
||||
([(id) rhs] . rest) . body)]
|
||||
(syntax-protect
|
||||
#'(for/foldX/derived [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id
|
||||
([(id) rhs] . rest) . body))]
|
||||
;; If we get here in single-value mode, then it's a bad clause:
|
||||
[(_ [orig-stx inner-recur #f #f nested? #f binds] fold-bind next-k break-k final?-id (clause . rest) . body)
|
||||
(raise-syntax-error
|
||||
|
|
@ -1587,28 +1600,32 @@
|
|||
;; non-nested loop approach to implement them:
|
||||
(ormap (lambda (s) (or (eq? '#:break (syntax-e s)) (eq? '#:final (syntax-e s))))
|
||||
(syntax->list #'(clause ... expr ...)))
|
||||
#'(for/foldX/derived [orig-stx inner-recur/fold nested? #f ()] fold-bind done-k done-k #f (clause ...) expr ...)]
|
||||
(syntax-protect
|
||||
#'(for/foldX/derived [orig-stx inner-recur/fold nested? #f ()] fold-bind done-k done-k #f (clause ...) expr ...))]
|
||||
[(_ [orig-stx nested?] fold-bind done-k . rest)
|
||||
;; Otherwise, allow compilation as nested loops, which can be slightly faster:
|
||||
#'(for/foldX/derived [orig-stx #f nested? #f ()] fold-bind done-k done-k #f . rest)]))
|
||||
(syntax-protect
|
||||
#'(for/foldX/derived [orig-stx #f nested? #f ()] fold-bind done-k done-k #f . rest))]))
|
||||
|
||||
(define-syntax (for/fold/derived stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx ([fold-var finid-init] ... #:result result-expr) . rest)
|
||||
(check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t)
|
||||
(syntax/loc #'orig-stx
|
||||
(let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #f]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest)])
|
||||
result-expr))]
|
||||
(syntax-protect
|
||||
(syntax/loc #'orig-stx
|
||||
(let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #f]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest)])
|
||||
result-expr)))]
|
||||
[(_ orig-stx ([fold-var finid-init] ...) . rest)
|
||||
(check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t)
|
||||
(syntax/loc #'orig-stx
|
||||
(for/foldX/derived/final [orig-stx #f]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest))]
|
||||
(syntax-protect
|
||||
(syntax/loc #'orig-stx
|
||||
(for/foldX/derived/final [orig-stx #f]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest)))]
|
||||
[(_ orig-stx (bindings ...) . rst)
|
||||
(raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))]
|
||||
[(_ orig-stx . rst)
|
||||
|
|
@ -1618,19 +1635,21 @@
|
|||
(syntax-case stx ()
|
||||
[(_ orig-stx ([fold-var finid-init] ... #:result result-expr) . rest)
|
||||
(check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t)
|
||||
(syntax/loc #'orig-stx
|
||||
(let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #t]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest)])
|
||||
result-expr))]
|
||||
(syntax-protect
|
||||
(syntax/loc #'orig-stx
|
||||
(let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #t]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest)])
|
||||
result-expr)))]
|
||||
[(_ orig-stx ([fold-var finid-init] ...) . rest)
|
||||
(check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t)
|
||||
(syntax/loc #'orig-stx
|
||||
(for/foldX/derived/final [orig-stx #t]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest))]
|
||||
(syntax-protect
|
||||
(syntax/loc #'orig-stx
|
||||
(for/foldX/derived/final [orig-stx #t]
|
||||
([fold-var finid-init] ...)
|
||||
(values* fold-var ...)
|
||||
. rest)))]
|
||||
[(_ orig-stx (bindings ...) . rst)
|
||||
(raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))]
|
||||
[(_ orig-stx . rst)
|
||||
|
|
@ -1721,10 +1740,12 @@
|
|||
|
||||
(define-syntax (for/fold stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest) (quasisyntax/loc stx (for/fold/derived #,stx . rest))]))
|
||||
[(_ . rest) (syntax-protect
|
||||
(quasisyntax/loc stx (for/fold/derived #,stx . rest)))]))
|
||||
(define-syntax (for*/fold stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest) (quasisyntax/loc stx (for*/fold/derived #,stx . rest))]))
|
||||
[(_ . rest) (syntax-protect
|
||||
(quasisyntax/loc stx (for*/fold/derived #,stx . rest)))]))
|
||||
|
||||
(define-for-variants (for for*)
|
||||
()
|
||||
|
|
@ -1755,20 +1776,21 @@
|
|||
(with-syntax ([orig-stx orig-stx]
|
||||
[for_/fold/derived for_/fold/derived-stx]
|
||||
[((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))])
|
||||
(syntax/loc stx
|
||||
(let-values ([(vec i)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([vec (make-vector 16)]
|
||||
[i 0])
|
||||
(for-clause ...)
|
||||
middle-body ...
|
||||
(let ([new-vec (if (eq? i (unsafe-vector*-length vec))
|
||||
(grow-vector vec)
|
||||
vec)])
|
||||
(unsafe-vector*-set! new-vec i (let () last-body ...))
|
||||
(values new-vec (unsafe-fx+ i 1))))])
|
||||
(shrink-vector vec i))))]
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(let-values ([(vec i)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([vec (make-vector 16)]
|
||||
[i 0])
|
||||
(for-clause ...)
|
||||
middle-body ...
|
||||
(let ([new-vec (if (eq? i (unsafe-vector*-length vec))
|
||||
(grow-vector vec)
|
||||
vec)])
|
||||
(unsafe-vector*-set! new-vec i (let () last-body ...))
|
||||
(values new-vec (unsafe-fx+ i 1))))])
|
||||
(shrink-vector vec i)))))]
|
||||
[(_ #:length length-expr #:fill fill-expr (for-clause ...) body ...)
|
||||
(with-syntax ([orig-stx orig-stx]
|
||||
[(limited-for-clause ...)
|
||||
|
|
@ -1801,20 +1823,21 @@
|
|||
[((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))]
|
||||
[for_/vector for_/vector-stx]
|
||||
[for_/fold/derived for_/fold/derived-stx])
|
||||
(syntax/loc stx
|
||||
(let ([len length-expr])
|
||||
(unless (exact-nonnegative-integer? len)
|
||||
(raise-argument-error 'for_/vector "exact-nonnegative-integer?" len))
|
||||
(let ([v (make-vector len fill-expr)])
|
||||
(unless (zero? len)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([i 0])
|
||||
(limited-for-clause ...)
|
||||
middle-body ...
|
||||
(unsafe-vector*-set! v i (let () last-body ...))
|
||||
(unsafe-fx+ 1 i)))
|
||||
v))))]
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(let ([len length-expr])
|
||||
(unless (exact-nonnegative-integer? len)
|
||||
(raise-argument-error 'for_/vector "exact-nonnegative-integer?" len))
|
||||
(let ([v (make-vector len fill-expr)])
|
||||
(unless (zero? len)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([i 0])
|
||||
(limited-for-clause ...)
|
||||
middle-body ...
|
||||
(unsafe-vector*-set! v i (let () last-body ...))
|
||||
(unsafe-fx+ 1 i)))
|
||||
v)))))]
|
||||
[(_ #:length length-expr (for-clause ...) body ...)
|
||||
(for_/vector #'(fv #:length length-expr #:fill 0 (for-clause ...) body ...)
|
||||
orig-stx for_/vector-stx for_/fold/derived-stx wrap-all?)]))
|
||||
|
|
@ -1849,12 +1872,14 @@
|
|||
(values* (alt-reverse id) ...)))))
|
||||
(syntax-case stx ()
|
||||
[(_ (id ... #:result result-expr) bindings expr1 expr ...)
|
||||
#`(let-values ([(id ...)
|
||||
#,(do-without-result-clause
|
||||
#'(_ (id ...) bindings expr1 expr ...))])
|
||||
result-expr)]
|
||||
(syntax-protect
|
||||
#`(let-values ([(id ...)
|
||||
#,(do-without-result-clause
|
||||
#'(_ (id ...) bindings expr1 expr ...))])
|
||||
result-expr))]
|
||||
[(_ (id ...) bindings expr1 expr ...)
|
||||
(do-without-result-clause stx)]))
|
||||
(syntax-protect
|
||||
(do-without-result-clause stx))]))
|
||||
|
||||
(define-syntax (for/lists stx) (do-for/lists #'for/fold/derived stx))
|
||||
(define-syntax (for*/lists stx) (do-for/lists #'for*/fold/derived stx))
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
'#%unsafe)
|
||||
(#%provide force promise? promise-forced? promise-running?
|
||||
;; provided to create extensions
|
||||
(struct promise ()) pref pset! prop:force reify-result
|
||||
(struct promise ()) (protect pref pset!) prop:force reify-result
|
||||
promise-forcer
|
||||
promise-printer
|
||||
(struct running ()) (struct reraise ())
|
||||
|
|
@ -249,7 +249,7 @@
|
|||
;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
|
||||
(#%provide (rename lazy* lazy))
|
||||
(define lazy make-composable-promise)
|
||||
(define-syntax (lazy* stx) (make-delayer stx #'lazy '()))
|
||||
(define-syntax (lazy* stx) (syntax-protect (make-delayer stx #'lazy '())))
|
||||
|
||||
;; Creates a (generic) promise that does not compose
|
||||
;; X = (force (delay X)) = (force (lazy (delay X)))
|
||||
|
|
@ -261,7 +261,7 @@
|
|||
;; but provided for regular delay/force uses.)
|
||||
(#%provide (rename delay* delay))
|
||||
(define delay make-promise)
|
||||
(define-syntax (delay* stx) (make-delayer stx #'delay '()))
|
||||
(define-syntax (delay* stx) (syntax-protect (make-delayer stx #'delay '())))
|
||||
|
||||
;; For simplicity and efficiency this code uses thunks in promise values for
|
||||
;; exceptions: this way, we don't need to tag exception values in some special
|
||||
|
|
|
|||
|
|
@ -62,23 +62,24 @@
|
|||
(with-syntax ([orig-stx orig-stx]
|
||||
[for_/fold/derived for_/fold/derived-stx]
|
||||
[((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))])
|
||||
(syntax/loc stx
|
||||
(let-values ([(vec i)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([vec (make-fXvector 16)]
|
||||
[i 0])
|
||||
(for-clause ...)
|
||||
middle-body ...
|
||||
(let ([new-vec (if (eq? i (unsafe-fXvector-length vec))
|
||||
(grow-fXvector vec)
|
||||
vec)])
|
||||
(let ([elem (let () last-body ...)])
|
||||
(if (fX? elem)
|
||||
(unsafe-fXvector-set! new-vec i elem)
|
||||
(not-an-fX 'for*/fXvector elem)))
|
||||
(values new-vec (unsafe-fx+ i 1))))])
|
||||
(shrink-fXvector vec i))))]
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(let-values ([(vec i)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([vec (make-fXvector 16)]
|
||||
[i 0])
|
||||
(for-clause ...)
|
||||
middle-body ...
|
||||
(let ([new-vec (if (eq? i (unsafe-fXvector-length vec))
|
||||
(grow-fXvector vec)
|
||||
vec)])
|
||||
(let ([elem (let () last-body ...)])
|
||||
(if (fX? elem)
|
||||
(unsafe-fXvector-set! new-vec i elem)
|
||||
(not-an-fX 'for*/fXvector elem)))
|
||||
(values new-vec (unsafe-fx+ i 1))))])
|
||||
(shrink-fXvector vec i)))))]
|
||||
[(for*/fXvector #:length length-expr #:fill fill-expr (for-clause ...) body ...)
|
||||
(with-syntax ([orig-stx orig-stx]
|
||||
[(limited-for-clause ...)
|
||||
|
|
@ -111,24 +112,25 @@
|
|||
[((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))]
|
||||
[for_/fXvector for_/fXvector-stx]
|
||||
[for_/fold/derived for_/fold/derived-stx])
|
||||
(syntax/loc stx
|
||||
(let ([len length-expr])
|
||||
(unless (exact-nonnegative-integer? len)
|
||||
(raise-argument-error 'for_/fXvector "exact-nonnegative-integer?" len))
|
||||
(let ([fill fill-expr])
|
||||
(let ([v (make-fXvector len fill)])
|
||||
(unless (zero? len)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([i 0])
|
||||
(limited-for-clause ...)
|
||||
middle-body ...
|
||||
(let ([elem (let () last-body ...)])
|
||||
(if (fX? elem)
|
||||
(unsafe-fXvector-set! v i elem)
|
||||
(not-an-fX 'for*/vector elem)))
|
||||
(unsafe-fx+ 1 i)))
|
||||
v)))))]
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(let ([len length-expr])
|
||||
(unless (exact-nonnegative-integer? len)
|
||||
(raise-argument-error 'for_/fXvector "exact-nonnegative-integer?" len))
|
||||
(let ([fill fill-expr])
|
||||
(let ([v (make-fXvector len fill)])
|
||||
(unless (zero? len)
|
||||
(for_/fold/derived
|
||||
orig-stx
|
||||
([i 0])
|
||||
(limited-for-clause ...)
|
||||
middle-body ...
|
||||
(let ([elem (let () last-body ...)])
|
||||
(if (fX? elem)
|
||||
(unsafe-fXvector-set! v i elem)
|
||||
(not-an-fX 'for*/vector elem)))
|
||||
(unsafe-fx+ 1 i)))
|
||||
v))))))]
|
||||
[(_ #:length length-expr (for-clause ...) body ...)
|
||||
(for_/fXvector #'(fv #:length length-expr #:fill fXzero (for-clause ...) body ...)
|
||||
orig-stx for_/fXvector-stx for_/fold/derived-stx wrap-all?)]))
|
||||
|
|
|
|||
|
|
@ -51,17 +51,19 @@
|
|||
(begin
|
||||
(check-id #'name)
|
||||
(check-id #'arg)
|
||||
#'(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-signature-form (λ (arg ignored) . val))))))
|
||||
(syntax-protect
|
||||
#'(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-signature-form (λ (arg ignored) . val)))))))
|
||||
((_ (name arg intro-arg) . val)
|
||||
(begin
|
||||
(check-id #'name)
|
||||
(check-id #'arg)
|
||||
(check-id #'intro-arg)
|
||||
#'(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-signature-form (λ (arg intro-arg) . val))))))
|
||||
(syntax-protect
|
||||
#'(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-signature-form (λ (arg intro-arg) . val)))))))
|
||||
((_ . l)
|
||||
(let ((l (checked-syntax->list stx)))
|
||||
(unless (>= 3 (length l))
|
||||
|
|
@ -981,7 +983,8 @@
|
|||
[(icount ...) (map
|
||||
(lambda (import) (length (car import)))
|
||||
import-sigs)])
|
||||
(values
|
||||
(values
|
||||
(syntax-protect
|
||||
(intro
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(make-unit
|
||||
|
|
@ -1033,7 +1036,7 @@
|
|||
(unit-export ((export-key ...)
|
||||
(vector-immutable (λ () (check-not-unsafe-undefined (unbox eloc) 'int-evar))
|
||||
...))
|
||||
...))))))))
|
||||
...)))))))))
|
||||
import-tagged-sigids
|
||||
export-tagged-sigids
|
||||
dep-tagged-sigids))))))
|
||||
|
|
@ -1358,7 +1361,8 @@
|
|||
orig-export-tagged-infos)]
|
||||
[name (syntax-local-infer-name (error-syntax))]
|
||||
[form (syntax-e (stx-car (error-syntax)))])
|
||||
(values
|
||||
(values
|
||||
(syntax-protect
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(let ([unit-tmp unit-exp])
|
||||
(check-unit unit-tmp 'form)
|
||||
|
|
@ -1390,7 +1394,7 @@
|
|||
orig-export-tagged-infos
|
||||
orig-export-sigs
|
||||
export-tagged-infos
|
||||
export-sigs))))))))
|
||||
export-sigs)))))))))
|
||||
import-tagged-sigids
|
||||
export-tagged-sigids
|
||||
dep-tagged-sigids)))))))
|
||||
|
|
@ -1649,6 +1653,7 @@
|
|||
;; created via compound-unit/infer. Only the `inferred` dependencies
|
||||
;; will appear in this syntax property, when no inference occurs the property
|
||||
;; will contain an empty list.
|
||||
(syntax-protect
|
||||
(syntax-property
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(let ([deps '()]
|
||||
|
|
@ -1676,7 +1681,7 @@
|
|||
'unit:inferred-init-depends
|
||||
(build-init-depend-property
|
||||
static-dep-info
|
||||
(map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))))
|
||||
(map syntax-e (syntax->list #'((import-tag . import-sigid) ...))))))
|
||||
(map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))
|
||||
(map syntax-e (syntax->list #'((export-tag . export-sigid) ...)))
|
||||
static-dep-info))))))
|
||||
|
|
@ -1816,9 +1821,10 @@
|
|||
(with-syntax ((((int-id . ext-id) ...) int+ext-ids)
|
||||
((def-name ...) (generate-temporaries (map car int+ext-ids))))
|
||||
(values
|
||||
#'(:unit (import) (export (rename export-spec (def-name int-id) ...))
|
||||
(define def-name int-id)
|
||||
...)
|
||||
(syntax-protect
|
||||
#'(:unit (import) (export (rename export-spec (def-name int-id) ...))
|
||||
(define def-name int-id)
|
||||
...))
|
||||
null
|
||||
(list (cadr tagged-export-sig))
|
||||
'()))))))
|
||||
|
|
@ -1853,17 +1859,18 @@
|
|||
(((etag . esig) ...) e)
|
||||
(((deptag . depsig) ...) d)
|
||||
(contracted? contracted?))
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(begin
|
||||
(define u #,exp)
|
||||
(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-unit-info (quote-syntax u)
|
||||
(list (cons 'itag (quote-syntax isig)) ...)
|
||||
(list (cons 'etag (quote-syntax esig)) ...)
|
||||
(list (cons 'deptag (quote-syntax depsig)) ...)
|
||||
(quote-syntax name)
|
||||
contracted?)))))))))
|
||||
(syntax-protect
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(begin
|
||||
(define u #,exp)
|
||||
(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-unit-info (quote-syntax u)
|
||||
(list (cons 'itag (quote-syntax isig)) ...)
|
||||
(list (cons 'etag (quote-syntax esig)) ...)
|
||||
(list (cons 'deptag (quote-syntax depsig)) ...)
|
||||
(quote-syntax name)
|
||||
contracted?))))))))))
|
||||
((_)
|
||||
(raise-stx-err err-msg)))))
|
||||
|
||||
|
|
@ -1899,21 +1906,22 @@
|
|||
(map check-helper tagged-export-infos))
|
||||
(form (stx-car (error-syntax))))
|
||||
(values
|
||||
#`(let ([unit-tmp unit-exp])
|
||||
#,(syntax/loc #'unit-exp
|
||||
(check-unit unit-tmp 'form))
|
||||
#,(syntax/loc #'unit-exp
|
||||
(check-sigs unit-tmp
|
||||
(vector-immutable
|
||||
(cons 'import-name
|
||||
(vector-immutable import-keys ...))
|
||||
...)
|
||||
(vector-immutable
|
||||
(cons 'export-name
|
||||
(vector-immutable export-keys ...))
|
||||
...)
|
||||
'form))
|
||||
unit-tmp)
|
||||
(syntax-protect
|
||||
#`(let ([unit-tmp unit-exp])
|
||||
#,(syntax/loc #'unit-exp
|
||||
(check-unit unit-tmp 'form))
|
||||
#,(syntax/loc #'unit-exp
|
||||
(check-sigs unit-tmp
|
||||
(vector-immutable
|
||||
(cons 'import-name
|
||||
(vector-immutable import-keys ...))
|
||||
...)
|
||||
(vector-immutable
|
||||
(cons 'export-name
|
||||
(vector-immutable export-keys ...))
|
||||
...)
|
||||
'form))
|
||||
unit-tmp))
|
||||
tagged-import-sigids
|
||||
tagged-export-sigids
|
||||
tagged-dep-sigids))))))
|
||||
|
|
@ -1976,9 +1984,10 @@
|
|||
(export (export-tagged-sig-id [e.x e.c] ...) ...)
|
||||
dep
|
||||
#,@splicing-body-contract)))])
|
||||
(values
|
||||
(syntax/loc stx
|
||||
(contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name)))
|
||||
(values
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))))
|
||||
isigs esigs deps))))]
|
||||
[(ic:import-clause/contract ec:export-clause/contract dep:dep-clause . bexps)
|
||||
(build-unit/contract
|
||||
|
|
@ -2350,9 +2359,10 @@
|
|||
(with-syntax ([u units]
|
||||
[(esig ...) esig]
|
||||
[(isig ...) isig])
|
||||
(if define?
|
||||
(syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...)))
|
||||
(syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))]
|
||||
(syntax-protect
|
||||
(if define?
|
||||
(syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...)))
|
||||
(syntax/loc (error-syntax) (invoke-unit u (import isig ...)))))))]
|
||||
[(list? units)
|
||||
(let-values ([(isig esig) (imps/exps-from-units units exports)])
|
||||
(with-syntax ([(new-unit) (generate-temporaries '(new-unit))]
|
||||
|
|
@ -2366,13 +2376,14 @@
|
|||
(export esig ...)
|
||||
(link unit ...))))])
|
||||
u)])
|
||||
(if define?
|
||||
(syntax/loc (error-syntax)
|
||||
(define-values/invoke-unit u
|
||||
(import isig ...) (export esig ...)))
|
||||
(syntax/loc (error-syntax)
|
||||
(invoke-unit u
|
||||
(import isig ...)))))))]
|
||||
(syntax-protect
|
||||
(if define?
|
||||
(syntax/loc (error-syntax)
|
||||
(define-values/invoke-unit u
|
||||
(import isig ...) (export esig ...)))
|
||||
(syntax/loc (error-syntax)
|
||||
(invoke-unit u
|
||||
(import isig ...))))))))]
|
||||
;; just for error handling
|
||||
[else (lookup-def-unit units)]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user