new #lang planet reader; new sandbox-make-loger parameter

svn: r10833

collects/planet/lang/reader.ss

@@ -1,39 +1,42 @@
 #lang scheme/base
 
-(require "../parsereq.ss")
+(require "../parsereq.ss"
+         syntax/readerr)
 
 (provide (rename-out [planet-read read]
                      [planet-read-syntax read-syntax]))
 
-(define (planet-read-fn in spec->read-data)
-  (let* ([spec (read-line in)]
-         [parsed-spec
-          (with-handlers ([exn:parse-failure? (λ (e) (raise-syntax-error 'read "bad syntax"))])
-            (parse-package-string spec))])
-    (values 
-     `(planet "lang/main.ss" ,parsed-spec)
-     (spec->read-data `(planet "lang/reader.ss" ,parsed-spec)))))
+(define (planet-read-fn in read-sym args src mod line col pos)
+  (let ([spec (regexp-try-match #px"^(.*?)(\\s|$)" in)]
+        [bad (lambda (str eof?)
+               ((if eof?
+                    raise-read-eof-error 
+                    raise-read-error)
+                (format "bad planet path following language-loder syntax~a~a"
+                        (if str ": " "")
+                        (or str ""))
+                src line col pos
+                (let-values ([(line col pos2) (port-next-location in)])
+                  (and pos pos2 (- pos2 pos)))))])
+    (if (or (not spec)
+            (equal? (cadr spec) ""))
+        (bad #f (eof-object? (peek-byte in)))
+        (let ([parsed-spec
+               (let ([str (bytes->string/latin-1 (cadr spec))])
+                 (if (module-path? `(planet ,(string->symbol str)))
+                     `(planet ,(string->symbol (string-append str "/lang/reader")))
+                     #f))])
+          (if parsed-spec
+              (let ([r (dynamic-require parsed-spec read-sym)])
+                (if (and (procedure? r)
+                         (procedure-arity-includes? r (+ 5 (length args))))
+                    (apply r (append args
+                                     (list in mod line col pos)))
+                    (apply r (append args (list in)))))
+              (bad (cadr spec) #f))))))
 
-(define (wrap port spec read)
-  (let* ([body
-          (let loop ([a null])
-            (let ([v (read port)])
-              (if (eof-object? v)
-                  (reverse a)
-                  (loop (cons v a)))))]
-         [p-name (object-name port)]
-         [name (if (path? p-name)
-                   (let-values ([(base name dir?) (split-path p-name)])
-                     (string->symbol (path->string (path-replace-suffix name #""))))
-                   'page)])
-    `(module ,name ,spec
-       . ,body)))
-
-(define (planet-read [inp (current-input-port)])
-  (define-values (spec r) (planet-read-fn inp (λ (spec) (dynamic-require spec 'read))))
-  (wrap inp spec r))
-
-(define (planet-read-syntax [src #f] [inp (current-input-port)])
-  (define-values (spec r) (planet-read-fn inp (λ (spec) (dynamic-require spec 'read-syntax))))
-  (wrap inp spec (lambda (p) (r src p))))
+(define (planet-read inp mod line col pos)
+  (planet-read-fn inp 'read null (object-name inp) mod line col pos))
 
+(define (planet-read-syntax src inp mod line col pos)
+  (planet-read-fn inp 'read-syntax (list src) src mod line col pos))

collects/scheme/sandbox.ss

@@ -18,6 +18,7 @@
          sandbox-path-permissions
          sandbox-network-guard
          sandbox-make-inspector
+         sandbox-make-logger
          sandbox-eval-limits
          kill-evaluator
          break-evaluator
@@ -133,6 +134,8 @@
 
 (define sandbox-make-inspector (make-parameter make-inspector))
 
+(define sandbox-make-logger (make-parameter current-logger))
+
 ;; computes permissions that are needed for require specs (`read' for all
 ;; files and "compiled" subdirs, `exists' for the base-dir)
 (define (module-specs->path-permissions mods)
@@ -586,6 +589,7 @@
     [current-security-guard (sandbox-security-guard)]
     [exit-handler (lambda x (error 'exit "user code cannot exit"))]
     [current-inspector ((sandbox-make-inspector))]
+    [current-logger ((sandbox-make-logger))]
     ;; This breaks because we need to load some libraries that are trusted
     ;; [current-code-inspector (make-inspector)]
     ;; Note the above definition of `current-eventspace': in MzScheme, it

collects/scribblings/reference/sandbox.scrbl

@@ -451,6 +451,12 @@ A parameter that determines the procedure used to create the inspector
 for sandboxed evaluation. The procedure is called when initializing an
 evaluator, and the default parameter value is @scheme[make-inspector].}
 
+@defparam[sandbox-make-logger make (-> logger?)]{
+
+A parameter that determines the procedure used to create the logger
+for sandboxed evaluation. The procedure is called when initializing an
+evaluator, and the default parameter value is @scheme[current-logger].}
+
 @; ----------------------------------------------------------------------
 
 @section{Interacting with Evaluators}