From baf7434c7f8978a651fe75d4bd0c2302d63ac847 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Fri, 19 May 2017 04:16:23 +0200
Subject: [PATCH] Fixed issue with recursive functions defined with
define-pure/stateless and define-pure/stateful
Rhe immutabile-value check was happening before the actual production of the lambda bound to the ID, and therefore an "undefined variable" error was raised.
---
private/pure-function.rkt | 91 ++++++++++++++++++++++++------------
scribblings/delay-pure.scrbl | 33 +++++++++++--
test/test-pure-safe.rkt | 21 +++++----
3 files changed, 100 insertions(+), 45 deletions(-)
diff --git a/private/pure-function.rkt b/private/pure-function.rkt
index e32430d..e8877c0 100644
--- a/private/pure-function.rkt
+++ b/private/pure-function.rkt
@@ -122,7 +122,8 @@
(begin
(free-id-set-add! unsafe-pure-functions-free-id-set/stateless #'fn)
#'(set-box! rw-unsafe-pure-functions-set/stateless
- (set-add fn)))]))
+ (set-add (unbox rw-unsafe-pure-functions-set/stateless)
+ fn)))]))
(define-for-syntax (unsafe-pure-function?/stateless id)
(free-id-set-member? unsafe-pure-functions-free-id-set/stateless id)))
@@ -140,7 +141,8 @@
(begin
(free-id-set-add! unsafe-allowed-functions-free-id-set/stateful #'fn)
#'(set-box! rw-unsafe-allowed-functions-set/stateful
- (set-add fn)))]))
+ (set-add (unbox rw-unsafe-allowed-functions-set/stateful)
+ fn)))]))
(define-for-syntax (unsafe-allowed-function?/stateful id)
(free-id-set-member? unsafe-allowed-functions-free-id-set/stateful id)))
@@ -199,6 +201,8 @@
declared-stateless-pure-function?) x) #t]
[(set-member? built-in-pure-functions-set x) #t]
[(set-member? (unsafe-pure-functions-set/stateless) x) #t]
+ [(and (eq? stateful/stateless 'stateful)
+ (set-member? (unsafe-allowed-functions-set/stateful) x)) #t]
;; delay/pure is only used in a safe way, unless the user requires
;; private files
[(eq? x make-promise/pure/stateful) #t]
@@ -228,9 +232,9 @@
(define ((immutable/stateless/c varref) x)
(check-immutable! x varref 'stateless void void))
-(define-for-syntax (make-no-set!-transformer id)
+(define-for-syntax (make-no-set!-transformer id [wrapper #f])
(λ (stx)
- (syntax-case stx (set!)
+ (syntax-case stx ()
[(set-id . rest)
(free-identifier=? #'set-id #'set!)
(raise-syntax-error
@@ -240,11 +244,11 @@
(syntax-e id))
stx
#'set-id)]
- [self (identifier? #'self) id]
+ [self (identifier? #'self) (if wrapper #`(#,wrapper #,id) id)]
[(self . args)
(identifier? #'self)
(datum->syntax (syntax-local-identifier-as-binding #'self)
- `(,id . ,#'args))])))
+ `(,(if wrapper #`(#,wrapper #,id) id) . ,#'args))])))
(begin-for-syntax
(define/contract (pure-impl self fn-stx check-result? stateful/stateless-sym)
@@ -366,30 +370,57 @@
[(self fn #:check-result) (pure-impl #'self #'fn 'check-result 'stateless)])
)
-(define-for-syntax (define-pure/impl stateful/stateless-sym)
- (syntax-parser
- [(self {~optional {~seq {~and fa #:∀} tvars}}
- (name . args)
- (~optional (~seq C:colon result-type))
- body …)
- #:with lam (if (free-identifier=? (datum->syntax #'self 'λ) #'te:λ)
- #'te:λ
- #'λ)
- #:with (maybe-result-type …) (if (attribute result-type)
- #'(C result-type)
- #'())
- #:with pure/? (if (eq? stateful/stateless-sym 'stateful)
- #'pure/stateful
- #'pure/stateless)
- #:with declared-wrapper (if (eq? stateful/stateless-sym 'stateful)
- #'declared-stateful-pure-function
- #'declared-stateless-pure-function)
- (quasisyntax/top-loc this-syntax
- (define name
- (declared-wrapper
- (pure/?
- (lam #,@(when-attr tvars #'(fa tvars)) args maybe-result-type …
- (let () body …))))))]))
+(begin-for-syntax
+ (define-syntax-class (maybe-free-id=? other)
+ #:attributes ()
+ (pattern self:id #:when (or (not other)
+ (free-identifier=? #'self other))))
+
+ (define-syntax-class (name+args+body [other-name #f])
+ (pattern ({~and {~optional {~seq #:∀ tvars}} {~seq fa …}}
+ ({~var name (maybe-free-id=? other-name)} . args)
+ . rest)))
+ (define-syntax-class def
+ (pattern {~and d {~or {~literal define}
+ {~literal te:define}}}
+ #:do [(record-disappeared-uses* #'d)])))
+
+(define-for-syntax ((define-pure/impl stateful/stateless-sym) stx)
+ (with-disappeared-uses
+ (syntax-parse stx
+ [{~or (self {~and whole-τ (CT:colon name/τ:id . self-τ)}
+ (:def . {~var || (name+args+body #'name/τ)}))
+ (self . {~and :name+args+body {~not ((:colon . _) . _)}})}
+ #:with lam (if (free-identifier=? (datum->syntax #'self 'λ) #'te:λ)
+ #'te:λ
+ #'λ)
+ #:with pure/? (if (eq? stateful/stateless-sym 'stateful)
+ #'pure/stateful
+ #'pure/stateless)
+ #:with declared-wrapper (if (eq? stateful/stateless-sym 'stateful)
+ #'declared-stateful-pure-function
+ #'declared-stateless-pure-function)
+ #:with unsafe-free-id-set
+ (if (eq? stateful/stateless-sym 'stateful)
+ #'unsafe-allowed-functions-free-id-set/stateful
+ #'unsafe-pure-functions-free-id-set/stateless)
+ #:with name-impl ((make-syntax-introducer) #'name)
+ (quasisyntax/top-loc this-syntax
+ (begin
+ #,@(when-attr CT #'{(CT name-impl . self-τ)})
+ ;#,@(when-attr whole-τ #'{whole-τ})
+ (define-syntax name (make-no-set!-transformer #'name-impl))
+ (define name-impl
+ (declared-wrapper
+ (pure/?
+ (lam fa … args . rest))))
+ (define-syntax dummy
+ ;; Must happen after defining name-impl, so that the fresh
+ ;; definition is visible. Due to the way Racket handle intdef-ctx
+ ;; it will first run all the macro definitions, and then expand the
+ ;; contents of name-impl (so when expanding the pure/? code,
+ ;; the free-id-set will already be modified.
+ (free-id-set-add! unsafe-free-id-set #'name-impl))))])))
(define-syntax define-pure/stateful (define-pure/impl 'stateful))
(define-syntax define-pure/stateless (define-pure/impl 'stateless))
diff --git a/scribblings/delay-pure.scrbl b/scribblings/delay-pure.scrbl
index 138a8b8..38257b1 100644
--- a/scribblings/delay-pure.scrbl
+++ b/scribblings/delay-pure.scrbl
@@ -105,17 +105,40 @@
@deftogether[
[@defform*[#:literals (:)
- [(define-pure/stateless (name . args) body ...)
- (define-pure/stateless (name . args) : result-type body ...)]]
+ [(define-pure/stateless (name . args) maybe-result body ...)
+ (define-pure/stateless
+ (: name . type)
+ (define (name . args) maybe-result body ...))]]
@defform*[#:literals (:)
- [(define-pure/stateful (name . args) body ...)
- (define-pure/stateful (name . args) : result-type body ...)]]]]{
+ [(define-pure/stateful (name . args) maybe-result body ...)
+ (define-pure/stateful
+ (: name . type)
+ (define (name . args) maybe-result body ...))]
+ #:grammar
+ [(maybe-result (code:line)
+ (code:line : result-type))]]]]{
Defines @racket[name] as a pure function. The @racket[define-pure/stateful]
form relies on @racket[pure/stateful], and therefore allows the function to
return a value containing @tech{stateful} functions. On the other hand,
@racket[define-pure/stateless] relies on @racket[pure/stateless], and
- therefore only allows the return value to contain @tech{stateless} functions.}
+ therefore only allows the return value to contain @tech{stateless} functions.
+
+ Due to the way the function is defined, a regular separate type annotation of
+ the form @racket[(: name type)] would not work (the function is first defined
+ using a temporary variable, and @racket[name] is merely a
+ @tech["rename transformer"
+ #:doc '(lib "scribblings/reference/reference.scrbl")] for that temporary
+ variable).
+
+ It is therefore possible to express such a type annotation by placing both
+ the type annotation and the definition within a @racket[define-pure/stateless]
+ or @racket[define-pure/stateful] form:
+
+ @racketblock[
+ (define-pure/stateless
+ (: square : (→ Number Number))
+ (define (square x) (* x x)))]}
@(define-syntax (show-pure-ids stx)
(with-syntax ([(id ...) (map (λ (id) (datum->syntax #'here (syntax-e id)))
diff --git a/test/test-pure-safe.rkt b/test/test-pure-safe.rkt
index 0a1ec29..1f628cd 100644
--- a/test/test-pure-safe.rkt
+++ b/test/test-pure-safe.rkt
@@ -16,16 +16,17 @@
(define f0
(let ([x (vector-immutable 'a 'b 'c)])
(let ()
- (: f (→ Integer
- (Listof Integer)
- (Rec R (List* Integer Symbol (Promise R)))))
- (define-pure/stateless (f [n : Integer] [big : (Listof Integer)])
- : (Rec R (List* Integer Symbol (Promise R)))
- (cons (length big)
- (cons (vector-ref x (modulo n 3))
- (delay/pure/stateless (f (add1 n)
- (reverse (cons (length big)
- big)))))))
+ (define-pure/stateless
+ (: f (→ Integer
+ (Listof Integer)
+ (Rec R (List* Integer Symbol (Promise R)))))
+ (define (f [n : Integer] [big : (Listof Integer)])
+ : (Rec R (List* Integer Symbol (Promise R)))
+ (cons (length big)
+ (cons (vector-ref x (modulo n 3))
+ (delay/pure/stateless (f (add1 n)
+ (reverse (cons (length big)
+ big))))))))
(f 0 '()))))
;; Check that the first 100 elements are as expected: