From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 29 Feb 2016 04:34:41 +0000 (-0800)
Subject: Refactor parser and unparser parameters.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~90
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f77c342c3b4079ce05ee86da44a9d9033659d3dc;p=mit-scheme.git
Refactor parser and unparser parameters.
* Made unsettable.
* Added type-checking converters.
* Check each "fluid" value with the corresponding converter.
---
diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 048016e26..719dc5ebe 100644
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -66,7 +66,7 @@ USA.
(param (repl-environment-value environment param-name)))
(if (default-object? fluid)
(param)
- fluid))))
+ ((parameter-converter param) fluid)))))
(define (repl-environment-value environment name)
(environment-lookup-or environment name
@@ -189,91 +189,141 @@ USA.
(define char-set/number-leaders)
(define (initialize-package!)
- (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! char-set/constituents
+ (char-set-difference char-set:graphic
+ char-set:whitespace))
+ (set! char-set/atom-delimiters
+ (char-set-union char-set:whitespace
+ ;; Note that #\, may break older code.
+ (string->char-set "()[]{}\";'`,")
+ (char-set #\U+00AB #\U+00BB)))
+ (set! char-set/symbol-quotes
+ (string->char-set "\\|"))
+ (set! char-set/number-leaders
+ (char-set-union char-set:numeric
+ (string->char-set "+-.")))
+
+ (set! system-global-parser-table
+ (make-initial-parser-table))
+
+ (set! param:parser-associate-positions?
+ (make-unsettable-parameter #f
+ boolean-converter))
+ (set! param:parser-atom-delimiters
+ (make-unsettable-parameter char-set/atom-delimiters
+ char-set-converter))
+ (set! param:parser-canonicalize-symbols?
+ (make-unsettable-parameter #t
+ boolean-converter))
+ (set! param:parser-constituents
+ (make-unsettable-parameter char-set/constituents
+ char-set-converter))
(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))
+ (make-unsettable-parameter #t
+ boolean-converter))
+ (set! param:parser-keyword-style
+ (make-unsettable-parameter #f
+ keyword-style-converter))
+ (set! param:parser-radix
+ (make-unsettable-parameter 10
+ radix-converter))
+ (set! param:parser-table
+ (make-unsettable-parameter system-global-parser-table
+ parser-table-converter))
+
+ (set! runtime-param:parser-associate-positions?
+ (copy-param param:parser-associate-positions?))
+ (set! runtime-param:parser-atom-delimiters
+ (copy-param param:parser-atom-delimiters))
+ (set! runtime-param:parser-canonicalize-symbols?
+ (copy-param param:parser-canonicalize-symbols?))
+ (set! runtime-param:parser-constituents
+ (copy-param param:parser-constituents))
(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))
- (atom-delimiters
- (char-set-union char-set:whitespace
- ;; Note that #\, may break older code.
- (string->char-set "()[]{}\";'`,")
- (char-set #\U+00AB #\U+00BB)))
- (symbol-quotes
- (string->char-set "\\|"))
- (number-leaders
- (char-set-union char-set:numeric
- (string->char-set "+-.")))
- (symbol-leaders
- (char-set-difference constituents
- (char-set-union atom-delimiters
- number-leaders)))
- (special-number-leaders
- (string->char-set "bBoOdDxXiIeEsSlL"))
- (store-char (lambda (v c h) (vector-set! v (char->integer c) h)))
- (store-char-set
- (lambda (v c h)
- (for-each (lambda (c) (store-char v c h))
- (char-set-members c)))))
- (let ((initial (make-vector #x100 #f))
- (special (make-vector #x100 #f)))
- (store-char-set initial char-set:whitespace handler:whitespace)
- (store-char-set initial number-leaders handler:atom)
- (store-char-set initial symbol-leaders handler:symbol)
- (store-char-set special special-number-leaders handler:number)
- (store-char initial #\( handler:list)
- (store-char special #\( handler:vector)
- (store-char special #\[ handler:hashed-object)
- (store-char initial #\) handler:close-parenthesis)
- (store-char initial #\] handler:close-bracket)
- (store-char initial #\: handler:prefix-keyword)
- (store-char initial #\; handler:comment)
- (store-char special #\| handler:multi-line-comment)
- (store-char special #\; handler:expression-comment)
- (store-char initial #\' handler:quote)
- (store-char initial #\` handler:quasiquote)
- (store-char initial #\, handler:unquote)
- (store-char initial #\" handler:string)
- (store-char initial #\# handler:special)
- (store-char special #\f handler:false)
- (store-char special #\F handler:false)
- (store-char special #\t handler:true)
- (store-char special #\T handler:true)
- (store-char special #\* handler:bit-string)
- (store-char special #\\ handler:char)
- (store-char special #\! handler:named-constant)
- (store-char special #\@ handler:unhash)
- (store-char-set special char-set:numeric handler:special-arg)
- (set! system-global-parser-table (make-parser-table initial special)))
- (set! char-set/constituents constituents)
- (set! char-set/atom-delimiters atom-delimiters)
- (set! char-set/symbol-quotes symbol-quotes)
- (set! char-set/number-leaders number-leaders)
- (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)
+ (copy-param param:parser-enable-file-attributes-parsing?))
+ (set! runtime-param:parser-keyword-style
+ (copy-param param:parser-keyword-style))
+ (set! runtime-param:parser-radix
+ (copy-param param:parser-radix))
+ (set! runtime-param:parser-table
+ (copy-param param:parser-table))
+
(set! hashed-object-interns (make-strong-eq-hash-table))
(initialize-condition-types!))
-
+
+(define (make-initial-parser-table)
+
+ (define (store-char v c h)
+ (vector-set! v (char->integer c) h))
+
+ (define (store-char-set v c h)
+ (for-each (lambda (c) (store-char v c h))
+ (char-set-members c)))
+
+ (let ((initial (make-vector #x100 #f))
+ (special (make-vector #x100 #f))
+ (symbol-leaders
+ (char-set-difference char-set/constituents
+ (char-set-union char-set/atom-delimiters
+ char-set/number-leaders)))
+ (special-number-leaders
+ (string->char-set "bBoOdDxXiIeEsSlL")))
+
+ (store-char-set initial char-set:whitespace handler:whitespace)
+ (store-char-set initial char-set/number-leaders handler:atom)
+ (store-char-set initial symbol-leaders handler:symbol)
+ (store-char-set special special-number-leaders handler:number)
+ (store-char initial #\( handler:list)
+ (store-char special #\( handler:vector)
+ (store-char special #\[ handler:hashed-object)
+ (store-char initial #\) handler:close-parenthesis)
+ (store-char initial #\] handler:close-bracket)
+ (store-char initial #\: handler:prefix-keyword)
+ (store-char initial #\; handler:comment)
+ (store-char special #\| handler:multi-line-comment)
+ (store-char special #\; handler:expression-comment)
+ (store-char initial #\' handler:quote)
+ (store-char initial #\` handler:quasiquote)
+ (store-char initial #\, handler:unquote)
+ (store-char initial #\" handler:string)
+ (store-char initial #\# handler:special)
+ (store-char special #\f handler:false)
+ (store-char special #\F handler:false)
+ (store-char special #\t handler:true)
+ (store-char special #\T handler:true)
+ (store-char special #\* handler:bit-string)
+ (store-char special #\\ handler:char)
+ (store-char special #\! handler:named-constant)
+ (store-char special #\@ handler:unhash)
+ (store-char-set special char-set:numeric handler:special-arg)
+
+ (make-parser-table initial special)))
+
+(define (boolean-converter value)
+ (guarantee-boolean value)
+ value)
+
+(define (char-set-converter value)
+ (guarantee-char-set value)
+ value)
+
+(define (keyword-style-converter value)
+ (if (not (memq value '(#f prefix suffix)))
+ (error "Invalid keyword style:" value))
+ value)
+
+(define (parser-table-converter value)
+ (guarantee-parser-table value)
+ value)
+
+(define (radix-converter value)
+ (if (not (memv value '(2 8 10 16)))
+ (error "Invalid parser radix:" value))
+ value)
+
+(define (copy-param param)
+ (make-unsettable-parameter (param)
+ (parameter-converter param)))
(define (handler:whitespace port db ctx char)
port db ctx char
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 4063fc368..bd690b51a 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -71,7 +71,7 @@ USA.
;; Dynamically bound to #t if we are already unparsing a bracketed
;; object so we can avoid nested brackets.
(define param:unparsing-within-brackets?)
-
+
(define (initialize-package!)
(set! hook/interned-symbol unparse-symbol)
(set! hook/procedure-unparser #f)
@@ -83,19 +83,42 @@ USA.
(char-set-union non-canon-symbol-quoted char-set:upper-case))
(set! system-global-unparser-table (make-system-global-unparser-table))
- (set! param:unparse-abbreviate-quotations? (make-settable-parameter #f))
- (set! param:unparse-compound-procedure-names? (make-settable-parameter #t))
- (set! param:unparse-primitives-by-name? (make-settable-parameter #f))
- (set! param:unparse-streams? (make-settable-parameter #t))
- (set! param:unparse-uninterned-symbols-by-name? (make-settable-parameter #f))
- (set! param:unparse-with-datum? (make-settable-parameter #f))
- (set! param:unparse-with-maximum-readability? (make-settable-parameter #f))
- (set! param:unparser-list-breadth-limit (make-settable-parameter #f))
- (set! param:unparser-list-depth-limit (make-settable-parameter #f))
- (set! param:unparser-radix (make-settable-parameter 10))
- (set! param:unparser-string-length-limit (make-settable-parameter #f))
+ (set! param:unparse-abbreviate-quotations?
+ (make-unsettable-parameter #f
+ boolean-converter))
+ (set! param:unparse-compound-procedure-names?
+ (make-unsettable-parameter #t
+ boolean-converter))
+ (set! param:unparse-primitives-by-name?
+ (make-unsettable-parameter #f
+ boolean-converter))
+ (set! param:unparse-streams?
+ (make-unsettable-parameter #t
+ boolean-converter))
+ (set! param:unparse-uninterned-symbols-by-name?
+ (make-unsettable-parameter #f
+ boolean-converter))
+ (set! param:unparse-with-datum?
+ (make-unsettable-parameter #f
+ boolean-converter))
+ (set! param:unparse-with-maximum-readability?
+ (make-unsettable-parameter #f
+ boolean-converter))
+ (set! param:unparser-list-breadth-limit
+ (make-unsettable-parameter #f
+ limit-converter))
+ (set! param:unparser-list-depth-limit
+ (make-unsettable-parameter #f
+ limit-converter))
+ (set! param:unparser-radix
+ (make-unsettable-parameter 10
+ radix-converter))
+ (set! param:unparser-string-length-limit
+ (make-unsettable-parameter #f
+ limit-converter))
(set! param:unparser-table
- (make-settable-parameter system-global-unparser-table))
+ (make-unsettable-parameter system-global-unparser-table
+ unparser-table-converter))
(set! param:default-unparser-state (make-unsettable-parameter #f))
(set! param:dispatch-table (make-unsettable-parameter #f))
@@ -106,65 +129,75 @@ USA.
(set! param:unparsing-within-brackets? (make-unsettable-parameter #f))
unspecific)
+(define (boolean-converter value)
+ (guarantee-boolean value)
+ value)
+
+(define (limit-converter value)
+ (if value (guarantee-exact-positive-integer value))
+ value)
+
+(define (radix-converter value)
+ (if (not (memv value '(2 8 10 16)))
+ (error "Invalid unparser radix:" value))
+ value)
+
+(define (unparser-table-converter value)
+ (guarantee-unparser-table value)
+ value)
+
+(define (resolve-fluids param fluid)
+ (if (default-object? fluid)
+ (param)
+ ((parameter-converter param) fluid)))
+
(define (get-param:unparse-abbreviate-quotations?)
- (if (default-object? *unparse-abbreviate-quotations?*)
- (param:unparse-abbreviate-quotations?)
- *unparse-abbreviate-quotations?*))
+ (resolve-fluids param:unparse-abbreviate-quotations?
+ *unparse-abbreviate-quotations?*))
(define (get-param:unparse-compound-procedure-names?)
- (if (default-object? *unparse-compound-procedure-names?*)
- (param:unparse-compound-procedure-names?)
- *unparse-compound-procedure-names?*))
+ (resolve-fluids param:unparse-compound-procedure-names?
+ *unparse-compound-procedure-names?*))
(define (get-param:unparse-primitives-by-name?)
- (if (default-object? *unparse-primitives-by-name?*)
- (param:unparse-primitives-by-name?)
- *unparse-primitives-by-name?*))
+ (resolve-fluids param:unparse-primitives-by-name?
+ *unparse-primitives-by-name?*))
(define (get-param:unparse-streams?)
- (if (default-object? *unparse-streams?*)
- (param:unparse-streams?)
- *unparse-streams?*))
+ (resolve-fluids param:unparse-streams?
+ *unparse-streams?*))
(define (get-param:unparse-uninterned-symbols-by-name?)
- (if (default-object? *unparse-uninterned-symbols-by-name?*)
- (param:unparse-uninterned-symbols-by-name?)
- *unparse-uninterned-symbols-by-name?*))
+ (resolve-fluids param:unparse-uninterned-symbols-by-name?
+ *unparse-uninterned-symbols-by-name?*))
(define (get-param:unparse-with-datum?)
- (if (default-object? *unparse-with-datum?*)
- (param:unparse-with-datum?)
- *unparse-with-datum?*))
+ (resolve-fluids param:unparse-with-datum?
+ *unparse-with-datum?*))
(define (get-param:unparse-with-maximum-readability?)
- (if (default-object? *unparse-with-maximum-readability?*)
- (param:unparse-with-maximum-readability?)
- *unparse-with-maximum-readability?*))
+ (resolve-fluids param:unparse-with-maximum-readability?
+ *unparse-with-maximum-readability?*))
(define (get-param:unparser-list-breadth-limit)
- (if (default-object? *unparser-list-breadth-limit*)
- (param:unparser-list-breadth-limit)
- *unparser-list-breadth-limit*))
+ (resolve-fluids param:unparser-list-breadth-limit
+ *unparser-list-breadth-limit*))
(define (get-param:unparser-list-depth-limit)
- (if (default-object? *unparser-list-depth-limit*)
- (param:unparser-list-depth-limit)
- *unparser-list-depth-limit*))
+ (resolve-fluids param:unparser-list-depth-limit
+ *unparser-list-depth-limit*))
(define (get-param:unparser-radix)
- (if (default-object? *unparser-radix*)
- (param:unparser-radix)
- *unparser-radix*))
+ (resolve-fluids param:unparser-radix
+ *unparser-radix*))
(define (get-param:unparser-string-length-limit)
- (if (default-object? *unparser-string-length-limit*)
- (param:unparser-string-length-limit)
- *unparser-string-length-limit*))
+ (resolve-fluids param:unparser-string-length-limit
+ *unparser-string-length-limit*))
(define (get-param:unparser-table)
- (if (default-object? *unparser-table*)
- (param:unparser-table)
- *unparser-table*))
+ (resolve-fluids param:unparser-table
+ *unparser-table*))
(define (make-system-global-unparser-table)
(let ((table (make-unparser-table unparse/default)))