fix certification problems in internal-defn 'begin' and with the 'call-with-values'->'let-values' transformation

svn: r9292

collects/r5rs/main.ss

@@ -4,8 +4,6 @@
            (for-syntax scheme/base syntax/kerncase)
            (only-in mzscheme transcript-on transcript-off))
 
-  (provide (rename-out [r5rs:body #%r5rs:body])) ; Temporary hack!
-
   (provide (for-syntax syntax-rules ...)
            (rename-out
             [mcons cons]
@@ -244,45 +242,49 @@
     (syntax-case stx (r5rs:lambda)
       ((r5rs:letrec ((var1 rhs) ...) body ...)
        (andmap immediate-value? (syntax->list #'(rhs ...)))
-       #'(letrec ((var1 rhs) ...) (r5rs:body body ...)))
+       (syntax/loc stx (letrec ((var1 rhs) ...) (r5rs:body body ...))))
       ((r5rs:letrec ((var1 init1) ...) body ...)
-       #'(r5rs:letrec "generate_temp_names"
+       (syntax/loc stx
+         (r5rs:letrec "generate_temp_names"
                       (var1 ...)
                       ()
                       ((var1 init1) ...)
-                      body ...))
+                      body ...)))
       ((r5rs:letrec "generate_temp_names"
                     ()
                     (temp1 ...)
                     ((var1 init1) ...)
                     body ...)
-       #'(let ((var1 undefined) ...)
+       (syntax/loc stx
+         (let ((var1 undefined) ...)
            (let ((temp1 init1) ...)
              (set! var1 temp1)
              ...
              (let ()
                (r5rs:body
-                body ...)))))
+                body ...))))))
       ((r5rs:letrec "generate_temp_names"
                     (x y ...)
                     (temp ...)
                     ((var1 init1) ...)
                     body ...)
-       #'(r5rs:letrec "generate_temp_names"
+       (syntax/loc stx
+         (r5rs:letrec "generate_temp_names"
                       (y ...)
                       (newtemp temp ...)
                       ((var1 init1) ...)
-                      body ...))))
+                      body ...)))))
 
   (define-syntax (r5rs:lambda stx)
     ;; Convert rest-arg list to mlist, and use r5rs:body:
     (syntax-case stx ()
       [(_ (id ...) . body)
-       #'(#%plain-lambda (id ...) (r5rs:body . body))]
+       (syntax/loc stx (#%plain-lambda (id ...) (r5rs:body . body)))]
       [(_ (id ... . rest) . body)
-       #'(#%plain-lambda (id ... . rest)
+       (syntax/loc stx
+         (#%plain-lambda (id ... . rest)
                          (let ([rest (list->mlist rest)])
-                           (r5rs:body . body)))]))
+                           (r5rs:body . body))))]))
 
   (define-syntax (r5rs:define stx)
     ;; Use r5rs:lambda

src/mzscheme/src/eval.c

@@ -5500,6 +5500,29 @@ static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env)
   return cnt;
 }
 
+static Scheme_Object *cert_ids(Scheme_Object *orig_ids, Scheme_Object *orig)
+{
+  Scheme_Object *id, *ids = orig_ids, *pr, *first = scheme_null, *last = NULL;
+
+  while (!SCHEME_STX_NULLP(ids)) {
+
+    id = SCHEME_STX_CAR(ids);
+    id = scheme_stx_cert(id, NULL, NULL, orig, NULL, 1);
+
+    pr = scheme_make_pair(id, scheme_null);
+    
+    if (last)
+      SCHEME_CDR(last) = pr;
+    else
+      first = pr;
+    last = pr;
+
+    ids = SCHEME_STX_CDR(ids);
+  }
+
+  return scheme_datum_to_syntax(first, orig_ids, orig_ids, 0, 2);
+}
+
 static Scheme_Object *
 compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, 
 		   Scheme_Compile_Expand_Info *rec, int drec)
