diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index f44e68ecc5..d8d5ebdbae 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -3,6 +3,7 @@ (require (for-syntax (rename-in r6rs/private/base-for-syntax [syntax-rules r6rs:syntax-rules]) scheme/base) + scheme/splicing r6rs/private/qq-gen r6rs/private/exns (prefix-in r5rs: r5rs) @@ -546,54 +547,20 @@ ;; ---------------------------------------- -;; let[rec]-syntax needs to be splicing, ad it needs the +;; let[rec]-syntax needs to be splicing, and it needs the ;; same transformer wrapper as in `define-syntax' -(define-for-syntax (do-let-syntax stx rec?) +(define-syntax (r6rs:let-syntax stx) (syntax-case stx () [(_ ([id expr] ...) body ...) - (if (eq? 'expression (syntax-local-context)) - (with-syntax ([let-stx (if rec? - #'letrec-syntax - #'let-syntax)]) - (syntax/loc stx - (let-stx ([id (wrap-as-needed expr)] ...) - (#%expression body) - ...))) - (let ([sli (if (list? (syntax-local-context)) - syntax-local-introduce - values)]) - (let ([ids (map sli (syntax->list #'(id ...)))] - [def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (let* ([add-context - (lambda (expr) - (let ([q (local-expand #`(quote #,expr) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ expr) #'expr])))]) - (with-syntax ([(id ...) - (map sli (map add-context ids))] - [(expr ...) - (let ([exprs (syntax->list #'(expr ...))]) - (if rec? - (map add-context exprs) - exprs))] - [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntax id (wrap-as-needed expr)) - ... - body ...))))))])) - -(define-syntax (r6rs:let-syntax stx) - (do-let-syntax stx #f)) + (syntax/loc stx + (splicing-let-syntax ([id (wrap-as-needed expr)] ...) body ...))])) (define-syntax (r6rs:letrec-syntax stx) - (do-let-syntax stx #t)) + (syntax-case stx () + [(_ ([id expr] ...) body ...) + (syntax/loc stx + (splicing-letrec-syntax ([id (wrap-as-needed expr)] ...) body ...))])) ;; ---------------------------------------- diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 906587efd1..7124f054be 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -49,36 +49,32 @@ (let-stx ([ids expr] ...) (#%expression body) ...))) - (let ([sli (if (list? (syntax-local-context)) - syntax-local-introduce - values)]) - (let ([all-ids (map (lambda (ids) (map sli ids)) all-ids)] - [def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) - (let* ([add-context - (lambda (expr) - (let ([q (local-expand #`(quote #,expr) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ expr) #'expr])))]) - (with-syntax ([((id ...) ...) - (map (lambda (ids) - (map sli (map add-context ids))) - all-ids)] - [(expr ...) - (let ([exprs (syntax->list #'(expr ...))]) - (if rec? - (map add-context exprs) - exprs))] - [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntaxes (id ...) expr) - ... - body ...)))))))])) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (list (gensym 'intdef))]) + (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (let* ([add-context + (lambda (expr) + (let ([q (local-expand #`(quote #,expr) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ expr) #'expr])))]) + (with-syntax ([((id ...) ...) + (map (lambda (ids) + (map add-context ids)) + all-ids)] + [(expr ...) + (let ([exprs (syntax->list #'(expr ...))]) + (if rec? + (map add-context exprs) + exprs))] + [(body ...) + (map add-context (syntax->list #'(body ...)))]) + #'(begin + (define-syntaxes (id ...) expr) + ... + body ...))))))])) (define-syntax (splicing-let-syntax stx) (do-let-syntax stx #f #f)) diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index f13f177a17..b3cf53c677 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1128,6 +1128,57 @@ ((car procs) 'x2 'z2) ((cadr procs) 'x10 'z10)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require scheme/splicing) + +(define abcdefg 10) +(test 12 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg))) +(test 13 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) (abcdefg 10)] + [(_ x) (+ 3 x)])]) + (abcdefg))) +(test 13 'splicing-letrec-syntax (let ([abcdefg 9]) + (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) (abcdefg 10)] + [(_ x) (+ 3 x)])]) + (abcdefg)))) +(test 12 'splicing-let-syntax (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg))) +(test 12 'splicing-let-syntax (let ([abcdefg (lambda () 9)]) + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg)))) +(test 11 'splicing-let-syntax (let ([abcdefg (lambda (x) x)]) + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) (+ 2 (abcdefg 9))] + [(_ ?) 77])]) + (abcdefg)))) +(splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (define hijklmn (abcdefg))) +(test 8 'hijklmn hijklmn) +(test 30 'local-hijklmn (let () + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (define hijklmn (abcdefg))) + (define other 22) + (+ other hijklmn))) +(test 8 'local-hijklmn (let () + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (begin + (define hijklmn (abcdefg)) + hijklmn)))) + +(test 9 'splicing-letrec-syntax (let ([abcdefg (lambda () 9)]) + (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) 0])]) + (define x 10)) + (abcdefg))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 41a2e8ee5c..c483f01bc6 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -3247,6 +3247,35 @@ static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object * return NULL; } +static int nonempty_rib(Scheme_Lexical_Rib *rib) +{ + rib = rib->next; + + while (rib) { + if (SCHEME_RENAME_LEN(rib->rename)) + return 1; + rib = rib->next; + } + + return 0; +} + +static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + while (skip_ribs) { + if (SAME_OBJ(SCHEME_CAR(skip_ribs), timestamp)) + return 1; + skip_ribs = SCHEME_CDR(skip_ribs); + } + + return 0; +} + +static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + return scheme_make_raw_pair(timestamp, skip_ribs); +} + #define QUICK_STACK_SIZE 10 #define EXPLAIN_RESOLVE 0 @@ -3275,7 +3304,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, If neither, result is #f and get_names[0] is either unchanged or NULL. */ { WRAP_POS wraps; - Scheme_Object *o_rename_stack = scheme_null; + Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; Scheme_Object *mresult = scheme_false; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; Scheme_Object *rename_stack[QUICK_STACK_SIZE]; @@ -3286,7 +3315,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; - EXPLAIN(printf("Resolving %s:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))); + EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), + scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); if (_wraps) { WRAP_POS_COPY(wraps, *_wraps); @@ -3553,17 +3583,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) && !no_lexical)) { /* Lexical rename: */ - Scheme_Object *rename, *renamed, *recur_skip_ribs; + Scheme_Object *rename, *renamed; int ri, c, istart, iend, is_rib; if (rib) { rename = rib->rename; - recur_skip_ribs = rib->timestamp; rib = rib->next; is_rib = 1; } else { rename = WRAP_POS_FIRST(wraps); - recur_skip_ribs = skip_ribs; is_rib = 0; } @@ -3658,19 +3686,23 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); EXPLAIN(printf("Rib: %p...\n", rib)); if (skip_ribs) { - if (scheme_bin_gt_eq(rib->timestamp, skip_ribs)) { + if (in_skip_set(rib->timestamp, skip_ribs)) { EXPLAIN(printf("Skip rib\n")); rib = NULL; } } if (rib) { - if (SAME_OBJ(did_rib, rib)) { - EXPLAIN(printf("Did rib\n")); - rib = NULL; - } else { - did_rib = rib; - rib = rib->next; /* First rib record has no rename */ - } + if (nonempty_rib(rib)) { + if (SAME_OBJ(did_rib, rib)) { + EXPLAIN(printf("Did rib\n")); + rib = NULL; + } else { + recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); + did_rib = rib; + rib = rib->next; /* First rib record has no rename */ + } + } else + rib = NULL; } } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { did_rib = NULL; @@ -4372,7 +4404,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS w; WRAP_POS prev; WRAP_POS w2; - Scheme_Object *stack = scheme_null, *key, *old_key; + Scheme_Object *stack = scheme_null, *key, *old_key, *skip_ribs = scheme_null, *orig_skip_ribs; Scheme_Object *v, *v2, *v2l, *stx, *name, *svl; long size, vsize, psize, i, j, pos; @@ -4380,9 +4412,15 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca we can simplify it in the context of a particular wrap suffix. (But don't mutate the wrap list, because that will stomp on tables that might be needed by a propoagation.) + + In addition to depending on the rest of the wraps, a + simplifciation can depend on preceding wraps due to rib + skipping. So the lex_cache maps a wrap to another hash table that + maps a skip list to a simplified rename. A lex_cache maps wrap starts w to simplified tables. A lex_cache - is modified by this function, only. */ + is modified by this function, only, but it's also read in + datum_to_wraps. */ WRAP_POS_INIT(w, wraps); WRAP_POS_INIT_END(prev); @@ -4396,9 +4434,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca key = WRAP_POS_KEY(w); if (!SAME_OBJ(key, old_key)) { v = scheme_hash_get(lex_cache, key); + if (v) + v = scheme_hash_get((Scheme_Hash_Table *)v, skip_ribs); } else v = NULL; old_key = key; + orig_skip_ribs = skip_ribs; if (v) { /* Tables here are already simplified. */ @@ -4412,6 +4453,8 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SCHEME_RIBP(v)) { /* A rib certainly isn't simplified yet. */ add = 1; + if (nonempty_rib((Scheme_Lexical_Rib *)v)) + skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)v)->timestamp, skip_ribs); } else { /* Need to simplify this vector? */ if (SCHEME_VEC_SIZE(v) == 1) @@ -4425,7 +4468,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (add) { /* Need to simplify, but do deepest first: */ if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(stack), key)) { - stack = CONS(key, stack); + stack = CONS(CONS(key, orig_skip_ribs), stack); } } else { /* This is already simplified. Remember it and stop, because @@ -4442,8 +4485,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca while (!SCHEME_NULLP(stack)) { key = SCHEME_CAR(stack); + orig_skip_ribs = SCHEME_CDR(key); + key = SCHEME_CAR(key); v2l = scheme_null; + skip_ribs = orig_skip_ribs; + WRAP_POS_REVINIT(w, key); while (!WRAP_POS_REVEND_P(w)) { @@ -4460,14 +4507,15 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SCHEME_RIBP(v)) { init_rib = (Scheme_Lexical_Rib *)v; - skip_ribs = init_rib->timestamp; - rib = init_rib->next; - vsize = 0; - while (rib) { - vsize += SCHEME_RENAME_LEN(rib->rename); - rib = rib->next; - } - rib = init_rib->next; + if (nonempty_rib(init_rib)) + skip_ribs = scheme_make_pair(init_rib->timestamp, skip_ribs); + rib = init_rib->next; + vsize = 0; + while (rib) { + vsize += SCHEME_RENAME_LEN(rib->rename); + rib = rib->next; + } + rib = init_rib->next; } else vsize = SCHEME_RENAME_LEN(v); @@ -4611,7 +4659,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS_DEC(w); } - scheme_hash_set(lex_cache, key, v2l); + v = scheme_hash_get(lex_cache, key); + if (!v) { + v = (Scheme_Object *)scheme_make_hash_table_equal(); + scheme_hash_set(lex_cache, key, v); + } + scheme_hash_set((Scheme_Hash_Table *)v, skip_ribs, v2l); stack = SCHEME_CDR(stack); } @@ -4622,7 +4675,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, Scheme_Hash_Table *rns, int just_simplify) { - Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null; + Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *skip_ribs = scheme_null; WRAP_POS w; Scheme_Hash_Table *lex_cache, *reverse_map; int stack_size = 0; @@ -4690,8 +4743,13 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, of simplified tables for the current wrap segment. */ if (SCHEME_NULLP(simplifies)) { simplifies = scheme_hash_get(lex_cache, old_key); + simplifies = scheme_hash_get((Scheme_Hash_Table *)simplifies, skip_ribs); /* assert: a is not NULL; see the simplify_lex_rename() call above */ } + if (SCHEME_RIBP(a)) { + if (nonempty_rib((Scheme_Lexical_Rib *)a)) + skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, skip_ribs); + } a = SCHEME_CAR(simplifies); /* used up one simplification: */ simplifies = SCHEME_CDR(simplifies);