From 24880e18a48d4ce2c85d08c1dbf7c860f47c000d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 3 Aug 2006 20:02:24 +0000
Subject: [PATCH] fix verifier for optimizer-introduced raise-arity-error on a
 closure converted to accept a mutable variable reference

svn: r3944
---
 collects/tests/mzscheme/optimize.ss | 27 +++++++++++++++++++++++++++
 src/mzscheme/src/eval.c             | 15 +++++++++++++--
 2 files changed, 40 insertions(+), 2 deletions(-)

diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss
index 008648ac2e..97021bb871 100644
--- a/collects/tests/mzscheme/optimize.ss
+++ b/collects/tests/mzscheme/optimize.ss
@@ -402,4 +402,31 @@
 	      (f y))
 	   '11)
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check bytecode verification of lifted functions
+
+(let ([check
+       (lambda (expr)
+         (let-values ([(r w) (make-pipe)])
+           (write (compile expr) w)
+           (parameterize ([read-accept-compiled #t])
+             (read r))))])
+  (check '(module m mzscheme
+            (provide f)
+            (define (f x)
+              (let loop ([n 0])
+                (set! x (+ n 1)) ; close over mutated variable
+                (loop n #f)
+                (loop n)))))
+  (check '(module m mzscheme
+            (provide f)
+            (define s (make-string 10))
+            (define (f x)
+              (let loop ([n 0])
+                (set! x (+ n 1)) ; close over mutated variable
+                (loop n s) ; and refer to global
+                (loop n))))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (report-errs)
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index 7ff2fbf894..908d5b2618 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -7514,6 +7514,15 @@ int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos,
   return 0;
 }
 
+static int argument_to_arity_error(Scheme_Object *app_rator, int proc_with_refs_ok)
+{
+  /* Since `raise-arity-error' doesn't actually apply its argument,
+     it's ok to pass any procedure. In particular, the compiler generates
+     calls to converted procedures. */
+  return ((proc_with_refs_ok == 2)
+          && SAME_OBJ(app_rator, scheme_raise_arity_error_proc));
+}
+
 void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, 
                           char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
 			  int depth, int letlimit, int delta, 
@@ -7585,7 +7594,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
 	  || (num_stxes && (p == num_toplevels)))
 	scheme_ill_formed_code(port);
       
-      if (proc_with_refs_ok != 1) {
+      if ((proc_with_refs_ok != 1) 
+          && !argument_to_arity_error(app_rator, proc_with_refs_ok)) {
         if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) {
           /* It's a lift. Check that the lift is defined, and that it
              doesn't want reference arguments. */
@@ -7778,7 +7788,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
       char *new_stack;
 
       if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS) {
-        if (proc_with_refs_ok != 1)
+        if ((proc_with_refs_ok != 1)
+            && !argument_to_arity_error(app_rator, proc_with_refs_ok))
           scheme_ill_formed_code(port);
       }