@@ -5579,6 +5602,9 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
                 /* If we don't check here, the error is in terms of `let': */
                 scheme_dup_symbol_check(&r, NULL, n, "argument", name);
   
+                /* Propagate certifications to bound id: */
+                n = scheme_stx_cert(n, NULL, NULL, name, NULL, 1);
+
                 v = SCHEME_STX_CAR(rest);
                 v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null);
                 if (last)
@@ -5591,16 +5617,19 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
                 rest = SCHEME_STX_CDR(rest);
               }
 
+              body = scheme_datum_to_syntax(icons(begin_symbol, body), form, 
+                                            scheme_sys_wraps(env), 
+                                            0, 2);
+              /* Copy certifications from lambda to `body'. */
+              body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
+              
               body = scheme_datum_to_syntax(cons(let_values_symbol,
                                                  cons(bindings,
-                                                      body)),
+                                                      cons(body, scheme_null))),
                                             form, 
                                             scheme_sys_wraps(env), 
                                             0, 2);
 
-              /* Copy certifications from lambda to `body'. */
-              body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
-		
               return scheme_compile_expand_expr(body, env, rec, drec, 0);
             } else {
 #if 0
@@ -5642,18 +5671,27 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
                 if (SAME_OBJ(gval, scheme_lambda_syntax) 
                     && SCHEME_STX_PAIRP(second)
                     && (arg_count(second, env) >= 0)) {
-                  Scheme_Object *lhs;
+                  Scheme_Object *lhs, *orig_post_first, *orig_post_second;
+                  orig_post_first = first;
+                  orig_post_second = second;
                   second = SCHEME_STX_CDR(second);
                   lhs = SCHEME_STX_CAR(second);
                   second = SCHEME_STX_CDR(second);
                   first = SCHEME_STX_CDR(first);
                   first = SCHEME_STX_CDR(first);
+                  first = icons(begin_symbol, first);
+                  first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1);
+                  second = icons(begin_symbol, second);
+                  second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1);
+                  /* Copy certifications from lambda to body: */
+                  lhs = cert_ids(lhs, orig_post_second);
+                  first = scheme_stx_cert(first, NULL, NULL, orig_post_first, NULL, 1);
+                  second = scheme_stx_cert(second, NULL, NULL, orig_post_second, NULL, 1);
                   /* Convert to let-values: */
                   name = icons(let_values_symbol,
-                               icons(icons(icons(lhs, icons(icons(begin_symbol, first), 
+                               icons(icons(icons(lhs, icons(first, scheme_null)), 
-                                                            scheme_null)), 
                                            scheme_null),
-                                     second));
+                                     icons(second, scheme_null)));
                   form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2);
                   return scheme_compile_expand_expr(form, env, rec, drec, 0);
                 }
@@ -6442,6 +6480,7 @@ scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto)
   for (ll = l; !SCHEME_NULLP(ll); ll = SCHEME_CDR(ll)) {
     a = SCHEME_CAR(ll);
     a = scheme_stx_track(a, expr, name);
+    a = scheme_stx_cert(a, NULL, NULL, expr, NULL, 1);
     SCHEME_CAR(ll) = a;
   }
   

src/mzscheme/src/syntax.c

@@ -4428,6 +4428,8 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
 				       Scheme_Comp_Env *env, 
 				       Scheme_Compile_Info *rec, int drec)
 {
+ try_again:
+
   if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
     /* If it's a begin, we have to check some more... */
     Scheme_Object *first, *val;
@@ -4437,11 +4439,12 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
 
     if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) {      
       /* Flatten begin: */
+      if (scheme_stx_proper_list_length(first) > 0) {
         Scheme_Object *rest;
-      rest = SCHEME_STX_CDR(first);
+        rest = scheme_flatten_begin(first, scheme_null);
-      if (scheme_stx_proper_list_length(rest) > 0) {
         first = scheme_datum_to_syntax(rest, first, first, 0, 2);
-	return scheme_compile_sequence(first, env, rec, drec);
+        forms = first;
+        goto try_again;
       }
     }