diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index ca90839973..7e38db918d 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1089,12 +1089,13 @@ (define max-call-head-width 5) (define (no-sharing? expr count apair? acdr) - (if (and found - (apair? expr) - (hash-table-get found (acdr expr) #f)) - #f - (or (zero? count) - (no-sharing? (acdr expr) (sub1 count) apair? acdr)))) + (if (apair? expr) + (if (and found + (hash-table-get found (acdr expr) #f)) + #f + (or (zero? count) + (no-sharing? (acdr expr) (sub1 count) apair? acdr))) + #f)) (define (style head expr apair? acar acdr) (case (look-in-style-table head) diff --git a/collects/mzlib/private/shared-body.ss b/collects/mzlib/private/shared-body.ss index 92ecd0948e..756c7bc3f3 100644 --- a/collects/mzlib/private/shared-body.ss +++ b/collects/mzlib/private/shared-body.ss @@ -56,6 +56,7 @@ (and (cadr decl) (andmap values (list-ref decl 4)) decl)))))))))] + [append-ids null] [same-special-id? (lambda (a b) ;; Almost module-or-top-identifier=?, ;; but handle the-cons specially @@ -84,7 +85,7 @@ ph)) names placeholder-ids ph-used?s)) (loop expr))) - (syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id? + (syntax-case* expr (the-cons mcons append box box-immutable vector vector-immutable) same-special-id? [(the-cons a d) (with-syntax ([a (cons-elem #'a)] [d (cons-elem #'d)]) @@ -95,13 +96,28 @@ (syntax (mcons undefined undefined))] [(mcons . _) (bad "mcons")] - [(list e ...) + [(lst e ...) + (ormap (lambda (x) (free-identifier=? x #'lst)) + (syntax->list #'(list list*))) (with-syntax ([(e ...) (map (lambda (x) (cons-elem x)) (syntax->list (syntax (e ...))))]) - (syntax/loc expr (list e ...)))] - [(list . _) - (bad "list")] + (syntax/loc expr (lst e ...)))] + [(lst . _) + (ormap (lambda (x) (free-identifier=? x #'lst)) + (syntax->list #'(list list*))) + (bad (syntax-e #'lst))] + [(append e0 ... e) + (let ([len-id (car (generate-temporaries '(len)))]) + (set! append-ids (cons len-id append-ids)) + (with-syntax ([e (cons-elem #'e)] + [len-id len-id]) + (syntax/loc expr (let ([ph (make-placeholder e)] + [others (append e0 ... null)]) + (set! len-id (length others)) + (append others ph)))))] + [(append . _) + (bad "append")] [(box v) (syntax (box undefined))] [(box . _) @@ -143,10 +159,12 @@ [(init-expr ...) (map (lambda (expr temp-id used?) (let ([init-id - (syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id? + (syntax-case* expr (the-cons mcons list list* append box box-immutable vector vector-immutable) same-special-id? [(the-cons . _) temp-id] [(mcons . _) temp-id] [(list . _) temp-id] + [(list* . _) temp-id] + [(append . _) temp-id] [(box . _) temp-id] [(box-immutable . _) temp-id] [(vector . _) temp-id] @@ -170,11 +188,13 @@ (if (null? l) null (cons (datum->syntax (quote-syntax here) n #f) - (loop (cdr l) (add1 n))))))]) + (loop (cdr l) (add1 n))))))] + [append-ids (reverse append-ids)]) (map (lambda (name expr) (let loop ([name name] [expr expr]) (with-syntax ([name name]) - (syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id? + (syntax-case* expr (the-cons mcons list list* append box box-immutable vector vector-immutable) + same-special-id? [(the-cons a d) #`(begin #,(loop #`(car name) #'a) #,(loop #`(cdr name) #'d))] @@ -189,6 +209,23 @@ (loop #`(list-ref name #,n) e)) (gen-n es) es)))] + [(list* e ...) + (let* ([es (syntax->list #'(e ...))] + [last-n (sub1 (length es))]) + #`(begin + #,@(map (lambda (n e) + (loop #`(#,(if (= (syntax-e n) last-n) + #'list-tail + #'list-ref) + name + #,n) + e)) + (gen-n es) + es)))] + [(append e0 ... e) + (with-syntax ([len-id (car append-ids)]) + (set! append-ids (cdr append-ids)) + (loop #`(list-tail name len-id) #'e))] [(box v) (syntax (set-box! name v))] [(box-immutable v) @@ -241,9 +278,11 @@ (and (unbox ph-used?) #`(placeholder-set! #,ph #,graph-expr))) placeholder-ids ph-used?s - (syntax->list #'(graph-expr ...))))]) + (syntax->list #'(graph-expr ...))))] + [(append-id ...) append-ids]) (syntax/loc stx (letrec-values ([(used-ph-id) (make-placeholder #f)] ... + [(append-id) #f] ... [(temp-id ...) (begin ph-init ... diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index a755f01c56..36356c5413 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -69,20 +69,22 @@ ;; keyword setup ;;-------------------------------------------------------------------- + (define-for-syntax (do-class-keyword stx) + (if (identifier? stx) + (raise-syntax-error + #f + "illegal (unparenthesized) use of a class keyword" + stx) + (raise-syntax-error + #f + "use of a class keyword is not in a class top-level" + stx))) + (define-syntax provide-class-keyword (syntax-rules () [(_ id ...) (begin - (define-syntax (id stx) - (if (identifier? stx) - (raise-syntax-error - #f - "illegal (unparenthesized) use of a class keyword" - stx) - (raise-syntax-error - #f - "use of a class keyword is not in a class top-level" - stx))) + (define-syntax (id stx) (do-class-keyword stx)) ... (provide id ...))])) @@ -94,43 +96,47 @@ inspect init-rest) + (define-for-syntax (do-define-like-internal stx) + (syntax-case stx () + [(_ orig . __) + (raise-syntax-error + #f + "use of a class keyword is not in a class top-level" + #'orig)])) + + (define-for-syntax (do-define-like stx internal-id) + (syntax-case stx () + [(_ elem ...) + (syntax-property + #`(#,internal-id #,stx + #,@(map (lambda (e) + (if (identifier? e) + e + (syntax-property + (syntax-case e () + [((n1 n2) . expr) + (quasisyntax/loc e + (#,(syntax-property + #'(n1 n2) + 'certify-mode 'transparent) + . expr))] + [_else e]) + 'certify-mode 'transparent))) + (syntax-e #'(elem ...)))) + 'certify-mode + 'transparent)] + [(_ . elems) + #`(#,internal-id #,stx . elems)] + [_else + (raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)])) + (define-syntax provide-class-define-like-keyword (syntax-rules () [(_ [internal-id id] ...) (begin - (define-syntax (internal-id stx) - (syntax-case stx () - [(_ orig . __) - (raise-syntax-error - #f - "use of a class keyword is not in a class top-level" - #'orig)])) + (define-syntax (internal-id stx) (do-define-like-internal stx)) ... - (define-syntax (id stx) - (syntax-case stx () - [(_ elem (... ...)) - (syntax-property - #`(internal-id #,stx - #,@(map (lambda (e) - (if (identifier? e) - e - (syntax-property - (syntax-case e () - [((n1 n2) . expr) - (quasisyntax/loc e - (#,(syntax-property - #'(n1 n2) - 'certify-mode 'transparent) - . expr))] - [_else e]) - 'certify-mode 'transparent))) - (syntax-e #'(elem (... ...))))) - 'certify-mode - 'transparent)] - [(_ . elems) - #`(internal-id #,stx . elems)] - [_else - (raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)])) + (define-syntax (id stx) (do-define-like stx #'internal-id)) ... (provide id ...))])) @@ -139,6 +145,14 @@ [-init init] [-init-field init-field]) + + (define-for-syntax not-in-a-class + (lambda (stx) + (raise-syntax-error + #f + "use of a class keyword is not in a class" + stx))) + (define-syntax define/provide-context-keyword (syntax-rules () [(_ (id param-id) ...) @@ -146,12 +160,7 @@ (begin (provide id) (define-syntax-parameter param-id - (make-set!-transformer - (lambda (stx) - (raise-syntax-error - #f - "use of a class keyword is not in a class" - stx)))) + (make-set!-transformer not-in-a-class)) (define-syntax id (make-parameter-rename-transformer #'param-id))) ...)])) diff --git a/collects/scribblings/reference/shared.scrbl b/collects/scribblings/reference/shared.scrbl index dbb40059ca..b52849df9e 100644 --- a/collects/scribblings/reference/shared.scrbl +++ b/collects/scribblings/reference/shared.scrbl @@ -38,14 +38,16 @@ following @scheme[_shared-expr] grammar, where earlier variants in a production take precedence over later variants: @schemegrammar*[ -#:literals (cons list vector-immutable box-immutable mcons vector box) +#:literals (cons list list* append vector-immutable box-immutable mcons vector box) [shared-expr shell-expr plain-expr] [shell-expr (cons in-immutable-expr in-immutable-expr) (list in-immutable-expr ...) + (list* in-immutable-expr ...) + (append early-expr ... in-immutable-expr) (vector-immutable in-immutable-expr ...) (box-immutable in-immutable-expr) - (mcons patchable-expr) + (mcons patchable-expr patchable-expr) (vector patchable-expr ...) (box patchable-expr ...) (#, @|maker| patchable-expr ...)] @@ -67,7 +69,7 @@ be one of the @scheme[id]s bound by the @scheme[shared] form to a When the @scheme[expr]s of the @scheme[shared] form are parsed via @scheme[_shared-expr] (taking into account the order of the variants -for precedence), and sub-expression that parses via +for precedence), and sub-expressions that parse via @scheme[_early-expr] will be evaluated first when the @scheme[shared] form is evaluated. Among such expressions, they are evaluated in the order as they appear within the @scheme[shared] form. However, any @@ -90,7 +92,7 @@ where a reference to an @scheme[id] produces @|undefined-const| if it is evaluated before the right-hand side of the @scheme[id] binding. Finally, the @scheme[_patchable-expr]s are evaluated. At this point, -all @scheme[id]s are bound, so @scheme[_patchable-expr]s also created +all @scheme[id]s are bound, so @scheme[_patchable-expr]s also creates data cycles (but only with cycles that can be created via mutation). @examples[ diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index b8b2e87440..cd8e37baa3 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -1317,7 +1317,7 @@ void GC_register_new_thread(void *t, void *c) /* administration / initialization */ /*****************************************************************************/ -int designate_modified(void *p) +static int designate_modified(void *p) { NewGC *gc = GC_get_GC(); struct mpage *page = pagemap_find_page(gc->page_maps, p); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index ad1128d326..a31ef7c2e1 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -4494,14 +4494,14 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca (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, but it's also read in - datum_to_wraps. */ + datum_to_wraps. + + In addition to depending on the rest of the wraps, a + simplification 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. */ WRAP_POS_INIT(w, wraps); WRAP_POS_INIT_END(prev); @@ -4548,7 +4548,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)) { + if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(SCHEME_CAR(stack)), key)) { stack = CONS(CONS(key, orig_skip_ribs), stack); } } else { @@ -4576,7 +4576,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca while (!WRAP_POS_REVEND_P(w)) { v = WRAP_POS_FIRST(w); - + if (SCHEME_RIBP(v) || (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ @@ -4734,6 +4734,21 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca SCHEME_VEC_ELS(v2)[0] = scheme_false; SCHEME_VEC_ELS(v2)[1] = scheme_false; + { + /* Sometimes we generate the same simplified lex table, so + look for an equivalent one in the cache. */ + v = scheme_hash_get(lex_cache, scheme_true); + if (!v) { + v = (Scheme_Object *)scheme_make_hash_table_equal(); + scheme_hash_set(lex_cache, scheme_true, v); + } + svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); + if (svl) + v2 = svl; + else + scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); + } + v2l = CONS(v2, v2l); }