Partially reverted previous commit.

This commit is contained in:
Georges Dupéron 2017-01-25 01:33:15 +01:00
parent 29c90350b2
commit 5d2f8cc512
7 changed files with 14 additions and 181 deletions

View File

@ -1,3 +0,0 @@
(module steal-box '#%kernel
(define-values (bx) (box #f))
(#%provide bx))

View File

@ -1,59 +0,0 @@
#lang racket
;; Manages to grasp the template-metafunction via (namespace-mapped-symbols)
;; within the eval.
(module extracted-template-metafunction racket/base
(require (for-syntax syntax/parse/experimental/template)
(for-syntax racket/base)
(for-meta 2 racket/base)
(for-meta 2 stxparse-info/parse/experimental/steal-box))
(define-syntax (fu stx)
(syntax-case stx ()
[(_ id-mf? id-mf-v)
(let ()
(eval #'(begin
(require (for-syntax
stxparse-info/parse/experimental/steal-box))
(define-template-metafunction (mf stx)
#'1)
(define-syntax (extract stx)
;; Use 3D syntax to return the value:
(displayln (namespace-mapped-symbols))
;(displayln (eval 'template-metafunction))
(define ctor (namespace-variable-value
(for/first ([sym (namespace-mapped-symbols)]
#:when (regexp-match #rx"template-metafunction[0-9].*" (symbol->string sym)))
sym)))
(displayln (list ctor (ctor 5165163)))
(displayln (template-metafunction? (syntax-local-value #'mf)))
(set-box! bx template-metafunction?)
#'(void)
#;#`(values #,template-metafunction?
#,template-metafunction-var))
(extract))
(module->namespace 'syntax/parse/experimental/template))
#`(begin
(define-for-syntax id-mf? 0)
(define-for-syntax id-mf-v 1)))]))
(fu out-id-mf? out-id-mf-v)
(begin-for-syntax
(define-for-syntax rsl bx))
#;(begin-for-syntax
(define-syntax (br stx)
(displayln rsl)
#'(void))
(br))
#;(begin-for-syntax
(begin-for-syntax
(displayln rsl)))
(provide (for-meta 2 rsl #;out-id-mf? #;out-id-mf-v)))
#;(require (rename-in (for-template 'extracted-template-metafunction)
[out-id-mf? template-metafunction?]
[out-id-mf-v template-metafunction-var]))
(require (for-meta -2 'extracted-template-metafunction))
(displayln rsl)
#;(provide template-metafunction?
template-metafunction-var)

View File

@ -1,25 +0,0 @@
#lang racket
(require (for-syntax syntax/parse/experimental/template)
(for-syntax racket/base)
(for-meta 2 racket/base)
(for-meta 2 stxparse-info/parse/experimental/steal-box))
(begin-for-syntax
(eval #'(begin (define-syntax (e2 stx)
#`(begin
(module #,(cdr (syntax-e stx)) racket
(provide (for-syntax e4a e4b))
;(require syntax/parse/experimental/template)
(define-for-syntax e4a #,template-metafunction?)
(define-for-syntax e4b #,template-metafunction-var)
(module* e5 racket/base
(require (for-template (submod "..")))
(provide e4a e4b)))))
(e2 . e3))
(module->namespace 'syntax/parse/experimental/template))
(define e5a (dynamic-require '(submod 'e3 e5) 'e4a))
(define e5b (dynamic-require '(submod 'e3 e5) 'e4b))
(provide (rename-out [e5a template-metafunction?]
[e5b template-metafunction-var])))

View File

@ -16,64 +16,6 @@
??
?@)
;; This is a bit ugly. Also, we can't extract the constructor for some reason
;; (probably because it is a transformer binding, not a variable),
;; so we require the original `define-template-metafunction` from
;; syntax/parse/experimental/template to fulfill the defintition below.
(require (only-in syntax/parse/experimental/template
define-template-metafunction))
(begin-for-syntax
(require "steal-metafunction.rkt")
(provide template-metafunction?
template-metafunction-var))
#;(begin
(require (only-in syntax/parse/experimental/template
define-template-metafunction))
(begin-for-syntax
(module extracted-template-metafunction racket/base
(require syntax/parse/experimental/template
(for-syntax racket/base))
(define-values (template-metafunction?
;template-metafunction
template-metafunction-var)
(eval #'(begin
(define-syntax (extract stx)
;; Use 3D syntax to return the value:
#`(values #,template-metafunction?
;; Doesn't work, probably because it's a macro:
;#,template-metafunction
#,template-metafunction-var))
(extract))
(module->namespace 'syntax/parse/experimental/template)))
(provide template-metafunction?
;template-metafunction
template-metafunction-var))
(require 'extracted-template-metafunction)
(provide template-metafunction?
template-metafunction-var)
;; Tests:
#;(begin
(require rackunit)
(require 'extracted-template-metafunction)
(require (for-meta 4 'extracted-template-metafunction))
(check-equal? (format "~a" template-metafunction?)
"#<procedure:template-metafunction?>")
(require (for-meta 1 racket/base))
(require (for-meta 2 racket/base))
(require (for-meta 3 racket/base))
(require (for-meta 4 racket/base))
(begin-for-syntax
(begin-for-syntax
(begin-for-syntax
(begin-for-syntax
(require rackunit)
(check-equal? (format "~a" template-metafunction?)
"#<procedure:template-metafunction?>"))))))))
#|
To do:
- improve error messages
@ -244,7 +186,10 @@ instead of integers and integer vectors.
;; ============================================================
#;(define-syntax (define-template-metafunction stx)
;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use
;; the exported prop:template-metafunction, template-metafunction? and
;; template-metafunction-accessor.
(define-syntax (define-template-metafunction stx)
(syntax-case stx ()
[(dsm (id arg ...) . body)
#'(dsm id (lambda (arg ...) . body))]
@ -256,9 +201,7 @@ instead of integers and integer vectors.
(template-metafunction (quote-syntax internal-id)))))]))
(begin-for-syntax
;; This struct is not declared here, but instead extracted from the official
;; syntax/parse/experimental/template, at the top of this file.
#;(struct template-metafunction (var)))
(struct template-metafunction (var)))
;; ============================================================

View File

@ -1,14 +0,0 @@
#lang racket
(require syntax/parse/experimental/template
stxparse-info/parse/experimental/steal-metafunction2)
(define-template-metafunction (mf stx)
#'1)
(provide mf)
(let ()
(define-syntax (foo stx)
(displayln
(template-metafunction?
(syntax-local-value #'mf)))
#''ok)
(foo))

View File

@ -1,8 +1,6 @@
#lang racket
(require ;syntax/parse
;syntax/parse/experimental/template
stxparse-info/parse
stxparse-info/parse/experimental/template)
(require syntax/parse
syntax/parse/experimental/template)
(provide mf original-template)
(define-template-metafunction (mf stx)
#'ok-metafunction-official-1)

View File

@ -1,23 +1,16 @@
#lang racket
(require ;syntax/parse
;syntax/parse/experimental/template
stxparse-info/parse
(require stxparse-info/parse
stxparse-info/parse/experimental/template
rackunit
#;"test-compatibility1.rkt")
(define-template-metafunction (mf stx)
#'ok-metafunction-official-1)
"test-compatibility1.rkt")
;; TODO: re-enable this, and do the test the other way round too
;; (the official syntax/parse to from stxparse-info)
#;(check-equal? (syntax-parse #'(1 (2 3))
[(x {~optional y} ({~optional z} t))
(list #;(syntax->datum
(original-template (x (?? y no-y) (?? z no-z) t (mf))))
(list (syntax->datum
(original-template (x (?? y no-y) (?? z no-z) t (mf))))
(syntax->datum
(template (x (?? y no-y) (?? z no-z) t (mf)))))])
'(#;(1 no-y 2 3 ok-metafunction-official-1)
'((1 no-y 2 3 ok-metafunction-official-1)
(1 no-y 2 3 ok-metafunction-official-1)))
(syntax-parse #'(1 (2 3))
[(x {~optional y} ({~optional z} t))
(syntax->datum
(template (x (?? y no-y) (?? z no-z) t (mf))))])