From f77c342c3b4079ce05ee86da44a9d9033659d3dc Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 28 Feb 2016 20:34:41 -0800 Subject: [PATCH] Refactor parser and unparser parameters. * Made unsettable. * Added type-checking converters. * Check each "fluid" value with the corresponding converter. --- src/runtime/parse.scm | 214 +++++++++++++++++++++++++---------------- src/runtime/unpars.scm | 131 +++++++++++++++---------- 2 files changed, 214 insertions(+), 131 deletions(-) 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))) -- 2.25.1