fix certification problem with improved compilation of syntax

svn: r4859

collects/tests/mzscheme/stx.ss

@@ -1146,6 +1146,28 @@
 	  (test #t eval '(module-identifier=? (f) #'x))
 	  (test #f eval `(module-identifier=? (f) (quote-syntax ,x-id))))))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;  certification example from the manual
+
+(module @-m mzscheme
+  (provide def-go)
+  (define (unchecked-go n x) 
+    (+ n 17))
+  (define-syntax (def-go stx)
+   (syntax-case stx ()
+     [(_ go)
+      #'(define-syntax (go stx)
+          (syntax-case stx ()
+           [(_ x)
+            #'(unchecked-go 8 x)]))])))
+
+(module @-n mzscheme
+  (require @-m)
+  (def-go go)
+  (go 10)) ; access to unchecked-go is allowed
+
+(require @-n)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

src/mzscheme/src/startup.inc

@@ -1718,7 +1718,9 @@
 "(let((new-e(loop(syntax-e stx))))"
 "(if(eq?(syntax-e stx) new-e)"
 " stx"
-"(datum->syntax-object/shape stx new-e))))"
+"(syntax-recertify"
+"(datum->syntax-object/shape stx new-e)"
+" stx sub-insp #f))))"
 "((vector? stx)"
 "(list->vector(map loop(vector->list stx))))"
 "((box? stx)(box(loop(unbox stx))))"
@@ -1994,6 +1996,7 @@
 "(else"
 "(cons(quote-syntax list*) r))))))))))))"
 " x)))"
+"(-define sub-insp(current-code-inspector))"
 "(provide syntax-case** syntax))"
 );
   EVAL_ONE_STR(

src/mzscheme/src/startup.ss

@@ -2014,7 +2014,9 @@
 	   (let ([new-e (loop (syntax-e stx))])
 	     (if (eq? (syntax-e stx) new-e)
 		 stx
-		 (datum->syntax-object/shape stx new-e)))]
+                 (syntax-recertify
+                  (datum->syntax-object/shape stx new-e)
+                  stx sub-insp #f)))]
 	  [(vector? stx)
 	   (list->vector (map loop (vector->list stx)))]
 	  [(box? stx) (box (loop (unbox stx)))]
@@ -2310,6 +2312,8 @@
 				   (cons (quote-syntax list*) r)]))))))))))
        x)))
 
+  (-define sub-insp (current-code-inspector))
+
   (provide syntax-case** syntax))
 
 ;;----------------------------------------------------------------------