From bb7d3d1a287a7aabdb11edeb16bf215a028ffe31 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 23 Oct 2008 13:38:03 +0000 Subject: [PATCH] fix 'local-expand' checking of stop list to disallow symbols; extend 'continuation-marks' to work on threads; fix HtDP language module-level stop list svn: r12101 --- .../contracts/contracts-module-begin.ss | 14 ++++---- collects/mzlib/private/sigutil.ss | 4 ++- .../scribblings/guide/define-struct.scrbl | 5 +-- .../scribblings/reference/cont-marks.scrbl | 19 +++++----- .../scribblings/reference/define-struct.scrbl | 4 ++- collects/swindle/setf.ss | 2 +- collects/syntax/kerncase.ss | 1 + collects/syntax/scribblings/kerncase.scrbl | 6 ++-- doc/release-notes/mzscheme/HISTORY.txt | 6 ++++ src/mzscheme/include/scheme.h | 3 ++ src/mzscheme/src/eval.c | 2 +- src/mzscheme/src/fun.c | 36 +++++++++++++++++-- src/mzscheme/src/module.c | 2 +- src/mzscheme/src/mzmark.c | 6 ++++ src/mzscheme/src/mzmarksrc.c | 3 ++ src/mzscheme/src/thread.c | 21 +++++++++++ 16 files changed, 109 insertions(+), 25 deletions(-) diff --git a/collects/lang/private/contracts/contracts-module-begin.ss b/collects/lang/private/contracts/contracts-module-begin.ss index 637a1834a2..2e541c9ad9 100644 --- a/collects/lang/private/contracts/contracts-module-begin.ss +++ b/collects/lang/private/contracts/contracts-module-begin.ss @@ -3,7 +3,8 @@ (require "contracts.ss") (require-for-syntax mzlib/list - syntax/boundmap) + syntax/boundmap + syntax/kerncase) (provide beginner-module-begin intermediate-module-begin advanced-module-begin) @@ -144,9 +145,9 @@ [_ (raise-syntax-error 'contract "internal error.5")]))) (define local-expand-stop-list - (list 'contract 'define-values 'define-syntaxes 'define-values-for-syntax '#%require - '#%provide 'define-data '#%app '#%datum 'define-struct 'begin 'begin0)) - + (append (list #'contract #'#%require #'#%provide language-level-define-data) + (kernel-form-identifier-list))) + ;; parse-contract-expressions ;; takes in a list of top level expressions and a list of contracts, and outputs the correct transformation. ;; 1. expand until we find a definition or a contract @@ -165,7 +166,7 @@ [else (let ([expanded (car exprs)]) - (syntax-case expanded (begin define-values define-data) + (syntax-case expanded (begin define-values) [(define-values (func) e1 ...) (contract-defined? cnt-list expanded) (let ([cnt (get-contract cnt-list expanded)]) @@ -175,7 +176,8 @@ #,(transform-contract ll-contract cnt expanded) #,(loop (remove cnt cnt-list) (cdr exprs)))))] [(define-data name c1 c2 ...) - (identifier? #'name) + (and (identifier? #'name) + (define-data-stx? expanded)) (quasisyntax/loc (car exprs) (begin (#,ll-define-data name c1 c2 ...) diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index f80ebfacba..a99eedf6b5 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -645,7 +645,9 @@ swapped-renames) (loop (cdr e)) (cons (car e) (loop (cdr e)))))))] - [local-vars (append renamed-internals filtered-exported-names imported-names)] + [local-vars (map (lambda (s) + (datum->syntax-object expr s)) + (append renamed-internals filtered-exported-names imported-names))] [expand-context (generate-expand-context)] [import-stxes (apply append (map (lambda (i) (map diff --git a/collects/scribblings/guide/define-struct.scrbl b/collects/scribblings/guide/define-struct.scrbl index 53ca28594a..20b38b3e68 100644 --- a/collects/scribblings/guide/define-struct.scrbl +++ b/collects/scribblings/guide/define-struct.scrbl @@ -393,8 +393,9 @@ A @scheme[_struct-option] always starts with a keyword: Specifies a value to be used for all automatic fields in the structure type, where an automatic field is indicated by the @scheme[#:auto] field option. The constructor procedure does not - accept arguments for automatic fields, and they are implicitly - mutable. + accept arguments for automatic fields. Automatic fields are + implicitly mutable (via reflective operations), but mutator + functions are bound only if @scheme[#:mutator] is also specified. @defexamples[ (define-struct posn (x y [z #:auto]) diff --git a/collects/scribblings/reference/cont-marks.scrbl b/collects/scribblings/reference/cont-marks.scrbl index 21d9f7470d..6252e64928 100644 --- a/collects/scribblings/reference/cont-marks.scrbl +++ b/collects/scribblings/reference/cont-marks.scrbl @@ -46,18 +46,21 @@ continuation's frames to the marks that were present when @scheme[call-with-current-continuation] or @scheme[call-with-composable-continuation] was invoked. -@defproc[(continuation-marks [cont continuation?] +@defproc[(continuation-marks [cont (or/c continuation? thread?)] [prompt-tag prompt-tag? (default-continuation-prompt-tag)]) continuation-mark-set?]{ Returns an opaque value containing the set of continuation marks for -all keys in the continuation @scheme[cont] up to the prompt tagged by -@scheme[prompt-tag]. If @scheme[cont] is an escape continuation (see -@secref["prompt-model"]), then the current continuation must extend -@scheme[cont], or the @exnraise[exn:fail:contract]. If @scheme[cont] -was not captured with respect to @scheme[prompt-tag] and does not -include a prompt for @scheme[prompt-tag], the -@exnraise[exn:fail:contract].} +all keys in the continuation @scheme[cont] (or the current +continuation of @scheme[cont] if it is a thread) up to the prompt +tagged by @scheme[prompt-tag]. If @scheme[cont] is an escape +continuation (see @secref["prompt-model"]), then the current +continuation must extend @scheme[cont], or the +@exnraise[exn:fail:contract]. If @scheme[cont] was not captured with +respect to @scheme[prompt-tag] and does not include a prompt for +@scheme[prompt-tag], the @exnraise[exn:fail:contract]. If +@scheme[cont] is a dead thread, the result is an empty set of +continuation marks.} @defproc[(current-continuation-marks [prompt-tag prompt-tag? (default-continuation-prompt-tag)]) continuation-mark-set?]{ diff --git a/collects/scribblings/reference/define-struct.scrbl b/collects/scribblings/reference/define-struct.scrbl index 5f94b579b3..7d13b77c9a 100644 --- a/collects/scribblings/reference/define-struct.scrbl +++ b/collects/scribblings/reference/define-struct.scrbl @@ -127,7 +127,9 @@ If @scheme[#:auto] is supplied as a @scheme[field-option], then the argument corresponding to the field. Instead, the structure type's automatic value is used for the field, as specified by the @scheme[#:auto-value] option, or as defaults to @scheme[#f] when -@scheme[#:auto-value] is not supplied. +@scheme[#:auto-value] is not supplied. The field is mutable (e.g., +through reflective operations), but a mutator procedure is bound only +if @scheme[#:mutable] is specified. If a @scheme[field] includes the @scheme[#:auto] option, then all fields after it must also include @scheme[#:auto], otherwise a syntax diff --git a/collects/swindle/setf.ss b/collects/swindle/setf.ss index d208953408..0066486297 100644 --- a/collects/swindle/setf.ss +++ b/collects/swindle/setf.ss @@ -44,7 +44,7 @@ ;; need to expand place first, in case it is itself a macro (with-syntax ([place (local-expand #'place 'expression - (append '(#%app #%top #%datum) + (append (list #'#%app #'#%top #'#%datum) (map (lambda (s) (datum->syntax-object #'place s #f)) '(#%app #%top #%datum))))]) diff --git a/collects/syntax/kerncase.ss b/collects/syntax/kerncase.ss index f53a319720..177f650527 100644 --- a/collects/syntax/kerncase.ss +++ b/collects/syntax/kerncase.ss @@ -75,6 +75,7 @@ (define (kernel-form-identifier-list) (syntax-e (quote-syntax (begin + begin0 define-values define-syntaxes define-values-for-syntax diff --git a/collects/syntax/scribblings/kerncase.scrbl b/collects/syntax/scribblings/kerncase.scrbl index c349d19da6..e7665210ae 100644 --- a/collects/syntax/scribblings/kerncase.scrbl +++ b/collects/syntax/scribblings/kerncase.scrbl @@ -44,5 +44,7 @@ primitive PLT Scheme forms.} Returns a list of identifiers that are bound normally, @scheme[for-syntax], and @scheme[for-template] to the primitive PLT -Scheme forms for expressions. This function is useful for generating a -list of stopping points to provide to @scheme[local-expand].} +Scheme forms for expressions and internal-definition positions (so the +list does not include @scheme[#%require] or @scheme[#%provide]). This +function is useful for generating a list of stopping points to provide +to @scheme[local-expand].} diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 124e6ca997..d6feea1e7f 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,9 @@ +Version 4.1.1.3 +Changed binding of identifiers introduced by unit signatures + to take into account the signature use's context +Added make-syntax-delta-introducer +Changed continuation-marks to accept a thread argument + Version 4.1.1.2 Added eqv-based hash tables Added hash-update and hash-update! diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 51c294dcc4..6215692ea7 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1007,6 +1007,9 @@ typedef struct Scheme_Thread { char ran_some; char suspend_to_kill; + struct Scheme_Thread *return_marks_to; + Scheme_Object *returned_marks; + struct Scheme_Overflow *overflow; struct Scheme_Comp_Env *current_local_env; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 5886b1ba8b..9bdf3f4d7f 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -9053,7 +9053,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in Scheme_Object *i; i = SCHEME_CAR(l); - if (!SCHEME_STX_SYMBOLP(i)) { + if (!SCHEME_STXP(i) || !SCHEME_STX_SYMBOLP(i)) { scheme_wrong_type(name, "#f or list of identifier syntax", 2, argc, argv); return NULL; } diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 5a6718b4bc..959909fe81 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -6785,8 +6785,8 @@ cont_marks(int argc, Scheme_Object *argv[]) { Scheme_Object *prompt_tag; - if (!SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0])) - scheme_wrong_type("continuation-marks", "continuation", 0, argc, argv); + if (!SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]) && !SCHEME_THREADP(argv[0])) + scheme_wrong_type("continuation-marks", "continuation or thread", 0, argc, argv); if (argc > 1) { if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) { @@ -6810,6 +6810,38 @@ cont_marks(int argc, Scheme_Object *argv[]) return continuation_marks(scheme_current_thread, NULL, argv[0], mc, prompt_tag, "continuation-marks", 0); } + } else if (SCHEME_THREADP(argv[0])) { + Scheme_Thread *t = (Scheme_Thread *)argv[0]; + Scheme_Object *m; + + if (SAME_OBJ(t, scheme_current_thread)) + return scheme_current_continuation_marks(prompt_tag); + + while (t->return_marks_to) { + scheme_thread_block(0.0); + } + + if (!(t->running & MZTHREAD_RUNNING)) { + /* empty marks */ + Scheme_Cont_Mark_Set *set; + + set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set); + set->so.type = scheme_cont_mark_set_type; + set->chain = NULL; + set->cmpos = 1; + set->native_stack_trace = NULL; + + return (Scheme_Object *)set; + } else { + t->return_marks_to = scheme_current_thread; + t->returned_marks = prompt_tag; + scheme_swap_thread(t); + + m = t->returned_marks; + t->returned_marks = NULL; + + return m; + } } else { return continuation_marks(NULL, argv[0], NULL, NULL, prompt_tag, "continuation-marks", 0); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 72ba911c39..01f6033eb2 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -2918,7 +2918,7 @@ static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx, scheme_push_continuation_frame(&cframe); scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); } - + name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a); if (env) { diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 6763b55411..41b09f93d2 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -1626,6 +1626,9 @@ static int thread_val_MARK(void *p) { gcMARK(pr->blocker); gcMARK(pr->overflow); + + gcMARK(pr->return_marks_to); + gcMARK(pr->returned_marks); gcMARK(pr->current_local_env); gcMARK(pr->current_local_mark); @@ -1729,6 +1732,9 @@ static int thread_val_FIXUP(void *p) { gcFIXUP(pr->blocker); gcFIXUP(pr->overflow); + + gcFIXUP(pr->return_marks_to); + gcFIXUP(pr->returned_marks); gcFIXUP(pr->current_local_env); gcFIXUP(pr->current_local_mark); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 056e906e7b..8530a366e0 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -641,6 +641,9 @@ thread_val { gcMARK(pr->blocker); gcMARK(pr->overflow); + + gcMARK(pr->return_marks_to); + gcMARK(pr->returned_marks); gcMARK(pr->current_local_env); gcMARK(pr->current_local_mark); diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 419a232bfd..eda7503c4c 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -2413,8 +2413,19 @@ int scheme_in_main_thread(void) return !scheme_current_thread->next; } +static void stash_current_marks() +{ + Scheme_Object *m; + m = scheme_current_continuation_marks(scheme_current_thread->returned_marks); + scheme_current_thread->returned_marks = m; + swap_target = scheme_current_thread->return_marks_to; + scheme_current_thread->return_marks_to = NULL; +} + static void do_swap_thread() { + start: + scheme_zero_unneeded_rands(scheme_current_thread); #if WATCH_FOR_NESTED_SWAPS @@ -2454,6 +2465,11 @@ static void do_swap_thread() && ((*scheme_current_thread->cont_mark_stack_owner) != scheme_current_thread))) { scheme_takeover_stacks(scheme_current_thread); } + + if (scheme_current_thread->return_marks_to) { + stash_current_marks(); + goto start; + } } else { Scheme_Thread *new_thread = swap_target; @@ -2769,6 +2785,11 @@ static void start_child(Scheme_Thread * volatile child, exit_or_escape(scheme_current_thread); } + if (scheme_current_thread->return_marks_to) { + stash_current_marks(); + do_swap_thread(); + } + { mz_jmp_buf newbuf; scheme_current_thread->error_buf = &newbuf;