From: Chris Hanson Date: Sun, 28 Feb 2016 07:11:05 +0000 (-0800) Subject: Fix parameterization in parse.scm. X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~105 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4094bee404ca15e8e8ac1605133737deb2394e12;p=mit-scheme.git Fix parameterization in parse.scm. --- diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 711d69f3e..cef4f4e85 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -104,10 +104,13 @@ USA. (parent ()) (import (runtime parser) - (*parser-associate-positions?* runtime-parser-associate-positions?) - (*parser-canonicalize-symbols?* runtime-parser-canonicalize-symbols?) - (*parser-radix* runtime-parser-radix) - (*parser-table* runtime-parser-table)) + (param:parser-associate-positions? + runtime-param:parser-associate-positions?) + (param:parser-canonicalize-symbols? + runtime-param:parser-canonicalize-symbols?) + (param:parser-radix runtime-param:parser-radix) + (param:parser-table runtime-param:parser-table) + get-param:parser-canonicalize-symbols?) (import (runtime character) bucky-bits->prefix) (import (runtime char-syntax) diff --git a/src/edwin/schmod.scm b/src/edwin/schmod.scm index 140ff2198..8eb020c3e 100644 --- a/src/edwin/schmod.scm +++ b/src/edwin/schmod.scm @@ -232,9 +232,8 @@ The following commands evaluate Scheme expressions: (let ((environment (evaluation-environment #f))) (obarray-completions (if (and bound-only? - ((environment-lookup - environment - '*PARSER-CANONICALIZE-SYMBOLS?*))) + (get-param:parser-canonicalize-symbols? + environment)) (string-downcase prefix) prefix) (if bound-only? diff --git a/src/ffi/cdecls.scm b/src/ffi/cdecls.scm index 144dccbe8..a5e5bab80 100644 --- a/src/ffi/cdecls.scm +++ b/src/ffi/cdecls.scm @@ -70,8 +70,7 @@ USA. (define current-filename) (define read-environment - (make-top-level-environment '(*PARSER-CANONICALIZE-SYMBOLS?*) - (list (make-parameter #f)))) + (simple-top-level-environment #f)) (define (include-cdecl-file filename cwd twd includes) ;; Adds the C declarations in FILENAME to INCLUDES. Interprets diff --git a/src/runtime/file-attributes.scm b/src/runtime/file-attributes.scm index 6d2351dc9..adb3b5127 100644 --- a/src/runtime/file-attributes.scm +++ b/src/runtime/file-attributes.scm @@ -120,35 +120,52 @@ This file is part of MIT/GNU Scheme. (define (parse-file-attributes-item parse port) ;; Prepare the parser for first mode. - (parameterize* (list (cons *parser-associate-positions?* #f) - (cons *parser-atom-delimiters* + (parameterize* (list (cons param:parser-associate-positions? #f) + (cons param:parser-atom-delimiters char-set/file-attributes-atom-delimiters) - (cons *parser-canonicalize-symbols?* #f) - (cons *parser-constituents* + (cons param:parser-canonicalize-symbols? #f) + (cons param:parser-constituents char-set/file-attributes-constituents) ;; no recursion! - (cons *parser-enable-file-attributes-parsing?* + (cons param:parser-enable-file-attributes-parsing? #f) - (cons *parser-keyword-style* #f) - (cons *parser-radix* 10) - (cons *parser-table* file-attributes-parser-table)) + (cons param:parser-keyword-style #f) + (cons param:parser-radix 10) + (cons param:parser-table file-attributes-parser-table)) (lambda () - (parse port system-global-environment)))) + (fluid-let ((*parser-associate-positions?* #!default) + (*parser-atom-delimiters* #!default) + (*parser-canonicalize-symbols?* #!default) + (*parser-constituents* #!default) + (*parser-enable-file-attributes-parsing?* #!default) + (*parser-keyword-style* #!default) + (*parser-radix* #!default) + (*parser-table* #!default)) + (parse port system-global-environment))))) (define (parse-file-attributes-value parse port) ;; Prepare the parser for second mode. - (parameterize* (list (cons *parser-associate-positions?* #f) - (cons *parser-atom-delimiters* char-set/atom-delimiters) - (cons *parser-canonicalize-symbols?* #f) - (cons *parser-constituents* char-set/constituents) + (parameterize* (list (cons param:parser-associate-positions? #f) + (cons param:parser-atom-delimiters + char-set/atom-delimiters) + (cons param:parser-canonicalize-symbols? #f) + (cons param:parser-constituents char-set/constituents) ;; no recursion! - (cons *parser-enable-file-attributes-parsing?* #f) + (cons param:parser-enable-file-attributes-parsing? #f) ;; enable prefix keywords - (cons *parser-keyword-style* 'prefix) - (cons *parser-radix* 10) - (cons *parser-table* system-global-parser-table)) + (cons param:parser-keyword-style 'prefix) + (cons param:parser-radix 10) + (cons param:parser-table system-global-parser-table)) (lambda () - (parse port system-global-environment)))) + (fluid-let ((*parser-associate-positions?* #!default) + (*parser-atom-delimiters* #!default) + (*parser-canonicalize-symbols?* #!default) + (*parser-constituents* #!default) + (*parser-enable-file-attributes-parsing?* #!default) + (*parser-keyword-style* #!default) + (*parser-radix* #!default) + (*parser-table* #!default)) + (parse port system-global-environment))))) (define (parse-file-attributes-line port db multiline) (declare (ignore db)) diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 9cbc7ad1a..0627959ef 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -176,7 +176,7 @@ USA. (set-working-directory-pathname! (if (default-object? pathname) (user-homedir-pathname) - pathname))) + pathname))) (define (show-time thunk) (let ((process-start (process-time-clock)) @@ -200,13 +200,13 @@ USA. (write-string " GC); real time: " port) (write (- real-end real-start) port)))) value))) - + (define (wait-interval ticks) (let ((end (+ (real-time-clock) ticks))) (let wait-loop () (if (< (real-time-clock) end) (wait-loop))))) - + (define hook/exit #!default) (define hook/%exit #!default) (define hook/quit #!default) @@ -255,7 +255,7 @@ USA. unspecific) (define default/quit %quit) - + (define user-initial-environment (*make-environment system-global-environment (vector lambda-tag:unnamed))) @@ -276,6 +276,12 @@ USA. (define (unbind-variable environment name) ((ucode-primitive unbind-variable 2) (->environment environment) name)) + +(define (simple-top-level-environment fold-case?) + (make-top-level-environment '(param:parser-canonicalize-symbols? + *parser-canonicalize-symbols?*) + (list (make-settable-parameter fold-case?) + #!default))) (define (object-gc-type object) (%encode-gc-type ((ucode-primitive object-gc-type 1) object))) diff --git a/src/runtime/option.scm b/src/runtime/option.scm index 9b5a765a4..9b2732440 100644 --- a/src/runtime/option.scm +++ b/src/runtime/option.scm @@ -50,17 +50,10 @@ USA. (cons *parent* #f) (cons param:suppress-loading-message? #t)) (lambda () - (load pathname (make-load-environment)) + (load pathname (simple-top-level-environment #t)) (values (*options*) (*parent*))))) find-option)) - (define (make-load-environment) - (let ((e (extend-top-level-environment system-global-environment))) - (environment-define e - '*PARSER-CANONICALIZE-SYMBOLS?* - (make-parameter #t)) - e)) - (if (memq name loaded-options) name (find-option (*options*) (*parent*))))) diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 45de6b379..048016e26 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -31,26 +31,82 @@ USA. (integrate-external "input") (integrate-external "port")) -(define *parser-associate-positions?*) -(define *parser-atom-delimiters*) -(define *parser-canonicalize-symbols?*) -(define *parser-constituents*) -(define *parser-enable-file-attributes-parsing?*) -(define *parser-keyword-style*) -(define *parser-radix*) -(define *parser-table*) - -(define runtime-parser-associate-positions?) -(define runtime-parser-atom-delimiters) -(define runtime-parser-canonicalize-symbols?) -(define runtime-parser-constituents) -(define runtime-parser-enable-file-attributes-parsing?) -(define runtime-parser-keyword-style) -(define runtime-parser-radix) -(define runtime-parser-table) +(define *parser-associate-positions?* #!default) +(define *parser-atom-delimiters* #!default) +(define *parser-canonicalize-symbols?* #!default) +(define *parser-constituents* #!default) +(define *parser-enable-file-attributes-parsing?* #!default) +(define *parser-keyword-style* #!default) +(define *parser-radix* #!default) +(define *parser-table* #!default) + +(define param:parser-associate-positions?) +(define param:parser-atom-delimiters) +(define param:parser-canonicalize-symbols?) +(define param:parser-constituents) +(define param:parser-enable-file-attributes-parsing?) +(define param:parser-keyword-style) +(define param:parser-radix) +(define param:parser-table) + +(define runtime-param:parser-associate-positions?) +(define runtime-param:parser-atom-delimiters) +(define runtime-param:parser-canonicalize-symbols?) +(define runtime-param:parser-constituents) +(define runtime-param:parser-enable-file-attributes-parsing?) +(define runtime-param:parser-keyword-style) +(define runtime-param:parser-radix) +(define runtime-param:parser-table) (define ignore-extra-list-closes #t) +(define (param-getter fluid-name param-name) + (lambda (environment) + (let ((fluid (repl-environment-value environment fluid-name)) + (param (repl-environment-value environment param-name))) + (if (default-object? fluid) + (param) + fluid)))) + +(define (repl-environment-value environment name) + (environment-lookup-or environment name + (lambda () + (environment-lookup-or (->environment '(USER)) name + (lambda () + (environment-lookup environment name)))))) + +(define get-param:parser-associate-positions? + (param-getter '*parser-associate-positions?* + 'param:parser-associate-positions?)) + +(define get-param:parser-atom-delimiters + (param-getter '*parser-atom-delimiters* + 'param:parser-atom-delimiters)) + +(define get-param:parser-canonicalize-symbols? + (param-getter '*parser-canonicalize-symbols?* + 'param:parser-canonicalize-symbols?)) + +(define get-param:parser-constituents + (param-getter '*parser-constituents* + 'param:parser-constituents)) + +(define get-param:parser-enable-file-attributes-parsing? + (param-getter '*parser-enable-file-attributes-parsing?* + 'param:parser-enable-file-attributes-parsing?)) + +(define get-param:parser-keyword-style + (param-getter '*parser-keyword-style* + 'param:parser-keyword-style)) + +(define get-param:parser-radix + (param-getter '*parser-radix* + 'param:parser-radix)) + +(define get-param:parser-table + (param-getter '*parser-table* + 'param:parser-table)) + (define (parse-object port environment) ((top-level-parser port) port environment)) @@ -133,22 +189,24 @@ USA. (define char-set/number-leaders) (define (initialize-package!) - (set! *parser-associate-positions?* (make-parameter #f)) - (set! *parser-atom-delimiters* (make-parameter 'UNBOUND)) - (set! *parser-canonicalize-symbols?* (make-parameter #t)) - (set! *parser-constituents* (make-parameter 'UNBOUND)) - (set! *parser-enable-file-attributes-parsing?* (make-parameter #t)) - (set! *parser-keyword-style* (make-parameter #f)) - (set! *parser-radix* (make-parameter 10)) - (set! *parser-table* (make-parameter 'UNBOUND)) - (set! runtime-parser-associate-positions? (make-parameter #f)) - (set! runtime-parser-atom-delimiters (make-parameter 'UNBOUND)) - (set! runtime-parser-canonicalize-symbols? (make-parameter #t)) - (set! runtime-parser-constituents (make-parameter 'UNBOUND)) - (set! runtime-parser-enable-file-attributes-parsing? (make-parameter #t)) - (set! runtime-parser-keyword-style (make-parameter #f)) - (set! runtime-parser-radix (make-parameter 10)) - (set! runtime-parser-table (make-parameter 'UNBOUND)) + (set! param:parser-associate-positions? (make-settable-parameter #f)) + (set! param:parser-atom-delimiters (make-settable-parameter 'UNBOUND)) + (set! param:parser-canonicalize-symbols? (make-settable-parameter #t)) + (set! param:parser-constituents (make-settable-parameter 'UNBOUND)) + (set! param:parser-enable-file-attributes-parsing? + (make-settable-parameter #t)) + (set! param:parser-keyword-style (make-settable-parameter #f)) + (set! param:parser-radix (make-settable-parameter 10)) + (set! param:parser-table (make-settable-parameter 'UNBOUND)) + (set! runtime-param:parser-associate-positions? (make-settable-parameter #f)) + (set! runtime-param:parser-atom-delimiters (make-settable-parameter 'UNBOUND)) + (set! runtime-param:parser-canonicalize-symbols? (make-settable-parameter #t)) + (set! runtime-param:parser-constituents (make-settable-parameter 'UNBOUND)) + (set! runtime-param:parser-enable-file-attributes-parsing? + (make-settable-parameter #t)) + (set! runtime-param:parser-keyword-style (make-settable-parameter #f)) + (set! runtime-param:parser-radix (make-settable-parameter 10)) + (set! runtime-param:parser-table (make-settable-parameter 'UNBOUND)) (let* ((constituents (char-set-difference char-set:graphic char-set:whitespace)) @@ -207,12 +265,12 @@ USA. (set! char-set/atom-delimiters atom-delimiters) (set! char-set/symbol-quotes symbol-quotes) (set! char-set/number-leaders number-leaders) - (*parser-atom-delimiters* atom-delimiters) - (*parser-constituents* constituents) - (runtime-parser-atom-delimiters atom-delimiters) - (runtime-parser-constituents constituents)) - (*parser-table* system-global-parser-table) - (runtime-parser-table system-global-parser-table) + (param:parser-atom-delimiters atom-delimiters) + (param:parser-constituents constituents) + (runtime-param:parser-atom-delimiters atom-delimiters) + (runtime-param:parser-constituents constituents)) + (param:parser-table system-global-parser-table) + (runtime-param:parser-table system-global-parser-table) (set! hashed-object-interns (make-strong-eq-hash-table)) (initialize-condition-types!)) @@ -812,23 +870,23 @@ USA. (begin (guarantee-environment environment #f) environment))) - (atom-delimiters - ((repl-environment-value environment '*PARSER-ATOM-DELIMITERS*))) - (constituents - ((repl-environment-value environment '*PARSER-CONSTITUENTS*)))) + (atom-delimiters (get-param:parser-atom-delimiters environment)) + (constituents (get-param:parser-constituents environment))) (guarantee-char-set atom-delimiters #f) (guarantee-char-set constituents #f) - (make-db ((repl-environment-value environment - '*PARSER-ASSOCIATE-POSITIONS?*)) + (make-db (get-param:parser-associate-positions? environment) atom-delimiters (overridable-value - port environment '*PARSER-CANONICALIZE-SYMBOLS?*) + port '*PARSER-CANONICALIZE-SYMBOLS?* + (get-param:parser-canonicalize-symbols? environment)) constituents (overridable-value - port environment '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?*) - (overridable-value port environment '*PARSER-KEYWORD-STYLE*) - ((repl-environment-value environment '*PARSER-RADIX*)) - ((repl-environment-value environment '*PARSER-TABLE*)) + port '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?* + (get-param:parser-enable-file-attributes-parsing? environment)) + (overridable-value port '*PARSER-KEYWORD-STYLE* + (get-param:parser-keyword-style environment)) + (get-param:parser-radix environment) + (get-param:parser-table environment) (make-shared-objects) (port/operation port 'DISCRETIONARY-WRITE-CHAR) (position-operation port environment) @@ -837,27 +895,18 @@ 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) +(define (overridable-value port name default-value) ;; Check the port property list for the name, and then the ;; environment. This way a port can override the default. (let* ((nope "no-overridden-value") (v (port/get-property port name nope))) (if (eq? v nope) - ((repl-environment-value environment name)) + default-value v))) (define (position-operation port environment) (let ((default (lambda (port) port #f))) - (if ((repl-environment-value environment '*PARSER-ASSOCIATE-POSITIONS?*)) + (if (get-param:parser-associate-positions? environment) (or (port/operation port 'POSITION) default) default))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 1c20d2b6f..1c1bc0fd4 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -516,6 +516,7 @@ USA. set-ephemeron-key! set-interrupt-enables! show-time + simple-top-level-environment system-hunk3-cons system-hunk3-cxr0 system-hunk3-cxr1 @@ -1513,8 +1514,10 @@ USA. (file-time->string file-time->local-rfc2822-string) (get-decoded-time local-decoded-time) (string->decoded-time rfc2822-string->decoded-time) - (universal-time->global-time-string universal-time->global-rfc2822-string) - (universal-time->local-time-string universal-time->local-rfc2822-string) + (universal-time->global-time-string + universal-time->global-rfc2822-string) + (universal-time->local-time-string + universal-time->local-rfc2822-string) (universal-time->string universal-time->local-rfc2822-string) ctime-string->decoded-time ctime-string->file-time @@ -3094,25 +3097,39 @@ USA. *parser-radix* *parser-table* define-bracketed-object-parser-method + param:parser-associate-positions? + param:parser-atom-delimiters + param:parser-canonicalize-symbols? + param:parser-constituents + param:parser-enable-file-attributes-parsing? + param:parser-keyword-style + param:parser-radix + param:parser-table parse-object parse-objects system-global-parser-table) (export (runtime) - (*parser-associate-positions?* runtime-parser-associate-positions?) - (*parser-atom-delimiters* runtime-parser-atom-delimiters) - (*parser-canonicalize-symbols?* runtime-parser-canonicalize-symbols?) - (*parser-constituents* runtime-parser-constituents) - (*parser-enable-file-attributes-parsing?* - runtime-parser-enable-file-attributes-parsing?) - (*parser-keyword-style* runtime-parser-keyword-style) - (*parser-radix* runtime-parser-radix) - (*parser-table* runtime-parser-table)) + (param:parser-associate-positions? + runtime-param:parser-associate-positions?) + (param:parser-atom-delimiters runtime-param:parser-atom-delimiters) + (param:parser-canonicalize-symbols? + runtime-param:parser-canonicalize-symbols?) + (param:parser-constituents runtime-param:parser-constituents) + (param:parser-enable-file-attributes-parsing? + runtime-param:parser-enable-file-attributes-parsing?) + (param:parser-keyword-style runtime-param:parser-keyword-style) + (param:parser-radix runtime-param:parser-radix) + (param:parser-table runtime-param:parser-table)) (export (runtime character) char-set/atom-delimiters) + (export (runtime swank) + get-param:parser-canonicalize-symbols?) (export (runtime unparser) char-set/atom-delimiters char-set/number-leaders char-set/symbol-quotes + get-param:parser-canonicalize-symbols? + get-param:parser-keyword-style repl-environment-value) (initialization (initialize-package!))) diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index e16293a67..fff751840 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -836,7 +836,7 @@ swank:xref (define (all-completions prefix environment) (let ((prefix - (if ((environment-lookup environment '*PARSER-CANONICALIZE-SYMBOLS?*)) + (if (get-param:parser-canonicalize-symbols? environment) (string-downcase prefix) prefix)) (completions '())) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index c21bcb700..380c353d1 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -368,7 +368,7 @@ USA. (unparse-symbol-name (symbol-name symbol)))) (define (unparse-keyword-name s) - (case ((repl-environment-value (*environment*) '*PARSER-KEYWORD-STYLE*)) + (case (get-param:parser-keyword-style (*environment*)) ((PREFIX) (*unparse-char #\:) (unparse-symbol-name s)) @@ -383,8 +383,7 @@ USA. (define (unparse-symbol-name s) (if (or (string-find-next-char-in-set s - (if ((repl-environment-value (*environment*) - '*PARSER-CANONICALIZE-SYMBOLS?*)) + (if (get-param:parser-canonicalize-symbols? (*environment*)) canon-symbol-quoted non-canon-symbol-quoted)) (fix:= (string-length s) 0) @@ -417,7 +416,7 @@ USA. (char=? (string-ref string 0) #\#)) (define (looks-like-keyword? string) - (case ((repl-environment-value (*environment*) '*PARSER-KEYWORD-STYLE*)) + (case (get-param:parser-keyword-style (*environment*)) ((PREFIX) (char=? (string-ref string 0) #\:)) ((SUFFIX) diff --git a/src/sicp/studen.scm b/src/sicp/studen.scm index a1e5d215c..bd12c3a3d 100644 --- a/src/sicp/studen.scm +++ b/src/sicp/studen.scm @@ -50,7 +50,7 @@ USA. (begin (discard-char) (string-append string "-" (loop))) string)))))))) - + (define char-set/mit-scheme-atom-delimiters char-set/atom-delimiters) @@ -99,12 +99,12 @@ USA. (access set-atom-delimiters! (->environment '(runtime parser)))) (define (enable-system-syntax) - (*parser-table* system-global-parser-table) + (param:parser-table system-global-parser-table) (set-atom-delimiters! 'mit-scheme) (set-repl/syntax-table! (nearest-repl) system-global-syntax-table)) (define (disable-system-syntax) - (*parser-table* *student-parser-table*) + (param:parser-table *student-parser-table*) (set-atom-delimiters! 'sicp) (set-repl/syntax-table! (nearest-repl) *student-syntax-table*)) @@ -366,7 +366,7 @@ USA. (ODD?) (OPEN-READER-CHANNEL . OPEN-INPUT-FILE) (OPEN-PRINTER-CHANNEL . OPEN-OUTPUT-FILE) - (OR . OR*) + (OR . OR*) (OUT) (PAIR?) (POSITION-PEN) @@ -495,7 +495,7 @@ USA. (if (default-object? filename) student-band-pathname (merge-pathnames (->pathname filename) - student-band-pathname)))) + student-band-pathname)))) (define (student-band #!optional filename) (if (not (default-object? filename))