From dfd58a2cddf09298aed4e6c68047340015259869 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 17 Aug 2011 06:18:22 -0600
Subject: [PATCH] adjust sandbox to give S-expression input "original" status

---
 collects/racket/sandbox.rkt        | 19 ++++++++++++++++---
 collects/tests/racket/sandbox.rktl |  5 +++++
 2 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/collects/racket/sandbox.rkt b/collects/racket/sandbox.rkt
index 30520357d5..8f6ae6a1fe 100644
--- a/collects/racket/sandbox.rkt
+++ b/collects/racket/sandbox.rkt
@@ -474,11 +474,24 @@
                       (loop (cdr inps) (and n (add1 n))
                             ;; 1st at line#1, pos#1, 2nd at line#2, pos#2 etc
                             ;; (starting from the `n' argument)
-                            (cons (datum->syntax
-                                   #f (car inps)
-                                   (list source n (and n 0) n (and n 1)))
+                            (cons (add-location (car inps)
+                                                (list source n (and n 0) n (and n 1)))
                                   r))))]))))
 
+(define orig-stx (read-syntax 'src (open-input-string "0"))) ; for "is original?" property
+(define (make-orig x loc) (datum->syntax #f x loc orig-stx))
+
+(define (add-location x loc)
+  (cond
+   [(null? x) null]
+   [(pair? x) (make-orig (cons (add-location (car x) loc) 
+                               (add-location (cdr x) loc))
+                         loc)]
+   [(vector? x) (make-orig (for/vector ([i (in-vector x)])
+                             (add-location i loc))
+                           loc)]
+   [else (make-orig x loc)]))
+
 (define ((init-hook-for-language language))
   (cond [(or (not (pair? language))
              (not (eq? 'special (car language))))
diff --git a/collects/tests/racket/sandbox.rktl b/collects/tests/racket/sandbox.rktl
index 8894bb1f62..61a5285941 100644
--- a/collects/tests/racket/sandbox.rktl
+++ b/collects/tests/racket/sandbox.rktl
@@ -493,6 +493,11 @@
         =err> "out of mem+o(?:ry)"
         b => 1))
 
+   --top--
+   (make-base-evaluator!)
+   --eval--
+   (syntax-original? #'x) => #t
+
    ))
 
 (report-errs)