From d62546af81b4eb12f9e8db8c68086cc2d9e49a6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 1 Aug 2016 17:27:18 +0200 Subject: [PATCH] While trying to remove the use-scope which causes problem with my implementation of #, in chunks. Found the solution: syntax-local-identifier-as-binding --- private/common.rkt | 10 ++--- private/lp.rkt | 97 ++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 95 insertions(+), 12 deletions(-) diff --git a/private/common.rkt b/private/common.rkt index e4aea319..bf2f4b74 100644 --- a/private/common.rkt +++ b/private/common.rkt @@ -132,13 +132,13 @@ (syntax-case exprs () [() (void)] [(expr . exprs) - (syntax-case #'expr (define-syntax quote-syntax) + (syntax-case #'expr (define-values quote-syntax) [(define-values (lifted) (quote-syntax (a-chunk id body ...))) (eq? (syntax-e #'a-chunk) 'a-chunk) (begin (add-to-chunk! #'id (syntax->list #'(body ...))) (loop #'exprs))] - [_ + [_ (loop #'exprs)])]))) (require (for-syntax racket/syntax @@ -204,11 +204,11 @@ ;; and make these identifiers exported by ;; hyper-literate (strip-context - #'((define-syntax-rule (if-preexpanding a b) + #'(#;(define-syntax-rule (if-preexpanding a b) b) - (define-syntax-rule (when-preexpanding . b) + #;(define-syntax-rule (when-preexpanding . b) (begin)) - (define-syntax-rule + #;(define-syntax-rule (unless-preexpanding . b) (begin . b)) (require scribble/manual diff --git a/private/lp.rkt b/private/lp.rkt index f9057dc9..4bcbf13b 100644 --- a/private/lp.rkt +++ b/private/lp.rkt @@ -14,11 +14,13 @@ (define (get-chunk-number id) (free-identifier-mapping-get chunk-numbers id (lambda () #f))) (define (inc-chunk-number id) - (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id)))) + (free-identifier-mapping-put! + chunk-numbers id + (+ 1 (free-identifier-mapping-get chunk-numbers id)))) (define (init-chunk-number id) (free-identifier-mapping-put! chunk-numbers id 2))) -(define-for-syntax ((make-chunk racketblock) stx) +(define-for-syntax ((make-chunk racketblock unsyntax?) stx) (syntax-parse stx [(_ (~optional (~seq #:save-as save-as)) name expr ...) ;; no need for more error checking, using chunk for the code will do that @@ -29,9 +31,90 @@ (when n (inc-chunk-number (syntax-local-introduce #'name))) + + ;; Lift the code so that it is caught by `extract-chunks` in common.rkt + ;(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) - (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) - + ;; Convoluted trick to allow unsyntax in chunks of code. The unsyntax + ;; escapes the chunk so that code can be injected at compile-time. + ;; The identifiers inside the escaped portion need to be available both + ;; for-syntax i.e. (for-meta 1) and (for-meta 0). This is because the + ;; underlying @racketblock expands the code at run-time, but the + ;; extract-chunks function in common.rkt looks at the expanded source + ;; code. + ;; For now, only #, i.e. unsyntax is supported, within @chunk. + ;; Later support for UNSYNTAX within @CHUNK may be added. + (if unsyntax? + ;; New hack: + (let () + (display (syntax->datum #'name)) + (display " 1 ") + (displayln (hash-ref (syntax-debug-info #'name) 'context)) + #;(syntax-local-lift-expression + #'(quote-syntax (a-chunk name (expr ...)))) + (syntax-local-lift-module-end-declaration + #'(begin + (require macro-debugger/syntax-browser) + (define-syntax (step3 stx22) + (syntax-case stx22 () + [(_ aaa bbb xxx) + (let () + (define +aaa (make-syntax-delta-introducer #'aaa (datum->syntax #f 'none))) + (define +bbb (make-syntax-delta-introducer (syntax-local-identifier-as-binding #'bbb) (datum->syntax #f 'none))) + (define aaa-bbb (+bbb (+aaa (datum->syntax #f 'none) 'add) 'remove)) + (define bbb-aaa (+aaa (+bbb (datum->syntax #f 'none) 'add) 'remove)) + (define +_aaa-bbb (make-syntax-delta-introducer aaa-bbb (datum->syntax #f 'none))) + (define +_bbb-aaa (make-syntax-delta-introducer aaa-bbb (datum->syntax #f 'none))) + (newline) + (display "aaaU ") (displayln (hash-ref (syntax-debug-info (syntax-local-identifier-as-binding #'aaa)) 'context)) + (display "bbb ") (displayln (hash-ref (syntax-debug-info #'bbb) 'context)) + (display "+aaa ") (displayln (hash-ref (syntax-debug-info (+aaa (datum->syntax #f 'none) 'add)) 'context)) + (display "+bbb ") (displayln (hash-ref (syntax-debug-info (+bbb (datum->syntax #f 'none) 'add)) 'context)) + (display "aaa-bbb ") (displayln (hash-ref (syntax-debug-info aaa-bbb) 'context)) + (display "bbb-aaa ") (displayln (hash-ref (syntax-debug-info bbb-aaa) 'context)) + (syntax-local-lift-expression (+_aaa-bbb #'xxx 'remove)) + #'(void))])) + (define-syntax (fo _) + (define a #'here) + (define b (syntax-local-introduce #'here)) + (define intr (make-syntax-delta-introducer b a)) + + + (display (syntax->datum #'name)) + (display " 2 ") + (displayln (hash-ref (syntax-debug-info #'name) 'context)) + (display "a2 ") + (displayln (hash-ref (syntax-debug-info a) 'context)) + (display "b2 ") + (displayln (hash-ref (syntax-debug-info b) 'context)) + (display "i2 ") + (displayln (hash-ref (syntax-debug-info (intr (datum->syntax #f 'xxx) 'add)) 'context)) + + + #;(syntax-local-lift-expression + #`(quote-syntax (a-chunk xyz + (begin + (displayln "hi") + (require macro-debugger/syntax-browser) + (browse-syntax (quote-syntax (a-chunk name expr ...))))))) + #;(syntax-local-lift-expression + #`(quote-syntax (a-chunk name + ;#,(hash-ref (syntax-debug-info a) 'context) + ;#,(hash-ref (syntax-debug-info b) 'context) + expr ...))) + #;#'(begin) + #`(step3 #,a + #,b + (quote-syntax (a-chunk name + ;#,(hash-ref (syntax-debug-info a) 'context) + ;#,(hash-ref (syntax-debug-info b) 'context) + expr ...)))) + (fo))));(quote-syntax (a-chunk name expr ...))) + ;; Default (old) behaviour, which does not support escaping (via #,): + (syntax-local-lift-expression + #'(quote-syntax (a-chunk name (expr ...))))) + + ;; Extract require forms (with-syntax ([tag tag] [str str] [((for-label-mod ...) ...) @@ -43,7 +126,7 @@ [(null? mods) null] [else (syntax-case (car mods) - (for-syntax quote submod) + (for-syntax quote submod) [(submod ".." . _) (loop (cdr mods))] [(submod "." . _) @@ -82,8 +165,8 @@ #'(define-syntax (save-as s) (syntax pre-content)) #'pre-content))))])) -(define-syntax chunk (make-chunk #'racketblock)) -(define-syntax CHUNK (make-chunk #'RACKETBLOCK)) +(define-syntax chunk (make-chunk #'racketblock #t)) +(define-syntax CHUNK (make-chunk #'RACKETBLOCK #f)) (define-syntax (chunkref stx) (syntax-case stx ()