From 70220c78a1ebd64ca276b831892e9315b7f08e7b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 28 Feb 2016 00:00:23 -0800 Subject: [PATCH] Fix parameterization in unpars.scm. --- src/6001/nodefs.scm | 6 +- src/compiler/base/debug.scm | 8 +- src/compiler/base/object.scm | 2 +- src/compiler/base/toplev.scm | 4 +- src/compiler/documentation/porting.guide | 4 +- src/compiler/machines/C/compiler.pkg | 4 +- src/compiler/machines/alpha/compiler.pkg | 4 +- src/compiler/machines/alpha/dassm1.scm | 4 +- src/compiler/machines/bobcat/compiler.pkg | 4 +- src/compiler/machines/bobcat/dassm1.scm | 4 +- src/compiler/machines/i386/compiler.pkg | 4 +- src/compiler/machines/i386/dassm1.scm | 4 +- src/compiler/machines/mips/compiler.pkg | 4 +- src/compiler/machines/mips/dassm1.scm | 4 +- src/compiler/machines/spectrum/compiler.pkg | 4 +- src/compiler/machines/spectrum/dassm1.scm | 4 +- src/compiler/machines/svm/compiler.pkg | 4 +- src/compiler/machines/svm/disassembler.scm | 4 +- src/compiler/machines/vax/compiler.pkg | 4 +- src/compiler/machines/vax/dassm1.scm | 4 +- src/compiler/machines/x86-64/compiler.pkg | 4 +- src/compiler/machines/x86-64/dassm1.scm | 4 +- src/edwin/artdebug.scm | 4 +- src/edwin/debug.scm | 5 +- src/edwin/evlcom.scm | 6 +- src/edwin/intmod.scm | 3 +- src/edwin/prompt.scm | 2 +- src/edwin/schmod.scm | 2 +- src/runtime/boot.scm | 2 +- src/runtime/debug.scm | 8 +- src/runtime/error.scm | 4 +- src/runtime/pp.scm | 33 +-- src/runtime/rep.scm | 11 +- src/runtime/runtime.pkg | 16 ++ src/runtime/stack-sample.scm | 8 +- src/runtime/swank.scm | 8 +- src/runtime/unpars.scm | 290 ++++++++++++-------- src/sf/cgen.scm | 2 +- src/sicp/compat.scm | 6 +- src/swat/scheme/other/rtest.scm | 4 +- tests/unit-testing.scm | 2 +- 41 files changed, 297 insertions(+), 211 deletions(-) diff --git a/src/6001/nodefs.scm b/src/6001/nodefs.scm index f45f75d81..31a4364a5 100644 --- a/src/6001/nodefs.scm +++ b/src/6001/nodefs.scm @@ -77,8 +77,8 @@ USA. (if (not (default-object? value)) (begin (write-string " --> " port) - (parameterize* (list (cons *unparser-list-depth-limit* 2) - (cons *unparser-list-breadth-limit* 10) - (cons *unparser-string-length-limit* 30)) + (parameterize* (list (cons param:unparser-list-depth-limit 2) + (cons param:unparser-list-breadth-limit 10) + (cons param:unparser-string-length-limit 30)) (lambda () (write value port)))))))) diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm index d0632ca55..dbe10b2e1 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -105,15 +105,15 @@ USA. (define (write-instructions thunk) (fluid-let ((*show-instruction* write)) - (parameterize* (list (cons *unparser-radix* 16) - (cons *unparse-uninterned-symbols-by-name?* #t)) + (parameterize* (list (cons param:unparser-radix 16) + (cons param:unparse-uninterned-symbols-by-name? #t)) thunk))) (define (pp-instructions thunk) (fluid-let ((*show-instruction* pretty-print)) (parameterize* (list (cons *pp-primitives-by-name* #f) - (cons *unparser-radix* 16) - (cons *unparse-uninterned-symbols-by-name?* #t)) + (cons param:unparser-radix 16) + (cons param:unparse-uninterned-symbols-by-name? #t)) thunk))) (define *show-instruction*) diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm index 842afc5c2..dbb581758 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -156,6 +156,6 @@ USA. (unparser/standard-method name)))) (define (tagged-vector/unparse state vector) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () ((tagged-vector/unparser vector) state vector)))) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index 7dd7a50b3..f059f1ed2 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -1063,8 +1063,8 @@ USA. (define (phase/lap-file-output scode port) (compiler-phase "LAP File Output" (lambda () - (parameterize* (list (cons *unparser-radix* 16) - (cons *unparse-uninterned-symbols-by-name?* #t)) + (parameterize* (list (cons param:unparser-radix 16) + (cons param:unparse-uninterned-symbols-by-name? #t)) (lambda () (with-output-to-port port (lambda () diff --git a/src/compiler/documentation/porting.guide b/src/compiler/documentation/porting.guide index 49192a999..985d4b2bc 100644 --- a/src/compiler/documentation/porting.guide +++ b/src/compiler/documentation/porting.guide @@ -3735,9 +3735,7 @@ Here is an example package declaration, drawn from the compiler: *rtl-procedures* *rtl-graphs*) (import (runtime compiler-info) - make-dbg-info-vector) - (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + make-dbg-info-vector)) The read-eval-print loop of Scheme evaluates all expressions in the same environment. It is possible to change this environment using the diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg index 5024d116f..92c3906cb 100644 --- a/src/compiler/machines/C/compiler.pkg +++ b/src/compiler/machines/C/compiler.pkg @@ -284,7 +284,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (runtime load) fasload-object-file) (import (scode-optimizer build-utilities) @@ -308,7 +308,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/alpha/compiler.pkg b/src/compiler/machines/alpha/compiler.pkg index 4d696bf08..50314a077 100644 --- a/src/compiler/machines/alpha/compiler.pkg +++ b/src/compiler/machines/alpha/compiler.pkg @@ -243,7 +243,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -265,7 +265,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/alpha/dassm1.scm b/src/compiler/machines/alpha/dassm1.scm index aa6de8e3b..5215e250a 100644 --- a/src/compiler/machines/alpha/dassm1.scm +++ b/src/compiler/machines/alpha/dassm1.scm @@ -131,7 +131,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -148,7 +148,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/bobcat/compiler.pkg b/src/compiler/machines/bobcat/compiler.pkg index 54fdb9e05..5effd1c62 100644 --- a/src/compiler/machines/bobcat/compiler.pkg +++ b/src/compiler/machines/bobcat/compiler.pkg @@ -249,7 +249,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -271,7 +271,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/bobcat/dassm1.scm b/src/compiler/machines/bobcat/dassm1.scm index 6a37eb763..5de904488 100644 --- a/src/compiler/machines/bobcat/dassm1.scm +++ b/src/compiler/machines/bobcat/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -134,7 +134,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 53d773c15..503ba51a6 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -272,7 +272,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -294,7 +294,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index 880ac5458..98a41d07f 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction comment) @@ -144,7 +144,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/marked-start block))) diff --git a/src/compiler/machines/mips/compiler.pkg b/src/compiler/machines/mips/compiler.pkg index 84ca71185..ee0e0c62c 100644 --- a/src/compiler/machines/mips/compiler.pkg +++ b/src/compiler/machines/mips/compiler.pkg @@ -249,7 +249,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -271,7 +271,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/mips/dassm1.scm b/src/compiler/machines/mips/dassm1.scm index 6a37eb763..5de904488 100644 --- a/src/compiler/machines/mips/dassm1.scm +++ b/src/compiler/machines/mips/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -134,7 +134,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/spectrum/compiler.pkg b/src/compiler/machines/spectrum/compiler.pkg index 760906264..7cc516c96 100644 --- a/src/compiler/machines/spectrum/compiler.pkg +++ b/src/compiler/machines/spectrum/compiler.pkg @@ -253,7 +253,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -275,7 +275,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/spectrum/dassm1.scm b/src/compiler/machines/spectrum/dassm1.scm index 0adcc7b14..890c5f5a6 100644 --- a/src/compiler/machines/spectrum/dassm1.scm +++ b/src/compiler/machines/spectrum/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -134,7 +134,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index cb2873571..e04381a85 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -280,7 +280,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -302,7 +302,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index adcfee1d6..420098b50 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -110,7 +110,7 @@ USA. (make-cursor block start symbol-table))) (define (write-instructions cursor) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (compiled-code-block/code-end (cursor-block cursor)))) (let loop () @@ -219,7 +219,7 @@ USA. #t))))) (define (write-constants cursor) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let* ((block (cursor-block cursor)) (end (compiled-code-block/index->offset diff --git a/src/compiler/machines/vax/compiler.pkg b/src/compiler/machines/vax/compiler.pkg index d143c002d..d59147146 100644 --- a/src/compiler/machines/vax/compiler.pkg +++ b/src/compiler/machines/vax/compiler.pkg @@ -244,7 +244,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -266,7 +266,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/vax/dassm1.scm b/src/compiler/machines/vax/dassm1.scm index b9e7b401b..bbbaf09c6 100644 --- a/src/compiler/machines/vax/dassm1.scm +++ b/src/compiler/machines/vax/dassm1.scm @@ -105,7 +105,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -122,7 +122,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg index 1b0f4334b..24c1849f3 100644 --- a/src/compiler/machines/x86-64/compiler.pkg +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -272,7 +272,7 @@ USA. make-dbg-info-vector split-inf-structure!) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*) + param:unparse-uninterned-symbols-by-name?) (import (scode-optimizer build-utilities) directory-processor)) @@ -294,7 +294,7 @@ USA. (import (runtime pretty-printer) *pp-primitives-by-name*) (import (runtime unparser) - *unparse-uninterned-symbols-by-name?*)) + param:unparse-uninterned-symbols-by-name?)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index 880ac5458..98a41d07f 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction comment) @@ -144,7 +144,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons *unparser-radix* 16)) + (parameterize* (list (cons param:unparser-radix 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/marked-start block))) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index 8cb1be85f..32d7552e7 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -1013,7 +1013,7 @@ Prefix argument means do not kill the debugger buffer." port)))) (define (print-with-subexpression expression subexpression) - (parameterize* (list (cons *unparse-primitives-by-name?* #t)) + (parameterize* (list (cons param:unparse-primitives-by-name? #t)) (lambda () (if (invalid-subexpression? subexpression) (write (unsyntax expression)) @@ -1043,7 +1043,7 @@ Prefix argument means do not kill the debugger buffer." port)) (define (print-reduction-as-subexpression expression) - (parameterize* (list (cons *unparse-primitives-by-name?* #t)) + (parameterize* (list (cons param:unparse-primitives-by-name? #t)) (lambda () (write-string (ref-variable subexpression-start-marker)) (write (unsyntax expression)) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index 7cbeb937d..a309884e1 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -1291,7 +1291,8 @@ it has been renamed, it will not be deleted automatically.") (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (parameterize* (list (cons *unparse-primitives-by-name?* #t)) + (parameterize* (list (cons param:unparse-primitives-by-name? + #t)) (lambda () (write (unsyntax (if (invalid-subexpression? subexpression) @@ -1382,7 +1383,7 @@ it has been renamed, it will not be deleted automatically.") (subproblem/number (reduction/subproblem reduction))) port))) (write-string " " port) - (parameterize* (list (cons *unparse-primitives-by-name?* #t)) + (parameterize* (list (cons param:unparse-primitives-by-name? #t)) (lambda () (write (unsyntax (reduction/expression reduction)) port))))) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index 19ef0eca2..1767df90f 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -234,7 +234,7 @@ The values are printed in the typein window." (lambda (buffer) (insert-string (parameterize* - (list (cons *unparse-with-maximum-readability?* #t)) + (list (cons param: #t)) (lambda () (write-to-string expression))) (buffer-end buffer))))) @@ -528,9 +528,9 @@ Set by Scheme evaluation code to update the mode line." (define (transcript-value-string value) (if (undefined-value? value) "" - (parameterize* (list (cons *unparser-list-depth-limit* + (parameterize* (list (cons param:unparser-list-depth-limit (ref-variable transcript-list-depth-limit)) - (cons *unparser-list-breadth-limit* + (cons param:unparser-list-breadth-limit (ref-variable transcript-list-breadth-limit))) (lambda () (write-to-string value))))) diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm index b7427f847..4fbc2e738 100644 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@ -727,7 +727,8 @@ If this is an error, the debugger examines the error condition." (lambda (mark) (if mark (insert-string - (parameterize* (list (cons *unparse-with-maximum-readability?* #t)) + (parameterize* (list (cons param:unparse-with-maximum-readability? + #t)) (lambda () (write-to-string expression))) mark)))) diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index b3b89ea8c..3f605e4bf 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -978,7 +978,7 @@ it is added to the front of the command history." (set-prompt-history-strings! 'REPEAT-COMPLEX-COMMAND (map (lambda (command) - (parameterize* (list (cons *unparse-with-maximum-readability?* #t)) + (parameterize* (list (cons param:unparse-with-maximum-readability? #t)) (lambda () (write-to-string command)))) (command-history-list))) diff --git a/src/edwin/schmod.scm b/src/edwin/schmod.scm index 8eb020c3e..54ed27995 100644 --- a/src/edwin/schmod.scm +++ b/src/edwin/schmod.scm @@ -327,7 +327,7 @@ Otherwise, it is shown in the echo area." (insert-string " . " point) (insert-string (symbol-name argl) point))))) (parameterize* - (list (cons *unparse-uninterned-symbols-by-name?* #t)) + (list (cons param:unparse-uninterned-symbols-by-name? #t)) (lambda () (message procedure-name ": " argl))))) (editor-error "Expression does not evaluate to a procedure: " diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 0ba8e8f59..80997d75e 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -63,7 +63,7 @@ USA. (lambda (state object) (let ((port (unparser-state/port state)) (hash-string (number->string (hash object)))) - (if (*unparse-with-maximum-readability?*) + (if (get-param:unparse-with-maximum-readability?) (begin (write-string "#@" port) (write-string hash-string port)) diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index 892a8f200..c5c908235 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -474,7 +474,7 @@ USA. (output-to-string 50 (lambda () - (parameterize* (list (cons *unparse-primitives-by-name?* true)) + (parameterize* (list (cons param:unparse-primitives-by-name? #t)) (lambda () (write (unsyntax expression))))))) ((debugging-info/noise? expression) @@ -956,11 +956,11 @@ using the read-eval-print environment instead.") (string-capitalize (if reason (string-append reason "; " message) message))) (define (debugger-pp expression indentation port) - (parameterize* (list (cons *unparser-list-depth-limit* + (parameterize* (list (cons param:unparser-list-depth-limit debugger:list-depth-limit) - (cons *unparser-list-breadth-limit* + (cons param:unparser-list-breadth-limit debugger:list-breadth-limit) - (cons *unparser-string-length-limit* + (cons param:unparser-string-length-limit debugger:string-length-limit)) (lambda () (pretty-print expression port true indentation)))) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 43f1d1a96..b132d71da 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -1268,8 +1268,8 @@ USA. (else (error "Unexpected value:" v))))))) (define (format-error-message message irritants port) - (parameterize* (list (cons *unparser-list-depth-limit* 2) - (cons *unparser-list-breadth-limit* 5)) + (parameterize* (list (cons param:unparser-list-depth-limit 2) + (cons param:unparser-list-breadth-limit 5)) (lambda () (for-each (lambda (irritant) (if (and (pair? irritant) diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index dfb966017..e39f320f5 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -234,11 +234,11 @@ USA. (- (or (*pp-forced-x-size*) (output-port/x-size port)) 1)) (cons output-port port) - (cons *unparse-uninterned-symbols-by-name?* + (cons param:unparse-uninterned-symbols-by-name? (*pp-uninterned-symbols-by-name*)) - (cons *unparse-abbreviate-quotations?* + (cons param:unparse-abbreviate-quotations? (or as-code? - (*unparse-abbreviate-quotations?*)))) + (param:unparse-abbreviate-quotations?)))) (lambda () (let* ((numerical-walk (if (*pp-avoid-circularity?*) @@ -718,14 +718,14 @@ USA. object)))) (define (walk-pair pair list-depth) - (if (let ((limit (*unparser-list-depth-limit*))) + (if (let ((limit (get-param:unparser-list-depth-limit))) (and limit (>= list-depth limit) (no-highlights? pair))) "..." (let ((list-depth (+ list-depth 1))) (let loop ((pair pair) (list-breadth 0)) - (cond ((let ((limit (*unparser-list-breadth-limit*))) + (cond ((let ((limit (get-param:unparser-list-breadth-limit))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -743,7 +743,8 @@ USA. (make-list-node "." (make-singleton-list-node - (if (let ((limit (*unparser-list-breadth-limit*))) + (if (let ((limit + (get-param:unparser-list-breadth-limit))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -768,14 +769,14 @@ USA. (define (walk-highlighted-object object list-depth numerical-walk) (let ((dl (pph/depth-limit object))) - (parameterize* (list (cons *unparser-list-breadth-limit* + (parameterize* (list (cons param:unparser-list-breadth-limit (let ((bl (pph/breadth-limit object))) (if (eq? bl 'DEFAULT) - (*unparser-list-breadth-limit*) + (param:unparser-list-breadth-limit) bl))) - (cons *unparser-list-depth-limit* + (cons param:unparser-list-depth-limit (if (eq? dl 'DEFAULT) - (*unparser-list-depth-limit*) + (param:unparser-list-depth-limit) dl))) (lambda () (numerical-walk (pph/object object) @@ -859,7 +860,7 @@ USA. ;;; The following two procedures walk lists and vectors, respectively. (define (walk-pair-terminating pair half-pointer/queue list-depth) - (if (let ((limit (*unparser-list-depth-limit*))) + (if (let ((limit (get-param:unparser-list-depth-limit))) (and limit (>= list-depth limit) (no-highlights? pair))) @@ -867,7 +868,7 @@ USA. (let ((list-depth (+ list-depth 1))) (let loop ((pair pair) (list-breadth 0) (half-pointer/queue half-pointer/queue)) - (cond ((let ((limit (*unparser-list-breadth-limit*))) + (cond ((let ((limit (get-param:unparser-list-breadth-limit))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -910,7 +911,7 @@ USA. "." (make-singleton-list-node (if - (let ((limit (*unparser-list-breadth-limit*))) + (let ((limit (get-param:unparser-list-breadth-limit))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -927,14 +928,14 @@ USA. half-pointer/queue list-depth))))))))))))))) (define (walk-vector-terminating pair half-pointer/queue list-depth) - (if (let ((limit (*unparser-list-depth-limit*))) + (if (let ((limit (get-param:unparser-list-depth-limit))) (and limit (>= list-depth limit) (no-highlights? pair))) "..." (let ((list-depth (+ list-depth 1))) (let loop ((pair pair) (list-breadth 0)) - (cond ((let ((limit (*unparser-list-breadth-limit*))) + (cond ((let ((limit (get-param:unparser-list-breadth-limit))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -967,7 +968,7 @@ USA. "." (make-singleton-list-node (if (let ((limit - (*unparser-list-breadth-limit*))) + (get-param:unparser-list-breadth-limit))) (and limit (>= list-breadth limit) (no-highlights? pair))) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index b8fef388a..d70e5cb6c 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -543,11 +543,12 @@ USA. (or message (and condition (cmdl-message/strings - (parameterize* (list (cons *unparser-list-depth-limit* 25) - (cons *unparser-list-breadth-limit* 100) - (cons *unparser-string-length-limit* 500)) - (lambda () - (condition/report-string condition)))))) + (parameterize* + (list (cons param:unparser-list-depth-limit 25) + (cons param:unparser-list-breadth-limit 100) + (cons param:unparser-string-length-limit 500)) + (lambda () + (condition/report-string condition)))))) (and condition repl:allow-restart-notifications? (condition-restarts-message condition)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 1c1bc0fd4..5a2c28574 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5013,6 +5013,18 @@ USA. guarantee-unparser-state guarantee-unparser-table make-unparser-table + param:unparse-abbreviate-quotations? + param:unparse-compound-procedure-names? + param:unparse-primitives-by-name? + param:unparse-streams? + param:unparse-uninterned-symbols-by-name? + param:unparse-with-datum? + param:unparse-with-maximum-readability? + param:unparser-list-breadth-limit + param:unparser-list-depth-limit + param:unparser-radix + param:unparser-string-length-limit + param:unparser-table system-global-unparser-table unparse-char unparse-object @@ -5025,11 +5037,15 @@ USA. unparser-table? user-object-type with-current-unparser-state) + (export (runtime boot-definitions) + get-param:unparse-with-maximum-readability?) (export (runtime record) rtd:unparser-state) (export (runtime output-port) unparse-object/top-level) (export (runtime pretty-printer) + get-param:unparser-list-breadth-limit + get-param:unparser-list-depth-limit make-unparser-state unparse-list/prefix-pair? unparse-list/unparser diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index 1f7897ac6..b8a0e25da 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -397,10 +397,10 @@ (define (profile-pp expression output-port) ;; Random parametrization. - (parameterize* (list (cons *unparser-list-breadth-limit* 5) - (cons *unparser-list-depth-limit* 3) - (cons *unparser-string-length-limit* 40) - (cons *unparse-primitives-by-name?* #t) + (parameterize* (list (cons param:unparser-list-breadth-limit 5) + (cons param:unparser-list-depth-limit 3) + (cons param:unparser-string-length-limit 40) + (cons param:unparse-primitives-by-name? #t) (cons *pp-save-vertical-space?* #t) (cons *pp-default-as-code?* #t)) (lambda () diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index fff751840..10ee4025e 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -760,7 +760,7 @@ swank:xref (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (parameterize* (list (cons *unparse-primitives-by-name?* #t)) + (parameterize* (list (cons param:unparse-primitives-by-name? #t)) (lambda () (write (unsyntax @@ -1112,9 +1112,9 @@ swank:xref (define (pprint-to-string o) (call-with-output-string (lambda (p) - (parameterize* (list (cons *unparser-list-breadth-limit* 10) - (cons *unparser-list-depth-limit* 4) - (cons *unparser-string-length-limit* 100)) + (parameterize* (list (cons param:unparser-list-breadth-limit 10) + (cons param:unparser-list-depth-limit 4) + (cons param:unparser-string-length-limit 100)) (lambda () (pp o p)))))) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 380c353d1..4063fc368 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -29,56 +29,143 @@ USA. (declare (usual-integrations)) +(define hook/interned-symbol) +(define hook/procedure-unparser) +(define string-delimiters) +(define non-canon-symbol-quoted) +(define canon-symbol-quoted) +(define system-global-unparser-table) + +(define *unparse-abbreviate-quotations?* #!default) +(define *unparse-compound-procedure-names?* #!default) +(define *unparse-primitives-by-name?* #!default) +(define *unparse-streams?* #!default) +(define *unparse-uninterned-symbols-by-name?* #!default) +(define *unparse-with-datum?* #!default) +(define *unparse-with-maximum-readability?* #!default) +(define *unparser-list-breadth-limit* #!default) +(define *unparser-list-depth-limit* #!default) +(define *unparser-radix* #!default) +(define *unparser-string-length-limit* #!default) +(define *unparser-table* #!default) + +(define param:unparse-abbreviate-quotations?) +(define param:unparse-compound-procedure-names?) +(define param:unparse-primitives-by-name?) +(define param:unparse-streams?) +(define param:unparse-uninterned-symbols-by-name?) +(define param:unparse-with-datum?) +(define param:unparse-with-maximum-readability?) +(define param:unparser-list-breadth-limit) +(define param:unparser-list-depth-limit) +(define param:unparser-radix) +(define param:unparser-string-length-limit) +(define param:unparser-table) + +(define param:default-unparser-state) +(define param:dispatch-table) +(define param:environment) +(define param:list-depth) +(define param:output-port) +(define param:slashify?) +;; 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! string-delimiters - (char-set-union char-set:not-graphic (char-set #\" #\\))) (set! hook/interned-symbol unparse-symbol) (set! hook/procedure-unparser #f) - (set! *unparser-radix* (make-parameter 10)) - (set! *unparser-list-breadth-limit* (make-parameter #f)) - (set! *unparser-list-depth-limit* (make-parameter #f)) - (set! *unparser-string-length-limit* (make-parameter #f)) - (set! *unparse-primitives-by-name?* (make-parameter #f)) - (set! *unparse-uninterned-symbols-by-name?* (make-parameter #f)) - (set! *unparse-with-maximum-readability?* (make-parameter #f)) - (set! *unparse-compound-procedure-names?* (make-parameter #t)) - (set! *unparse-with-datum?* (make-parameter #f)) - (set! *unparse-abbreviate-quotations?* (make-parameter #f)) - (set! *unparse-streams?* (make-parameter #t)) - (set! system-global-unparser-table (make-system-global-unparser-table)) - (set! *unparser-table* (make-parameter system-global-unparser-table)) - (set! *default-unparser-state* (make-parameter #f)) + (set! string-delimiters + (char-set-union char-set:not-graphic (char-set #\" #\\))) (set! non-canon-symbol-quoted - (char-set-union char-set/atom-delimiters - char-set/symbol-quotes)) + (char-set-union char-set/atom-delimiters char-set/symbol-quotes)) (set! canon-symbol-quoted - (char-set-union non-canon-symbol-quoted - char-set:upper-case)) - (set! *unparsing-within-brackets* (make-parameter #f)) - (set! *list-depth* (make-parameter #f)) - (set! *output-port* (make-parameter #f)) - (set! *slashify?* (make-parameter #f)) - (set! *environment* (make-parameter #f)) - (set! *dispatch-table* (make-parameter #f)) - unspecific) - -(define *unparser-radix*) -(define *unparser-list-breadth-limit*) -(define *unparser-list-depth-limit*) -(define *unparser-string-length-limit*) -(define *unparse-primitives-by-name?*) -(define *unparse-uninterned-symbols-by-name?*) -(define *unparse-with-maximum-readability?*) -(define *unparse-compound-procedure-names?*) -(define *unparse-with-datum?*) -(define *unparse-abbreviate-quotations?*) -(define *unparse-streams?*) -(define system-global-unparser-table) -(define *unparser-table*) -(define *default-unparser-state*) -(define non-canon-symbol-quoted) -(define canon-symbol-quoted) + (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:unparser-table + (make-settable-parameter system-global-unparser-table)) + + (set! param:default-unparser-state (make-unsettable-parameter #f)) + (set! param:dispatch-table (make-unsettable-parameter #f)) + (set! param:environment (make-unsettable-parameter #f)) + (set! param:list-depth (make-unsettable-parameter #f)) + (set! param:output-port (make-unsettable-parameter #f)) + (set! param:slashify? (make-unsettable-parameter #f)) + (set! param:unparsing-within-brackets? (make-unsettable-parameter #f)) + unspecific) + +(define (get-param:unparse-abbreviate-quotations?) + (if (default-object? *unparse-abbreviate-quotations?*) + (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?*)) + +(define (get-param:unparse-primitives-by-name?) + (if (default-object? *unparse-primitives-by-name?*) + (param:unparse-primitives-by-name?) + *unparse-primitives-by-name?*)) + +(define (get-param:unparse-streams?) + (if (default-object? *unparse-streams?*) + (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?*)) + +(define (get-param:unparse-with-datum?) + (if (default-object? *unparse-with-datum?*) + (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?*)) + +(define (get-param:unparser-list-breadth-limit) + (if (default-object? *unparser-list-breadth-limit*) + (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*)) + +(define (get-param:unparser-radix) + (if (default-object? *unparser-radix*) + (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*)) + +(define (get-param:unparser-table) + (if (default-object? *unparser-table*) + (param:unparser-table) + *unparser-table*)) + (define (make-system-global-unparser-table) (let ((table (make-unparser-table unparse/default))) (for-each (lambda (entry) @@ -146,7 +233,7 @@ USA. (define (with-current-unparser-state state procedure) (guarantee-unparser-state state 'WITH-CURRENT-UNPARSER-STATE) - (parameterize* (list (cons *default-unparser-state* state)) + (parameterize* (list (cons param:default-unparser-state state)) (lambda () (procedure (unparser-state/port state))))) @@ -169,7 +256,7 @@ USA. (unparser-state/environment state))) (define (unparse-object/top-level object port slashify? environment) - (let ((state (*default-unparser-state*))) + (let ((state (param:default-unparser-state))) (unparse-object/internal object port @@ -187,47 +274,40 @@ USA. environment))))) (define (unparse-object/internal object port list-depth slashify? environment) - (parameterize* (list (cons *list-depth* list-depth) - (cons *output-port* port) - (cons *slashify?* slashify?) - (cons *environment* environment) - (cons *dispatch-table* + (parameterize* (list (cons param:list-depth list-depth) + (cons param:output-port port) + (cons param:slashify? slashify?) + (cons param:environment environment) + (cons param:dispatch-table (unparser-table/dispatch-vector - (let ((table (*unparser-table*))) + (let ((table (get-param:unparser-table))) (guarantee-unparser-table table #f) table)))) (lambda () (*unparse-object object)))) (define-integrable (invoke-user-method method object) - (method (make-unparser-state (*output-port*) - (*list-depth*) - (*slashify?*) - (*environment*)) + (method (make-unparser-state (param:output-port) + (param:list-depth) + (param:slashify?) + (param:environment)) object)) -(define *list-depth*) -(define *slashify?*) -(define *environment*) -(define *dispatch-table*) - (define (*unparse-object object) - ((vector-ref (*dispatch-table*) + ((vector-ref (param:dispatch-table) ((ucode-primitive primitive-object-type 1) object)) object)) ;;;; Low Level Operations -(define *output-port*) - (define-integrable (*unparse-char char) - (output-port/write-char (*output-port*) char)) + (output-port/write-char (param:output-port) char)) (define-integrable (*unparse-string string) - (output-port/write-string (*output-port*) string)) + (output-port/write-string (param:output-port) string)) (define-integrable (*unparse-substring string start end) - (output-port/write-substring (*output-port*) string start end)) + (output-port/write-substring (param:output-port) string start end)) (define-integrable (*unparse-datum object) (*unparse-hex (object-datum object))) @@ -243,27 +323,23 @@ USA. (*unparse-string "#@") (*unparse-hash object)) -;; Dynamically bound to #T if we are already unparsing a bracketed -;; object so we can avoid nested brackets. -(define *unparsing-within-brackets*) - ;; Values to use while unparsing within brackets. (define within-brackets-list-breadth-limit 5) (define within-brackets-list-depth-limit 3) (define (*unparse-with-brackets name object thunk) - (if (or (and (*unparse-with-maximum-readability?*) object) - (*unparsing-within-brackets*)) + (if (or (and (get-param:unparse-with-maximum-readability?) object) + (param:unparsing-within-brackets?)) (*unparse-readable-hash object) - (parameterize* (list (cons *unparsing-within-brackets* #t) - (cons *unparser-list-breadth-limit* - (if (*unparser-list-breadth-limit*) - (min (*unparser-list-breadth-limit*) + (parameterize* (list (cons param:unparsing-within-brackets? #t) + (cons param:unparser-list-breadth-limit + (if (get-param:unparser-list-breadth-limit) + (min (get-param:unparser-list-breadth-limit) within-brackets-list-breadth-limit) within-brackets-list-breadth-limit)) - (cons *unparser-list-depth-limit* - (if (*unparser-list-depth-limit*) - (min (*unparser-list-depth-limit*) + (cons param:unparser-list-depth-limit + (if (get-param:unparser-list-depth-limit) + (min (get-param:unparser-list-depth-limit) within-brackets-list-depth-limit) within-brackets-list-depth-limit))) (lambda () @@ -279,7 +355,7 @@ USA. (begin (*unparse-char #\space) (limit-unparse-depth thunk)) - (if (*unparse-with-datum?*) + (if (get-param:unparse-with-datum?) (begin (*unparse-char #\space) (*unparse-datum object)))) @@ -353,10 +429,8 @@ USA. (define (unparse/interned-symbol symbol) (hook/interned-symbol symbol)) -(define hook/interned-symbol) - (define (unparse/uninterned-symbol symbol) - (if (*unparse-uninterned-symbols-by-name?*) + (if (get-param:unparse-uninterned-symbols-by-name?) (unparse-symbol symbol) (*unparse-with-brackets 'UNINTERNED-SYMBOL symbol (lambda () @@ -368,7 +442,7 @@ USA. (unparse-symbol-name (symbol-name symbol)))) (define (unparse-keyword-name s) - (case (get-param:parser-keyword-style (*environment*)) + (case (get-param:parser-keyword-style (param:environment)) ((PREFIX) (*unparse-char #\:) (unparse-symbol-name s)) @@ -383,7 +457,7 @@ USA. (define (unparse-symbol-name s) (if (or (string-find-next-char-in-set s - (if (get-param:parser-canonicalize-symbols? (*environment*)) + (if (get-param:parser-canonicalize-symbols? (param:environment)) canon-symbol-quoted non-canon-symbol-quoted)) (fix:= (string-length s) 0) @@ -416,7 +490,7 @@ USA. (char=? (string-ref string 0) #\#)) (define (looks-like-keyword? string) - (case (get-param:parser-keyword-style (*environment*)) + (case (get-param:parser-keyword-style (param:environment)) ((PREFIX) (char=? (string-ref string 0) #\:)) ((SUFFIX) @@ -424,7 +498,7 @@ USA. (else #f))) (define (unparse/character character) - (if (or (*slashify?*) + (if (or (param:slashify?) (not (char-ascii? character))) (begin (*unparse-string "#\\") @@ -432,10 +506,10 @@ USA. (*unparse-char character))) (define (unparse/string string) - (if (*slashify?*) + (if (param:slashify?) (let ((end (string-length string))) (let ((end* - (let ((limit (*unparser-string-length-limit*))) + (let ((limit (get-param:unparser-string-length-limit))) (if limit (min limit end) end)))) @@ -485,8 +559,6 @@ USA. (digit->char (integer-divide-remainder qr2) 8) (digit->char (integer-divide-remainder qr1) 8))))) -(define string-delimiters) - (define (unparse/bit-string bit-string) (*unparse-string "#*") (let loop ((index (fix:- (bit-string-length bit-string) 1))) @@ -524,7 +596,7 @@ USA. (let loop ((index 1)) (cond ((fix:= index length) (*unparse-char #\))) - ((let ((limit (*unparser-list-breadth-limit*))) + ((let ((limit (get-param:unparser-list-breadth-limit))) (and limit (>= index limit))) (*unparse-string " ...)")) (else @@ -542,7 +614,7 @@ USA. (map-reference-trap (lambda () (vector-ref vector index)))) (define (unparse/record record) - (if (*unparse-with-maximum-readability?*) + (if (get-param:unparse-with-maximum-readability?) (*unparse-readable-hash record) (invoke-user-method unparse-record record))) @@ -551,7 +623,7 @@ USA. => (lambda (prefix) (unparse-list/prefix-pair prefix pair))) ((unparse-list/unparser pair) => (lambda (method) (invoke-user-method method pair))) - ((and (*unparse-streams?*) (stream-pair? pair)) + ((and (get-param:unparse-streams?) (stream-pair? pair)) (unparse-list/stream-pair pair)) (else (unparse-list pair)))) @@ -565,10 +637,10 @@ USA. (*unparse-char #\))))) (define (limit-unparse-depth kernel) - (let ((limit (*unparser-list-depth-limit*))) + (let ((limit (get-param:unparser-list-depth-limit))) (if limit - (let ((depth (*list-depth*))) - (parameterize* (list (cons *list-depth* (1+ depth))) + (let ((depth (param:list-depth))) + (parameterize* (list (cons param:list-depth (1+ depth))) (lambda () (if (> (1+ depth) limit) (*unparse-string "...") @@ -585,7 +657,7 @@ USA. (begin (*unparse-char #\space) (*unparse-object (safe-car l)) - (if (let ((limit (*unparser-list-breadth-limit*))) + (if (let ((limit (get-param:unparser-list-breadth-limit))) (and limit (>= n limit) (pair? (safe-cdr l)))) @@ -609,7 +681,7 @@ USA. (*unparse-object (safe-car (safe-cdr pair)))) (define (unparse-list/prefix-pair? object) - (and (*unparse-abbreviate-quotations?*) + (and (get-param:unparse-abbreviate-quotations?) (pair? (safe-cdr object)) (null? (safe-cdr (safe-cdr object))) (case (safe-car object) @@ -638,7 +710,7 @@ USA. ((stream-pair? value) (*unparse-char #\space) (*unparse-object (safe-car value)) - (if (let ((limit (*unparser-list-breadth-limit*))) + (if (let ((limit (get-param:unparser-list-breadth-limit))) (and limit (>= n limit))) (*unparse-string " ...") @@ -655,8 +727,6 @@ USA. ;;;; Procedures -(define hook/procedure-unparser) - (define (unparse-procedure procedure usual-method) (let ((method (and hook/procedure-unparser @@ -673,7 +743,7 @@ USA. (unparse-procedure procedure (lambda () (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure - (and (*unparse-compound-procedure-names?*) + (and (get-param:unparse-compound-procedure-names?) (lambda-components* (procedure-lambda procedure) (lambda (name required optional rest body) required optional rest body @@ -686,9 +756,9 @@ USA. (let ((unparse-name (lambda () (*unparse-object (primitive-procedure-name procedure))))) - (cond ((*unparse-primitives-by-name?*) + (cond ((get-param:unparse-primitives-by-name?) (unparse-name)) - ((*unparse-with-maximum-readability?*) + ((get-param:unparse-with-maximum-readability?) (*unparse-readable-hash procedure)) (else (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f @@ -770,7 +840,7 @@ USA. (*unparse-string prefix)) radix) 10)))) - (case (*unparser-radix*) + (case (get-param:unparser-radix) ((2) (prefix "#b" 2 2)) ((8) (prefix "#o" 8 8)) ((16) (prefix "#x" 10 16)) @@ -786,7 +856,7 @@ USA. (*unparse-with-brackets "floating-vector" v (and (not (zero? length)) (lambda () - (let ((limit (let ((limit (*unparser-list-breadth-limit*))) + (let ((limit (let ((limit (get-param:unparser-list-breadth-limit))) (if (not limit) length (min length limit))))) @@ -819,7 +889,7 @@ USA. (compiled-procedure/name proc)) => named-arity-dispatched-procedure) (else (plain 'ARITY-DISPATCHED-PROCEDURE))))) - ((*unparse-with-maximum-readability?*) + ((get-param:unparse-with-maximum-readability?) (*unparse-readable-hash entity)) ((record? (%entity-extra entity)) ;; Kludge to make the generic dispatch mechanism work. @@ -844,7 +914,7 @@ USA. (*unparse-object (promise-value promise))) (lambda () (*unparse-string "(unevaluated)") - (if (*unparse-with-datum?*) + (if (get-param:unparse-with-datum?) (begin (*unparse-char #\space) (*unparse-datum promise))))))) \ No newline at end of file diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index cec4b0bdf..f145c8837 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -245,6 +245,6 @@ USA. (define (pp-expression form #!optional port) (parameterize* (list (cons *pp-primitives-by-name* #f) (cons *pp-uninterned-symbols-by-name* #f) - (cons *unparse-abbreviate-quotations?* #t)) + (cons param:unparse-abbreviate-quotations? #t)) (lambda () (pp (cgen/external-with-declarations form) port)))) \ No newline at end of file diff --git a/src/sicp/compat.scm b/src/sicp/compat.scm index 8fffc1775..670ca6dd5 100644 --- a/src/sicp/compat.scm +++ b/src/sicp/compat.scm @@ -154,15 +154,13 @@ USA. (let ((newval (if (default-object? newval) false newval))) (if (not (or (not newval) (and (exact-integer? newval) (> newval 0)))) (error:illegal-datum newval 'PRINT-DEPTH)) - (*unparser-list-depth-limit* newval) - unspecific)) + (param:unparser-list-depth-limit newval))) (define (print-breadth #!optional newval) (let ((newval (if (default-object? newval) false newval))) (if (not (or (not newval) (and (exact-integer? newval) (> newval 0)))) (error:illegal-datum newval 'PRINT-BREADTH)) - (*unparser-list-breadth-limit* newval) - unspecific)) + (param:unparser-list-breadth-limit newval))) (define (ceiling->exact number) (inexact->exact (ceiling number))) diff --git a/src/swat/scheme/other/rtest.scm b/src/swat/scheme/other/rtest.scm index 444aa5ab5..43c894bf9 100644 --- a/src/swat/scheme/other/rtest.scm +++ b/src/swat/scheme/other/rtest.scm @@ -2,8 +2,8 @@ ;; to make this possible to debug -; (*unparser-list-breadth-limit* 10) -; (*unparser-list-depth-limit* 10) +; (param:unparser-list-breadth-limit 10) +; (param:unparser-list-depth-limit 10) ;; GC stress test diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index 24a3f2a79..0aafd43b8 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -229,7 +229,7 @@ USA. (define (write-expr-property tag p port) (write-tag tag port) - (let-fluid *unparse-abbreviate-quotations?* #t + (parameterize* (list (cons param:unparse-abbreviate-quotations? #t)) (lambda () (write (cdr p) port)))) -- 2.25.1