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 048016e265923308acb779ed31cf67c20f6c34b4..719dc5ebed76a4064b86be87b0ec29af53b52362 100644 (file)
--- 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!))
-
+\f
+(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)))
 \f
 (define (handler:whitespace port db ctx char)
   port db ctx char

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 4063fc368ecfc1083a2bf6b306272f35899b20ca..bd690b51a58b3e6d03dde6810e31830be05cf225 100644 (file)
--- 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?)
-
+\f
 (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)
 \f
+(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*))
 \f
 (define (make-system-global-unparser-table)
   (let ((table (make-unparser-table unparse/default)))