runtime: Make it nicer to (ge '(R3RS)).

The default parser and unparser expect to find bindings for
e.g. *parser-table* in any given environment, but there are no such
bindings in a package with parent #f (unless you import them).  If you
don't, executing (ge '(R3RS)) puts the REPL into a tight little error
loop.  This patch makes the parser and unparser consult the (USER)
package if they don't find these bindings in the current environment.

Once "in" a package like (r3rs) it is tricky to get out(!).  Entering
(ge '(USER)) will just produce an error: unbound variable GE.  Thus
the default/repl-eval now looks for an unquoted expression and
evaluates it in the (USER) package, so you can enter ,(ge '(USER)) to
get back.

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 1b60ba6f7d4fe22ca358b370cf34f5653424fd91..3a9846053f1ff49d078217510175d0a9bc39e761 100644 (file)
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -797,12 +797,12 @@ USA.
                (guarantee-environment environment #f)
                environment)))
         (atom-delimiters
-         (environment-lookup environment '*PARSER-ATOM-DELIMITERS*))
+         (repl-environment-value environment '*PARSER-ATOM-DELIMITERS*))
         (constituents
-         (environment-lookup environment '*PARSER-CONSTITUENTS*)))
+         (repl-environment-value environment '*PARSER-CONSTITUENTS*)))
     (guarantee-char-set atom-delimiters #f)
     (guarantee-char-set constituents #f)
-    (make-db (environment-lookup environment '*PARSER-ASSOCIATE-POSITIONS?*)
+    (make-db (repl-environment-value environment '*PARSER-ASSOCIATE-POSITIONS?*)
             atom-delimiters
             (overridable-value
              port environment '*PARSER-CANONICALIZE-SYMBOLS?*)
@@ -810,8 +810,8 @@ USA.
             (overridable-value
              port environment '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?*)
             (overridable-value port environment '*PARSER-KEYWORD-STYLE*)
-            (environment-lookup environment '*PARSER-RADIX*)
-            (environment-lookup environment '*PARSER-TABLE*)
+            (repl-environment-value environment '*PARSER-RADIX*)
+            (repl-environment-value environment '*PARSER-TABLE*)
             (make-shared-objects)
             (port/operation port 'DISCRETIONARY-WRITE-CHAR)
             (position-operation port environment)
@@ -820,14 +820,27 @@ USA.
             (port/operation port 'READ-CHAR)
             '())))
 
+(define (repl-environment-value environment name)
+  (environment-lookup-or
+   environment name
+   (lambda ()
+     (environment-lookup-or
+      (->environment '(USER)) name
+      (lambda ()
+       (environment-lookup environment name))))))
+
 (define (overridable-value port environment name)
   ;; Check the port property list for the name, and then the
   ;; environment.  This way a port can override the default.
-  (port/get-property port name (environment-lookup environment name)))
+  (let* ((nope "no-overridden-value")
+        (v (port/get-property port name nope)))
+    (if (eq? v nope)
+       (repl-environment-value environment name)
+       v)))
 
 (define (position-operation port environment)
   (let ((default (lambda (port) port #f)))
-    (if (environment-lookup environment '*PARSER-ASSOCIATE-POSITIONS?*)
+    (if (repl-environment-value environment '*PARSER-ASSOCIATE-POSITIONS?*)
        (or (port/operation port 'POSITION)
            default)
        default)))

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 981303abc932e67c69d81d244115cfd161778dbc..c22f19720fc2db328ce6628f4e62b703ebf3bf1a 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -466,7 +466,11 @@ USA.
 
 (define hook/repl-eval)
 (define (default/repl-eval s-expression environment repl)
-  (%repl-scode-eval (syntax s-expression environment) environment repl))
+  (if (and (pair? s-expression)
+          (eq? 'UNQUOTE (car s-expression)))
+      (let ((env (->environment '(user))))
+       (%repl-scode-eval (syntax (cadr s-expression) env) env repl))
+      (%repl-scode-eval (syntax s-expression environment) environment repl)))
 
 (define (repl-scode-eval scode #!optional environment repl)
   (receive (environment repl) (optional-er environment repl 'REPL-SCODE-EVAL)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 13c5b176d952d39e6801175071373d6a12247cd5..61428f1b7746d0fa216333fc393bc56d09f74d6c 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1698,6 +1698,7 @@ USA.
          environment-has-parent?
          environment-lambda
          environment-lookup
+         environment-lookup-or
          environment-lookup-macro
          environment-macro-names
          environment-parent
@@ -3036,7 +3037,8 @@ USA.
   (export (runtime unparser)
          char-set/atom-delimiters
          char-set/number-leaders
-         char-set/symbol-quotes)
+         char-set/symbol-quotes
+         repl-environment-value)
   (initialization (initialize-package!)))
 
 (define-package (runtime parser file-attributes)

diff --git a/src/runtime/uenvir.scm b/src/runtime/uenvir.scm
index bb210ecc2aaa6132e3145fa6e7870a59afcf1db3..e03114c6da082e9cd88850546d89057cfd91ea56 100644 (file)
--- a/src/runtime/uenvir.scm
+++ b/src/runtime/uenvir.scm
@@ -159,6 +159,12 @@ USA.
           (error:macro-binding environment name))
          (else value))))
 
+(define (environment-lookup-or environment name no-value)
+  (case (environment-reference-type environment name)
+    ((UNBOUND UNASSIGNED) (no-value))
+    ((MACRO) (error:macro-binding environment name))
+    (else (environment-lookup environment name))))
+
 (define (environment-lookup-macro environment name)
   (and (eq? 'MACRO (environment-reference-type environment name))
        (let ((value (environment-safe-lookup environment name)))

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index cd39c15204c3b27d441ba39e13f01f74e2785cb9..67eb38f31d420f7ec169edacc2c96469faa6f566 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -183,7 +183,7 @@ USA.
              (*dispatch-table*
               (unparser-table/dispatch-vector
                (let ((table
-                      (environment-lookup environment '*UNPARSER-TABLE*)))
+                      (repl-environment-value environment '*UNPARSER-TABLE*)))
                  (guarantee-unparser-table table #f)
                  table))))
     (*unparse-object object)))
@@ -337,7 +337,7 @@ USA.
       (unparse-symbol-name (symbol-name symbol))))
 
 (define (unparse-keyword-name s)
-  (case (environment-lookup *environment* '*PARSER-KEYWORD-STYLE*)
+  (case (repl-environment-value *environment* '*PARSER-KEYWORD-STYLE*)
     ((PREFIX)
      (*unparse-char #\:)
      (unparse-symbol-name s))
@@ -352,8 +352,8 @@ USA.
 (define (unparse-symbol-name s)
   (if (or (string-find-next-char-in-set
           s
-          (if (environment-lookup *environment*
-                                  '*PARSER-CANONICALIZE-SYMBOLS?*)
+          (if (repl-environment-value *environment*
+                                      '*PARSER-CANONICALIZE-SYMBOLS?*)
               canon-symbol-quoted
               non-canon-symbol-quoted))
          (fix:= (string-length s) 0)
@@ -386,7 +386,7 @@ USA.
   (char=? (string-ref string 0) #\#))
 
 (define (looks-like-keyword? string)
-  (case (environment-lookup *environment* '*PARSER-KEYWORD-STYLE*)
+  (case (repl-environment-value *environment* '*PARSER-KEYWORD-STYLE*)
     ((PREFIX)
      (char=? (string-ref string 0) #\:))
     ((SUFFIX)