added optional 3rd argument to drscheme:language:add-snip-value to support initializing the user's namespace

svn: r3910

collects/drscheme/private/drsig.ss

@@ -229,6 +229,7 @@
      simple-module-based-language-config-panel
      
      add-snip-value
+     setup-setup-values
 
      register-capability
      capability-registered?

collects/drscheme/private/language.ss

@@ -1128,9 +1128,10 @@
       ;;
       
       (define to-snips null)
-      (define-struct to-snip (predicate? >value))
+      (define-struct to-snip (predicate? >value setup-thunk))
-      (define (add-snip-value predicate constructor)
+      (define add-snip-value
-        (set! to-snips (cons (make-to-snip predicate constructor) to-snips)))
+        (opt-lambda (predicate constructor [setup-thunk void])
+          (set! to-snips (cons (make-to-snip predicate constructor setup-thunk) to-snips))))
       
       (define (value->snip v)
         (ormap (λ (to-snip) (and ((to-snip-predicate? to-snip) v)
@@ -1138,6 +1139,8 @@
                to-snips))
       (define (to-snip-value? v)
         (ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
+      (define (setup-setup-values) 
+        (for-each (λ (t) ((to-snip-setup-thunk t))) to-snips))
       
       
       (define capabilities '())

collects/drscheme/private/rep.ss

@@ -34,6 +34,27 @@ TODO
   
   (provide rep@)
 
+  (define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name"))
+  
+  ;; this macro wraps its argument expression in some code in a non-tail manner
+  ;; so that a new name gets put onto the mzscheme stack. DrScheme's exception
+  ;; handlers trims the stack starting at this point to avoid showing drscheme's
+  ;; internals on the stack in the REPL.
+  (define-syntax (with-stacktrace-name stx)
+    (syntax-case stx ()
+      [(_ e)
+       (with-syntax ([my-funny-name (syntax-local-value #'stacktrace-name)])
+         (syntax
+          (let ([my-funny-name (λ () (begin0 e (random 1)))]) 
+            ((if (zero? (random 1)) 
+                 my-funny-name
+                 values)))))]))
+  
+  (define stacktrace-runtime-name
+    (let-syntax ([m (λ (x) (with-syntax ([x (syntax-local-value #'stacktrace-name)])
+                             (syntax 'x)))])
+      (m)))
+  
   (define rep@
     (unit/sig drscheme:rep^
       (import (drscheme:init : drscheme:init^)
@@ -228,8 +249,7 @@ TODO
       
       (define (cut-out-top-of-stack exn)
         (let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))])
-          (let loop ([stack (reverse initial-stack)]
+          (let loop ([stack initial-stack])
-                     [hit-2? #f])
             (cond
               [(null? stack) 
                (unless (exn:break? exn)
@@ -241,27 +261,17 @@ TODO
               [else 
                (let ([top (car stack)])
                  (cond
-                   [(is-cut? top 'cut-stacktrace-above-here1)
+                   [(cut-here? top) null]
-                    (if hit-2?
+                   [else (cons top (loop (cdr stack)))]))]))))
-                        (reverse (cdr stack))
-                        (begin
-                          (fprintf (current-error-port) "ACK! found 1 without 2\n")
-                          initial-stack))]
-                   [(is-cut? top 'cut-stacktrace-above-here2)
-                    (if hit-2?
-                        (reverse (cdr stack))
-                        (loop (cdr stack) #t))]
-                   [else
-                    (loop (cdr stack) hit-2?)]))]))))
       
       ;; is-cut? : any symbol -> boolean
       ;; determines if this stack entry is really 
-      (define (is-cut? top sym)
+      (define (cut-here? top)
         (and (pair? top)
              (let* ([fn-name (car top)]
                     [srcloc (cdr top)]
                     [source (and srcloc (srcloc-source srcloc))])
-               (and (eq? fn-name sym) 
+               (and (eq? fn-name stacktrace-runtime-name) 
                     (path? source)
                     (let loop ([path source]
                                [pieces '(#"rep.ss" #"private" #"drscheme" #"collects")])
@@ -1048,13 +1058,7 @@ TODO
                       
                       (λ () 
                         (let loop ()
-                          (let ([sexp/syntax/eof 
+                          (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))])
-                                 ;; this named thunk & application helps drscheme know to cut 
-                                 ;; off part of the stack trace. (too bad not all of it ...)
-                                 ((rec cut-stacktrace-above-here1
-                                    (λ ()
-                                      (begin0 (get-sexp/syntax/eof)
-                                              (void)))))])
                             (unless (eof-object? sexp/syntax/eof)
                               (call-with-break-parameterization
                                (get-user-break-parameterization)
@@ -1064,10 +1068,8 @@ TODO
                                ;; break exn.
                                (λ ()
                                  (call-with-values
-                                  (rec cut-stacktrace-above-here1
                                   (λ ()
-                                      (begin0 (eval-syntax sexp/syntax/eof)
+                                    (with-stacktrace-name (eval-syntax sexp/syntax/eof)))
-                                              (void))))
                                   (λ x (display-results x)))))
                               (loop))))
                         (set! cleanup? #t))
@@ -1210,6 +1212,21 @@ TODO
                     (let ([run-on-user-thread (lambda (t) (queue-user/wait t))])
                       run-on-user-thread))
               
+              ;; setup the special repl values
+              (let ([raised-exn? #f]
+                    [exn #f])
+                (queue-user/wait
+                 (λ () ; =User=, =No-Breaks=
+                   (with-handlers ((void (λ (x) 
+                                           (set! exn x)
+                                           (set! raised-exn? #t))))
+                     (drscheme:language:setup-setup-values))))
+                (when raised-exn?
+                  (fprintf 
+                   (current-error-port)
+                   "copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n")
+                  (raise exn)))
+              
               ;; installs the teachpacks
               ;; must happen after language is initialized.
               (queue-user/wait

collects/drscheme/private/tool-contracts.ss

@@ -966,15 +966,19 @@
   
   
   (drscheme:language:add-snip-value
-   (-> (-> any/c boolean?)
+   (opt-> ((-> any/c boolean?)
-       (-> any/c (is-a?/c snip%))
+           (-> any/c (is-a?/c snip%)))
+          ((-> any/c))
           void?)
-   (test-value convert-value)
+   (test-value convert-value (setup-thunk void))
    "Registers a handler to convert values into snips as they are printed in the REPL."
    ""
-   "The \\var{test-snip} argument is called to determine if this handler can convert the value"
+   "The \\var{test-snip} argument is called to determine if this handler can convert the value "
-   "and the \\var{convert-value} argument is called to build a snip."
+   "and the \\var{convert-value} argument is called to build a snip. "
-   "Both functions are called on the user's thread and with the user's settings.")
+   "The (optional) \\var{setup-thunk} is called just after the user's namespace and other "
+   "setings are built, but before any of the user's code is evaluated."
+   ""
+   "All three functions are called on the user's thread and with the user's settings.")
   
   (drscheme:language:extend-language-interface
    (interface?