From: Matt Birkholz Date: Sat, 27 Apr 2013 21:16:13 +0000 (-0700) Subject: runtime: Make it nicer to (ge '(R3RS)). X-Git-Tag: release-9.2.0~184 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fe044480837d2c10a4422d05d5a1017343ef3b85;p=mit-scheme.git 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 1b60ba6f7..3a9846053 100644 --- 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 981303abc..c22f19720 100644 --- 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 13c5b176d..61428f1b7 100644 --- 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 bb210ecc2..e03114c6d 100644 --- 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 cd39c1520..67eb38f31 100644 --- 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)