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

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,8 +145,8 @@
               [_ (raise-syntax-error 'contract "internal error.5")])))
 	
 	(define local-expand-stop-list 
-          (list 'contract 'define-values 'define-syntaxes 'define-values-for-syntax '#%require
+          (append (list #'contract #'#%require #'#%provide language-level-define-data)
-                '#%provide 'define-data '#%app '#%datum 'define-struct 'begin 'begin0))
+                  (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. 
@@ -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 ...)

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

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
+  accept arguments for automatic fields. Automatic fields are
-  mutable.
+  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])

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
+all keys in the continuation @scheme[cont] (or the current
-@scheme[prompt-tag].  If @scheme[cont] is an escape continuation (see
+continuation of @scheme[cont] if it is a thread) up to the prompt
-@secref["prompt-model"]), then the current continuation must extend
+tagged by @scheme[prompt-tag].  If @scheme[cont] is an escape
-@scheme[cont], or the @exnraise[exn:fail:contract]. If @scheme[cont]
+continuation (see @secref["prompt-model"]), then the current
-was not captured with respect to @scheme[prompt-tag] and does not
+continuation must extend @scheme[cont], or the
-include a prompt for @scheme[prompt-tag], the
+@exnraise[exn:fail:contract]. If @scheme[cont] was not captured with
-@exnraise[exn:fail:contract].}
+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?]{

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

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))))])

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

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
+Scheme forms for expressions and internal-definition positions (so the
-list of stopping points to provide to @scheme[local-expand].}
+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].}

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!

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;

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;
       }

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]))
+  if (!SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]) && !SCHEME_THREADP(argv[0]))
-    scheme_wrong_type("continuation-marks", "continuation", 0, argc, argv);
+    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);

src/mzscheme/src/mzmark.c

@@ -1627,6 +1627,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);
   gcMARK(pr->current_local_name);
@@ -1730,6 +1733,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);
   gcFIXUP(pr->current_local_name);

src/mzscheme/src/mzmarksrc.c

@@ -642,6 +642,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);
   gcMARK(pr->current_local_name);

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;