another int-def binding simplification repair
svn: r12585
This commit is contained in:
Matthew Flatt
parent
06064b856b
commit
5f3b7e5c6f
|
|
@ -1,11 +1,45 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base
|
||||
syntax/kerncase
|
||||
syntax/boundmap))
|
||||
syntax/boundmap
|
||||
syntax/define))
|
||||
|
||||
(provide define-package
|
||||
(provide define*
|
||||
define*-values
|
||||
define*-syntax
|
||||
define*-syntaxes
|
||||
define-package
|
||||
open-package)
|
||||
|
||||
(define-for-syntax (do-define-* stx define-values-id)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for definition"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(with-syntax ([define-values define-values-id])
|
||||
(syntax/loc stx
|
||||
(define-values (id ...) rhs))))]))
|
||||
(define-syntax (define*-values stx)
|
||||
(do-define-* stx #'define-values))
|
||||
(define-syntax (define*-syntaxes stx)
|
||||
(do-define-* stx #'define-syntaxes))
|
||||
|
||||
(define-syntax (define* stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-values (#,id) #,rhs))))
|
||||
(define-syntax (define*-syntax stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-syntaxes (#,id) #,rhs))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct package (exports hidden)
|
||||
#:omit-define-syntaxes
|
||||
|
|
@ -70,14 +104,19 @@
|
|||
(if (pair? orig-ctx)
|
||||
orig-ctx
|
||||
null)))]
|
||||
[pre-package-id (lambda (id)
|
||||
(identifier-remove-from-definition-context
|
||||
id
|
||||
def-ctx))]
|
||||
[kernel-forms (kernel-form-identifier-list)]
|
||||
[pre-package-id (lambda (id def-ctxes)
|
||||
(for/fold ([id id])
|
||||
([def-ctx (in-list def-ctxes)])
|
||||
(identifier-remove-from-definition-context
|
||||
id
|
||||
def-ctx)))]
|
||||
[kernel-forms (list*
|
||||
#'define*-values
|
||||
#'define*-syntaxes
|
||||
(kernel-form-identifier-list))]
|
||||
[init-exprs (syntax->list #'(form ...))]
|
||||
[new-bindings (make-bound-identifier-mapping)]
|
||||
[fixup-sub-package (lambda (renamed-exports renamed-defines)
|
||||
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
|
||||
(lambda (stx)
|
||||
(syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax
|
||||
list cons #%plain-lambda)
|
||||
|
|
@ -101,7 +140,7 @@
|
|||
(bound-identifier=? id e-id))
|
||||
renamed-defines)))
|
||||
;; Need to preserve the original
|
||||
(pre-package-id id)
|
||||
(pre-package-id id def-ctxes)
|
||||
;; It's not accessible, so just hide the name
|
||||
;; to avoid re-binding errors.
|
||||
(car (generate-temporaries (list id)))))
|
||||
|
|
@ -127,20 +166,26 @@
|
|||
id
|
||||
#t))
|
||||
ids))]
|
||||
[add-package-context (lambda (stx)
|
||||
(let ([q (local-expand #`(quote #,stx)
|
||||
ctx
|
||||
(list #'quote)
|
||||
def-ctx)])
|
||||
(syntax-case q ()
|
||||
[(_ stx) #'stx])))])
|
||||
[add-package-context (lambda (def-ctxes)
|
||||
(lambda (stx)
|
||||
(for/fold ([stx stx])
|
||||
([def-ctx (in-list (reverse def-ctxes))])
|
||||
(let ([q (local-expand #`(quote #,stx)
|
||||
ctx
|
||||
(list #'quote)
|
||||
def-ctx)])
|
||||
(syntax-case q ()
|
||||
[(_ stx) #'stx])))))])
|
||||
(let loop ([exprs init-exprs]
|
||||
[rev-forms null]
|
||||
[defined null])
|
||||
[defined null]
|
||||
[def-ctxes (list def-ctx)])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(internal-definition-context-seal def-ctx)
|
||||
(let ([exports-renamed (map add-package-context (or exports null))]
|
||||
(for-each (lambda (def-ctx)
|
||||
(internal-definition-context-seal def-ctx))
|
||||
def-ctxes)
|
||||
(let ([exports-renamed (map (add-package-context def-ctxes) (or exports null))]
|
||||
[defined-renamed (bound-identifier-mapping-map new-bindings
|
||||
(lambda (k v) k))])
|
||||
(for-each (lambda (ex renamed)
|
||||
|
|
@ -165,7 +210,8 @@
|
|||
(bound-identifier-mapping-map new-bindings
|
||||
(lambda (k v) (and v k)))))])
|
||||
#`(begin
|
||||
#,@(map (fixup-sub-package exports-renamed defined-renamed) (reverse rev-forms))
|
||||
#,@(map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
|
||||
(reverse rev-forms))
|
||||
(define-syntax pack-id
|
||||
(make-package
|
||||
(lambda ()
|
||||
|
|
@ -175,40 +221,65 @@
|
|||
(lambda ()
|
||||
(list (quote-syntax hidden) ...)))))))]
|
||||
[else
|
||||
(let ([expr (local-expand (car exprs) ctx kernel-forms def-ctx)])
|
||||
(syntax-case expr (begin define-syntaxes define-values)
|
||||
(let ([expr ((add-package-context (cdr def-ctxes))
|
||||
(local-expand ((add-package-context (cdr def-ctxes)) (car exprs))
|
||||
ctx
|
||||
kernel-forms
|
||||
(car def-ctxes)))])
|
||||
(syntax-case expr (begin)
|
||||
[(begin . rest)
|
||||
(loop (append (syntax->list #'rest) (cdr exprs))
|
||||
rev-forms
|
||||
defined)]
|
||||
[(define-syntaxes (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-syntaxes)
|
||||
(free-identifier=? #'def #'define*-syntaxes))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
||||
(let ([star? (free-identifier=? #'def #'define*-syntaxes)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context)
|
||||
(car def-ctxes))]
|
||||
[ids (if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids)])
|
||||
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons #`(define-syntaxes #,ids rhs)
|
||||
rev-forms)
|
||||
(cons ids defined)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-values)
|
||||
(free-identifier=? #'def #'define*-values))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(let ([star? (free-identifier=? #'def #'define*-values)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context)
|
||||
(car def-ctxes))]
|
||||
[ids (if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids)])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons #'(define-syntaxes (id ...) rhs)
|
||||
rev-forms)
|
||||
(cons ids defined))))]
|
||||
[(define-values (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons expr rev-forms)
|
||||
(cons ids defined)))]
|
||||
(cons #`(define-values #,ids rhs) rev-forms)
|
||||
(cons ids defined)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
|
||||
[else
|
||||
(loop (cdr exprs)
|
||||
(cons #`(define-values () (begin #,expr (values)))
|
||||
rev-forms)
|
||||
defined)]))]))))))]))
|
||||
defined
|
||||
def-ctxes)]))]))))))]))
|
||||
|
||||
(define-syntax (open-package stx)
|
||||
(define-for-syntax (do-open stx define-syntaxes-id)
|
||||
(syntax-case stx ()
|
||||
[(_ pack-id)
|
||||
(let ([id #'pack-id])
|
||||
|
|
@ -239,8 +310,8 @@
|
|||
(syntax-local-introduce (cdr p))))
|
||||
((package-exports v)))]
|
||||
[(h ...) (map syntax-local-introduce ((package-hidden v)))])
|
||||
#'(begin
|
||||
(define-syntaxes (intro ...)
|
||||
#`(begin
|
||||
(#,define-syntaxes-id (intro ...)
|
||||
(let ([rev-map (lambda (x)
|
||||
(reverse-mapping
|
||||
x
|
||||
|
|
@ -250,3 +321,8 @@
|
|||
(list (quote-syntax h) ...)))])
|
||||
(values (make-rename-transformer #'defined rev-map)
|
||||
...))))))))]))
|
||||
|
||||
(define-syntax (open-package stx)
|
||||
(do-open stx #'define-syntaxes))
|
||||
(define-syntax (open*-package stx)
|
||||
(do-open stx #'define*-syntaxes))
|
||||
|
|
|
|||
|
|
@ -4573,7 +4573,7 @@ static int explain_simp = 0;
|
|||
static void print_skips(Scheme_Object *skips)
|
||||
{
|
||||
while (skips) {
|
||||
printf(" skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL));
|
||||
fprintf(stderr, " skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL));
|
||||
skips = SCHEME_CDR(skips);
|
||||
}
|
||||
}
|
||||
|
|
@ -4630,6 +4630,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
|
||||
v2l = scheme_null;
|
||||
|
||||
EXPLAIN_S(fprintf(stderr, "[in simplify]\n"));
|
||||
|
||||
while (!WRAP_POS_END_P(w)) {
|
||||
if (SCHEME_VECTORP(WRAP_POS_FIRST(w))
|
||||
|| SCHEME_RIBP(WRAP_POS_FIRST(w))) {
|
||||
|
|
@ -4704,7 +4706,6 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
|
||||
return NULL;
|
||||
}
|
||||
SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = other_env;
|
||||
}
|
||||
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
|
||||
if (same_marks(&w2, &w, other_env)) {
|
||||
|
|
@ -4789,6 +4790,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL)));
|
||||
ribs_stack = SCHEME_CDR(ribs_stack);
|
||||
vsize = 0;
|
||||
local_ribs = NULL;
|
||||
} else {
|
||||
prec_ribs = SCHEME_CAR(SCHEME_CAR(ribs_stack));
|
||||
skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CDR(SCHEME_CAR(ribs_stack));
|
||||
|
|
@ -4866,8 +4868,14 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
|
||||
other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii];
|
||||
if (SCHEME_VOIDP(other_env)) {
|
||||
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, NULL, 0);
|
||||
SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env;
|
||||
int rib_dep;
|
||||
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0);
|
||||
if (rib_dep) {
|
||||
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
|
||||
return NULL;
|
||||
}
|
||||
if (!rib)
|
||||
SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env;
|
||||
}
|
||||
|
||||
if (!WRAP_POS_END_P(prev)
|
||||
|
|
@ -5033,7 +5041,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
|
||||
if (!prev_prec_ribs) {
|
||||
/* no dependency on ribs, so we can globally cache this result */
|
||||
scheme_hash_set(lex_cache, v, v2l);
|
||||
scheme_hash_set(lex_cache, key, v2l);
|
||||
end_mutable = v2l;
|
||||
}
|
||||
|
||||
|
|
@ -6764,7 +6772,7 @@ Scheme_Object *scheme_new_stx_simplify_cache()
|
|||
void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache)
|
||||
{
|
||||
#if 0
|
||||
if (SAME_OBJ(scheme_intern_symbol("x"), SCHEME_STX_VAL(stx))) {
|
||||
if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) {
|
||||
fprintf(stderr,
|
||||
"simplifying... %s\n",
|
||||
scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0),
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user