From 3dfe974427943a683381bd2c9ce980b54daa056b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 12 Jun 2018 20:51:48 -0700 Subject: [PATCH] Change nearly all code to use parameterize rather than parameterize*. --- src/6001/edextra.scm | 5 +- src/6001/nodefs.scm | 9 +- src/compiler/base/debug.scm | 19 ++-- src/compiler/base/object.scm | 5 +- src/compiler/base/toplev.scm | 76 ++++++++-------- src/compiler/machines/i386/dassm1.scm | 86 +++++++++--------- src/compiler/machines/svm/disassembler.scm | 58 ++++++------ src/compiler/machines/x86-64/dassm1.scm | 86 +++++++++--------- src/edwin/artdebug.scm | 45 +++++---- src/edwin/autold.scm | 16 ++-- src/edwin/bufcom.scm | 4 +- src/edwin/bufinp.scm | 12 +-- src/edwin/bufout.scm | 4 +- src/edwin/debug.scm | 68 +++++++------- src/edwin/editor.scm | 24 +++-- src/edwin/evlcom.scm | 75 +++++++-------- src/edwin/eystep.scm | 5 +- src/edwin/filcom.scm | 6 +- src/edwin/hlpcom.scm | 5 +- src/edwin/intmod.scm | 39 ++++---- src/edwin/prompt.scm | 6 +- src/edwin/schmod.scm | 6 +- src/edwin/winout.scm | 4 +- src/ffi/build.scm | 5 +- src/ffi/cdecls.scm | 5 +- src/imail/imail-util.scm | 7 +- src/runtime/advice.scm | 57 ++++++------ src/runtime/command-line.scm | 22 ++--- src/runtime/dbgutl.scm | 4 +- src/runtime/debug.scm | 29 +++--- src/runtime/error.scm | 74 +++++++-------- src/runtime/ffi.scm | 5 +- src/runtime/file-io.scm | 8 +- src/runtime/framex.scm | 5 +- src/runtime/infutl.scm | 11 +-- src/runtime/load.scm | 25 +++-- src/runtime/mit-macros.scm | 5 +- src/runtime/ntdir.scm | 12 +-- src/runtime/option.scm | 11 +-- src/runtime/pp.scm | 90 +++++++++--------- src/runtime/prgcop.scm | 14 ++- src/runtime/printer.scm | 10 +- src/runtime/rep.scm | 83 ++++++++--------- src/runtime/savres.scm | 5 +- src/runtime/stack-sample.scm | 22 ++--- src/runtime/string-io.scm | 12 +-- src/runtime/structure-parser.scm | 7 +- src/runtime/swank.scm | 101 +++++++++------------ src/runtime/syntax-rename.scm | 4 +- src/runtime/syntax.scm | 4 +- src/runtime/textual-port.scm | 20 ++-- src/runtime/thread.scm | 4 +- src/runtime/unsyn.scm | 5 +- src/runtime/unxdir.scm | 6 +- src/runtime/usrint.scm | 6 +- src/runtime/world-report.scm | 5 +- src/runtime/wrkdir.scm | 6 +- src/sf/cgen.scm | 9 +- src/sos/microbench.scm | 16 ++-- src/ssp/xhtml-expander.scm | 32 +++---- src/ssp/xmlrpc.scm | 5 +- tests/unit-testing.scm | 5 +- 62 files changed, 654 insertions(+), 765 deletions(-) diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm index 94546dca1..0f9cc47ab 100644 --- a/src/6001/edextra.scm +++ b/src/6001/edextra.scm @@ -294,9 +294,8 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh. (groups/files-to-copy groups))))) (define (load-quietly pathname environment) - (parameterize* (list (cons param:suppress-loading-message? #t)) - (lambda () - (load pathname environment)))) + (parameterize ((param:suppress-loading-message? #t)) + (load pathname environment))) (define (->string object) (if (string? object) diff --git a/src/6001/nodefs.scm b/src/6001/nodefs.scm index 9e5b51c45..fe8c2901c 100644 --- a/src/6001/nodefs.scm +++ b/src/6001/nodefs.scm @@ -79,8 +79,7 @@ USA. (if (not (default-object? value)) (begin (write-string " --> " port) - (parameterize* (list (cons param:printer-list-depth-limit 2) - (cons param:printer-list-breadth-limit 10) - (cons param:printer-string-length-limit 30)) - (lambda () - (write value port)))))))) + (parameterize ((param:printer-list-depth-limit 2) + (param:printer-list-breadth-limit 10) + (param:printer-string-length-limit 30)) + (write value port))))))) diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm index 66af842e6..87cfe0daa 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -78,9 +78,8 @@ USA. (define (write-rtl-instructions rtl port) (write-instructions (lambda () - (parameterize* (list (cons current-output-port port)) - (lambda () - (for-each show-rtl-instruction rtl)))))) + (parameterize ((current-output-port port)) + (for-each show-rtl-instruction rtl))))) (define (dump-rtl filename) (write-instructions @@ -105,16 +104,16 @@ USA. (define (write-instructions thunk) (fluid-let ((*show-instruction* write)) - (parameterize* (list (cons param:printer-radix 16) - (cons param:print-uninterned-symbols-by-name? #t)) - thunk))) + (parameterize ((param:printer-radix 16) + (param:print-uninterned-symbols-by-name? #t)) + (thunk)))) (define (pp-instructions thunk) (fluid-let ((*show-instruction* pretty-print)) - (parameterize* (list (cons param:pp-primitives-by-name? #f) - (cons param:printer-radix 16) - (cons param:print-uninterned-symbols-by-name? #t)) - thunk))) + (parameterize ((param:pp-primitives-by-name? #f) + (param:printer-radix 16) + (param:print-uninterned-symbols-by-name? #t)) + (thunk)))) (define *show-instruction*) diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm index f164a62d2..43b4dabc5 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -64,9 +64,8 @@ USA. (fix:> (vector-length object) 0) (eq? tag (vector-ref object 0)))) (lambda (vector port) - (parameterize* (list (cons param:printer-radix 16)) - (lambda () - ((tagged-vector/unparser vector) vector port))))) + (parameterize ((param:printer-radix 16)) + ((tagged-vector/unparser vector) vector port)))) tag)))) (define (define-vector-tag-unparser tag unparser) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index e0afce317..477dff42f 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -1076,42 +1076,40 @@ USA. (define (phase/lap-file-output scode port) (compiler-phase "LAP File Output" (lambda () - (parameterize* (list (cons param:printer-radix 16) - (cons param:print-uninterned-symbols-by-name? #t)) - (lambda () - (parameterize* (list (cons current-output-port port)) - (lambda () - (write-string "LAP for object ") - (write *recursive-compilation-number*) - (newline) - (pp scode (current-output-port) #t 4) - (newline) - (newline) - (newline) - (for-each - (lambda (instruction) - (cond ((and (pair? instruction) - (eq? (car instruction) 'LABEL)) - (write (cadr instruction)) - (write-char #\:)) - ((and (pair? instruction) - (eq? (car instruction) 'COMMENT)) - (write-char #\tab) - (write-string ";;") - (for-each (lambda (frob) - (write-string " ") - (write (if (and (pair? frob) - (eq? (car frob) 'RTL)) - (cadr frob) - frob))) - (cdr instruction))) - (else - (write-char #\tab) - (write instruction))) - (newline)) - *lap*) - (if (not (zero? *recursive-compilation-number*)) - (begin - (write-char #\page) - (newline))) - (output-port/flush-output port)))))))) + (parameterize ((param:printer-radix 16) + (param:print-uninterned-symbols-by-name? #t)) + (parameterize ((current-output-port port)) + (write-string "LAP for object ") + (write *recursive-compilation-number*) + (newline) + (pp scode (current-output-port) #t 4) + (newline) + (newline) + (newline) + (for-each + (lambda (instruction) + (cond ((and (pair? instruction) + (eq? (car instruction) 'LABEL)) + (write (cadr instruction)) + (write-char #\:)) + ((and (pair? instruction) + (eq? (car instruction) 'COMMENT)) + (write-char #\tab) + (write-string ";;") + (for-each (lambda (frob) + (write-string " ") + (write (if (and (pair? frob) + (eq? (car frob) 'RTL)) + (cadr frob) + frob))) + (cdr instruction))) + (else + (write-char #\tab) + (write instruction))) + (newline)) + *lap*) + (if (not (zero? *recursive-compilation-number*)) + (begin + (write-char #\page) + (newline))) + (output-port/flush-output port)))))) diff --git a/src/compiler/machines/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index c66063afe..960696e2f 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -117,25 +117,24 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons param:printer-radix 16)) - (lambda () - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction comment) - (disassembler/write-instruction - symbol-table - offset - (lambda () - (if comment - (let ((s - (call-with-output-string - (lambda (port) - (display instruction port))))) - (if (< (string-length s) 40) - (write-string (string-pad-right s 40)) - (write-string s)) - (write-string "; ") - (display comment)) - (write instruction))))))))) + (parameterize ((param:printer-radix 16)) + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction comment) + (disassembler/write-instruction + symbol-table + offset + (lambda () + (if comment + (let ((s + (call-with-output-string + (lambda (port) + (display instruction port))))) + (if (< (string-length s) 40) + (write-string (string-pad-right s 40)) + (write-string s)) + (write-string "; ") + (display comment)) + (write instruction)))))))) (define (disassembler/for-each-instruction instruction-stream procedure) (let loop ((instruction-stream instruction-stream)) @@ -146,31 +145,30 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons param:printer-radix 16)) - (lambda () - (let ((end (system-vector-length block))) - (let loop ((index (compiled-code-block/marked-start block))) - (cond ((not (< index end)) 'DONE) - ((object-type? - (let-syntax ((ucode-type - (sc-macro-transformer - (lambda (form environment) - environment - (apply microcode-type (cdr form)))))) - (ucode-type linkage-section)) - (system-vector-ref block index)) - (loop (disassembler/write-linkage-section block - symbol-table - index))) - (else - (disassembler/write-instruction - symbol-table - (compiled-code-block/index->offset index) - (lambda () - (write-constant block - symbol-table - (system-vector-ref block index)))) - (loop (1+ index))))))))) + (parameterize ((param:printer-radix 16)) + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/marked-start block))) + (cond ((not (< index end)) 'DONE) + ((object-type? + (let-syntax ((ucode-type + (sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form)))))) + (ucode-type linkage-section)) + (system-vector-ref block index)) + (loop (disassembler/write-linkage-section block + symbol-table + index))) + (else + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) (define (write-constant block symbol-table constant) (write-string (cdr (write-to-string constant 60))) diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index 48491973f..0c1f62a50 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -110,14 +110,13 @@ USA. (make-cursor block start symbol-table))) (define (write-instructions cursor) - (parameterize* (list (cons param:printer-radix 16)) - (lambda () - (let ((end (compiled-code-block/code-end (cursor-block cursor)))) - (let loop () - (if (< (cursor-offset cursor) end) - (begin - (write-instruction cursor) - (loop)))))))) + (parameterize ((param:printer-radix 16)) + (let ((end (compiled-code-block/code-end (cursor-block cursor)))) + (let loop () + (if (< (cursor-offset cursor) end) + (begin + (write-instruction cursor) + (loop))))))) (define (write-instruction cursor) (write-offset cursor) @@ -219,28 +218,27 @@ USA. #t))))) (define (write-constants cursor) - (parameterize* (list (cons param:printer-radix 16)) - (lambda () - (let* ((block (cursor-block cursor)) - (end (compiled-code-block/index->offset - (system-vector-length block)))) - - (assert (= (cursor-offset cursor) - (* (1+ (compiled-code-block/marked-start block)) - address-units-per-object))) - (let loop () - (let ((offset (cursor-offset cursor))) - (if (< offset end) - (let ((object (system-vector-ref - block (compiled-code-block/offset->index offset)))) - (if (object-type? (ucode-type linkage-section) object) - (write-linkage-section object cursor) - (begin - (write-offset cursor) - (write-constant object cursor) - (set-cursor-offset! cursor - (+ offset address-units-per-object)))) - (loop))))))))) + (parameterize ((param:printer-radix 16)) + (let* ((block (cursor-block cursor)) + (end (compiled-code-block/index->offset + (system-vector-length block)))) + + (assert (= (cursor-offset cursor) + (* (1+ (compiled-code-block/marked-start block)) + address-units-per-object))) + (let loop () + (let ((offset (cursor-offset cursor))) + (if (< offset end) + (let ((object (system-vector-ref + block (compiled-code-block/offset->index offset)))) + (if (object-type? (ucode-type linkage-section) object) + (write-linkage-section object cursor) + (begin + (write-offset cursor) + (write-constant object cursor) + (set-cursor-offset! cursor + (+ offset address-units-per-object)))) + (loop)))))))) (define (write-constant constant cursor) (write-string (cdr (write-to-string constant 60))) diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index ad93ad646..034951b16 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -117,25 +117,24 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (parameterize* (list (cons param:printer-radix 16)) - (lambda () - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction comment) - (disassembler/write-instruction - symbol-table - offset - (lambda () - (if comment - (let ((s - (call-with-output-string - (lambda (port) - (display instruction port))))) - (if (< (string-length s) 40) - (write-string (string-pad-right s 40)) - (write-string s)) - (write-string "; ") - (display comment)) - (write instruction))))))))) + (parameterize ((param:printer-radix 16)) + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction comment) + (disassembler/write-instruction + symbol-table + offset + (lambda () + (if comment + (let ((s + (call-with-output-string + (lambda (port) + (display instruction port))))) + (if (< (string-length s) 40) + (write-string (string-pad-right s 40)) + (write-string s)) + (write-string "; ") + (display comment)) + (write instruction)))))))) (define (disassembler/for-each-instruction instruction-stream procedure) (let loop ((instruction-stream instruction-stream)) @@ -146,31 +145,30 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (parameterize* (list (cons param:printer-radix 16)) - (lambda () - (let ((end (system-vector-length block))) - (let loop ((index (compiled-code-block/marked-start block))) - (cond ((not (< index end)) 'DONE) - ((object-type? - (let-syntax ((ucode-type - (sc-macro-transformer - (lambda (form environment) - environment - (apply microcode-type (cdr form)))))) - (ucode-type linkage-section)) - (system-vector-ref block index)) - (loop (disassembler/write-linkage-section block - symbol-table - index))) - (else - (disassembler/write-instruction - symbol-table - (compiled-code-block/index->offset index) - (lambda () - (write-constant block - symbol-table - (system-vector-ref block index)))) - (loop (1+ index))))))))) + (parameterize ((param:printer-radix 16)) + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/marked-start block))) + (cond ((not (< index end)) 'DONE) + ((object-type? + (let-syntax ((ucode-type + (sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form)))))) + (ucode-type linkage-section)) + (system-vector-ref block index)) + (loop (disassembler/write-linkage-section block + symbol-table + index))) + (else + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) (define (write-constant block symbol-table constant) (write-string (cdr (write-to-string constant 60))) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index b6673c61c..dac2020c6 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -681,9 +681,8 @@ Move to the last subproblem if the subproblem number is too high." (if (or argument (invalid-subexpression? sub)) (pp exp) - (parameterize* (list (cons param:pp-no-highlights? - #f)) - do-hairy))) + (parameterize ((param:pp-no-highlights? #f)) + (do-hairy)))) ((debugging-info/noise? exp) (message ((debugging-info/noise exp) #t))) (else @@ -1014,20 +1013,19 @@ Prefix argument means do not kill the debugger buffer." port)))) (define (print-with-subexpression expression subexpression) - (parameterize* (list (cons param:print-primitives-by-name? #t)) - (lambda () - (if (invalid-subexpression? subexpression) - (write (unsyntax expression)) - (let ((sub (write-to-string (unsyntax subexpression)))) - (write (unsyntax-with-substitutions - expression - (list - (cons subexpression - (unparser-literal/make - (string-append - (ref-variable subexpression-start-marker) - sub - (ref-variable subexpression-end-marker)))))))))))) + (parameterize ((param:print-primitives-by-name? #t)) + (if (invalid-subexpression? subexpression) + (write (unsyntax expression)) + (let ((sub (write-to-string (unsyntax subexpression)))) + (write (unsyntax-with-substitutions + expression + (list + (cons subexpression + (unparser-literal/make + (string-append + (ref-variable subexpression-start-marker) + sub + (ref-variable subexpression-end-marker))))))))))) (define (invalid-subexpression? subexpression) (or (debugging-info/undefined-expression? subexpression) @@ -1044,11 +1042,10 @@ Prefix argument means do not kill the debugger buffer." port)) (define (print-reduction-as-subexpression expression) - (parameterize* (list (cons param:print-primitives-by-name? #t)) - (lambda () - (write-string (ref-variable subexpression-start-marker)) - (write (unsyntax expression)) - (write-string (ref-variable subexpression-end-marker))))) + (parameterize ((param:print-primitives-by-name? #t)) + (write-string (ref-variable subexpression-start-marker)) + (write (unsyntax expression)) + (write-string (ref-variable subexpression-end-marker)))) (define (print-history-level compiled? subproblem-number reduction-id expression-thunk environment port) @@ -1065,8 +1062,8 @@ Prefix argument means do not kill the debugger buffer." (cdr (call-with-truncated-output-string pad-width (lambda (port) - (parameterize* (list (cons current-output-port port)) - expression-thunk)))) + (parameterize ((current-output-port port)) + (expression-thunk))))) " ") pad-width #\-) diff --git a/src/edwin/autold.scm b/src/edwin/autold.scm index db1ad3ee5..d09c93ad3 100644 --- a/src/edwin/autold.scm +++ b/src/edwin/autold.scm @@ -206,12 +206,11 @@ Second arg is prefix arg when called interactively." (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (parameterize* - (list (cons param:suppress-loading-message? #t)) - (lambda () - ((message-wrapper #f "Loading " (car library)) - (lambda () - (load-library library))))))))) + (parameterize + ((param:suppress-loading-message? #t)) + ((message-wrapper #f "Loading " (car library)) + (lambda () + (load-library library)))))))) (load-library library)))))) (cond ((not (library-loaded? name)) (do-it)) @@ -236,6 +235,5 @@ Second arg PURIFY? means purify the file's contents after loading; (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (parameterize* (list (cons param:suppress-loading-message? #t)) - (lambda () - (load filename environment 'DEFAULT purify?)))))))) \ No newline at end of file + (parameterize ((param:suppress-loading-message? #t)) + (load filename environment 'DEFAULT purify?))))))) \ No newline at end of file diff --git a/src/edwin/bufcom.scm b/src/edwin/bufcom.scm index ec713fac2..60371c94d 100644 --- a/src/edwin/bufcom.scm +++ b/src/edwin/bufcom.scm @@ -274,8 +274,8 @@ When locked, the buffer's major mode may not be changed." (define (with-output-to-temporary-buffer name properties thunk) (call-with-output-to-temporary-buffer name properties (lambda (port) - (parameterize* (list (cons current-output-port port)) - thunk)))) + (parameterize ((current-output-port port)) + (thunk))))) (define (call-with-temporary-buffer name procedure) (let ((buffer)) diff --git a/src/edwin/bufinp.scm b/src/edwin/bufinp.scm index 65efb8661..237dcba82 100644 --- a/src/edwin/bufinp.scm +++ b/src/edwin/bufinp.scm @@ -31,17 +31,17 @@ USA. (define (with-input-from-mark mark thunk #!optional receiver) (let ((port (make-buffer-input-port mark (group-end mark)))) (let ((value - (parameterize* (list (cons current-input-port port)) - thunk))) + (parameterize ((current-input-port port)) + (thunk)))) (if (default-object? receiver) value (receiver value (input-port/mark port)))))) (define (with-input-from-region region thunk) - (parameterize* (list (cons current-input-port - (make-buffer-input-port (region-start region) - (region-end region)))) - thunk)) + (parameterize ((current-input-port + (make-buffer-input-port (region-start region) + (region-end region)))) + (thunk))) (define (call-with-input-mark mark procedure) (procedure (make-buffer-input-port mark (group-end mark)))) diff --git a/src/edwin/bufout.scm b/src/edwin/bufout.scm index c5e33ae01..2b7d9dfc6 100644 --- a/src/edwin/bufout.scm +++ b/src/edwin/bufout.scm @@ -32,8 +32,8 @@ USA. (define (with-output-to-mark mark thunk) (call-with-output-mark mark (lambda (port) - (parameterize* (list (cons current-output-port port)) - thunk)))) + (parameterize ((current-output-port port)) + (thunk))))) (define (call-with-output-mark mark procedure) (let ((port (mark->output-port mark))) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index 3f6e50fe4..dbb9a7907 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -49,26 +49,25 @@ USA. indentation port) (let ((start-mark #f) (end-mark #f)) - (parameterize* (list (cons param:pp-no-highlights? #f)) - (lambda () - (debugger-pp - (unsyntax-with-substitutions - expression - (list (cons subexpression - (make-pretty-printer-highlight - (unsyntax subexpression) - (lambda (port) - (set! start-mark - (mark-right-inserting-copy - (output-port->mark port))) - unspecific) - (lambda (port) - (set! end-mark - (mark-right-inserting-copy - (output-port->mark port))) - unspecific))))) - indentation - port))) + (parameterize ((param:pp-no-highlights? #f)) + (debugger-pp + (unsyntax-with-substitutions + expression + (list (cons subexpression + (make-pretty-printer-highlight + (unsyntax subexpression) + (lambda (port) + (set! start-mark + (mark-right-inserting-copy + (output-port->mark port))) + unspecific) + (lambda (port) + (set! end-mark + (mark-right-inserting-copy + (output-port->mark port))) + unspecific))))) + indentation + port)) (if (and start-mark end-mark) (highlight-region-excluding-indentation (make-region start-mark end-mark) @@ -702,13 +701,11 @@ USA. (max summary-minimum-columns (- columns indentation 4)) (lambda (port) - (parameterize* - (list (cons current-output-port port)) - (lambda () - ((bline-type/write-summary - (bline/type bline)) - bline - (current-output-port)))))))) + (parameterize ((current-output-port port)) + ((bline-type/write-summary + (bline/type bline)) + bline + (current-output-port))))))) (insert-string (cdr summary) mark) (if (car summary) (insert-string " ..." mark))) @@ -1292,13 +1289,11 @@ 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 param:print-primitives-by-name? - #t)) - (lambda () - (write - (unsyntax (if (invalid-subexpression? subexpression) - expression - subexpression)))))) + (parameterize ((param:print-primitives-by-name? #t)) + (write + (unsyntax (if (invalid-subexpression? subexpression) + expression + subexpression))))) ((debugging-info/noise? expression) (write-string ";" port) (write-string ((debugging-info/noise expression) #f) @@ -1384,9 +1379,8 @@ it has been renamed, it will not be deleted automatically.") (subproblem/number (reduction/subproblem reduction))) port))) (write-string " " port) - (parameterize* (list (cons param:print-primitives-by-name? #t)) - (lambda () - (write (unsyntax (reduction/expression reduction)) port))))) + (parameterize ((param:print-primitives-by-name? #t)) + (write (unsyntax (reduction/expression reduction)) port)))) (define (reduction/write-description bline port) (let ((reduction (bline/object bline))) diff --git a/src/edwin/editor.scm b/src/edwin/editor.scm index 691f82803..b1de7d0ef 100644 --- a/src/edwin/editor.scm +++ b/src/edwin/editor.scm @@ -71,19 +71,17 @@ USA. (lambda (root-continuation) (set! editor-thread-root-continuation root-continuation) - (parameterize* (list (cons notification-output-port - null-output-port)) - (lambda () - (do ((thunks (let ((thunks editor-initial-threads)) - (set! editor-initial-threads '()) - thunks) - (cdr thunks))) - ((null? thunks)) - (create-thread root-continuation - (car thunks) - (car thunks))) - (top-level-command-reader - edwin-initialization))))))) + (parameterize ((notification-output-port + null-output-port)) + (do ((thunks (let ((thunks editor-initial-threads)) + (set! editor-initial-threads '()) + thunks) + (cdr thunks))) + ((null? thunks)) + (create-thread root-continuation + (car thunks) + (car thunks))) + (top-level-command-reader edwin-initialization)))))) message) #f `((START-CHILD ,(editor-start-child-cmdl with-editor-ungrabbed)) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index dda1a90fb..70699fd91 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -233,10 +233,8 @@ The values are printed in the typein window." (call-with-transcript-buffer (lambda (buffer) (insert-string - (parameterize* - (list (cons param:print-with-maximum-readability? #t)) - (lambda () - (write-to-string expression))) + (parameterize ((param:print-with-maximum-readability? #t)) + (write-to-string expression)) (buffer-end buffer))))) (editor-eval buffer expression @@ -412,31 +410,28 @@ Set by Scheme evaluation code to update the mode line." (define (editor-eval buffer sexp environment) (let ((core (lambda () - (parameterize* (list (cons current-input-port dummy-i/o-port)) - (lambda () - (let ((value)) - (let ((output-string - (call-with-output-string - (lambda (port) - (parameterize* (list (cons current-output-port - port)) - (lambda () - (set! value - (eval-with-history sexp environment)) - unspecific)))))) - (let ((evaluation-output-receiver - (ref-variable evaluation-output-receiver buffer))) - (if evaluation-output-receiver - (evaluation-output-receiver value output-string) - (with-output-to-transcript-buffer - (lambda () - (write-string output-string) - (transcript-write - value - (and (ref-variable enable-transcript-buffer - buffer) - (transcript-buffer)))))))) - value)))))) + (parameterize ((current-input-port dummy-i/o-port)) + (let ((value)) + (let ((output-string + (call-with-output-string + (lambda (port) + (parameterize ((current-output-port port)) + (set! value + (eval-with-history sexp environment)) + unspecific))))) + (let ((evaluation-output-receiver + (ref-variable evaluation-output-receiver buffer))) + (if evaluation-output-receiver + (evaluation-output-receiver value output-string) + (with-output-to-transcript-buffer + (lambda () + (write-string output-string) + (transcript-write + value + (and (ref-variable enable-transcript-buffer + buffer) + (transcript-buffer)))))))) + value))))) (if (ref-variable enable-run-light? buffer) (let ((run-light (ref-variable-object run-light)) (outside) @@ -481,16 +476,15 @@ Set by Scheme evaluation code to update the mode line." (let ((output-port (mark->output-port (buffer-end buffer) buffer))) (fresh-line output-port) - (parameterize* (list (cons current-output-port output-port)) - thunk)))))) + (parameterize ((current-output-port output-port)) + (thunk))))))) (let ((value)) (let ((output (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port port)) - (lambda () - (set! value (thunk)) - unspecific)))))) + (parameterize ((current-output-port port)) + (set! value (thunk)) + unspecific))))) (if (and (not (string-null? output)) (not (ref-variable evaluation-output-receiver))) (string->temporary-buffer output "*Unsolicited-Output*" '()))) @@ -530,12 +524,11 @@ Set by Scheme evaluation code to update the mode line." (define (transcript-value-string value) (if (undefined-value? value) "" - (parameterize* (list (cons param:printer-list-depth-limit - (ref-variable transcript-list-depth-limit)) - (cons param:printer-list-breadth-limit - (ref-variable transcript-list-breadth-limit))) - (lambda () - (write-to-string value))))) + (parameterize ((param:printer-list-depth-limit + (ref-variable transcript-list-depth-limit)) + (param:printer-list-breadth-limit + (ref-variable transcript-list-breadth-limit))) + (write-to-string value)))) (define (call-with-transcript-buffer procedure) (let ((buffer (transcript-buffer))) diff --git a/src/edwin/eystep.scm b/src/edwin/eystep.scm index 3e4b080c1..ccec92bf5 100644 --- a/src/edwin/eystep.scm +++ b/src/edwin/eystep.scm @@ -61,9 +61,8 @@ USA. (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (parameterize* (list (cons current-input-port dummy-i/o-port)) - (lambda () - (with-output-to-transcript-buffer thunk)))))) + (parameterize ((current-input-port dummy-i/o-port)) + (with-output-to-transcript-buffer thunk))))) ;;;; Stepper Mode diff --git a/src/edwin/filcom.scm b/src/edwin/filcom.scm index 19d742775..fb6c778b5 100644 --- a/src/edwin/filcom.scm +++ b/src/edwin/filcom.scm @@ -218,10 +218,8 @@ procedures are called." (lambda () (catch-file-errors (lambda (condition) condition #f) (lambda () - (parameterize* - (list (cons param:suppress-loading-message? #t)) - (lambda () - (load pathname '(EDWIN)))))))))))) + (parameterize ((param:suppress-loading-message? #t)) + (load pathname '(EDWIN))))))))))) (if (and (procedure? database) (procedure-arity-valid? database 1)) (database buffer) diff --git a/src/edwin/hlpcom.scm b/src/edwin/hlpcom.scm index 923406406..f4260e426 100644 --- a/src/edwin/hlpcom.scm +++ b/src/edwin/hlpcom.scm @@ -318,9 +318,8 @@ If you want VALUE to be a string, you must surround it with doublequotes." (define (with-output-to-help-display thunk) (string->temporary-buffer (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port - port)) - thunk))) + (parameterize ((current-output-port port)) + (thunk)))) "*Help*" '(READ-ONLY))) diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm index dc85f554a..b13526a73 100644 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@ -122,23 +122,22 @@ evaluated in the specified inferior REPL buffer." (detach-thread thread) thread)))) (attach-buffer-interface-port! buffer port) - (parameterize* (list (cons param:exit-hook inferior-repl/exit) - (cons param:suspend-hook inferior-repl/suspend)) - (lambda () - (dynamic-wind - (lambda () unspecific) - (lambda () - (repl/start (make-repl #f - port - environment - #f - `((ERROR-DECISION ,error-decision)) - user-initial-prompt) - (make-init-message message))) - (lambda () - (signal-thread-event editor-thread - (lambda () - (unwind-inferior-repl-buffer buffer))))))))) + (parameterize ((param:exit-hook inferior-repl/exit) + (param:suspend-hook inferior-repl/suspend)) + (dynamic-wind + (lambda () unspecific) + (lambda () + (repl/start (make-repl #f + port + environment + #f + `((ERROR-DECISION ,error-decision)) + user-initial-prompt) + (make-init-message message))) + (lambda () + (signal-thread-event editor-thread + (lambda () + (unwind-inferior-repl-buffer buffer)))))))) buffer)) (define (make-init-message message) @@ -732,10 +731,8 @@ If this is an error, the debugger examines the error condition." (lambda (mark) (if mark (insert-string - (parameterize* (list (cons param:print-with-maximum-readability? - #t)) - (lambda () - (write-to-string expression))) + (parameterize ((param:print-with-maximum-readability? #t)) + (write-to-string expression)) mark)))) (let ((port (buffer-interface-port buffer #t))) ;;(move-mark-to! (port/mark port) (buffer-end buffer)) diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index 89a40a66f..eea3539fe 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -979,10 +979,8 @@ it is added to the front of the command history." (set-prompt-history-strings! 'REPEAT-COMPLEX-COMMAND (map (lambda (command) - (parameterize* (list (cons param:print-with-maximum-readability? - #t)) - (lambda () - (write-to-string command)))) + (parameterize ((param:print-with-maximum-readability? #t)) + (write-to-string command))) (command-history-list))) (execute-command-history-entry (read-from-string diff --git a/src/edwin/schmod.scm b/src/edwin/schmod.scm index 3de918086..5dac4adcc 100644 --- a/src/edwin/schmod.scm +++ b/src/edwin/schmod.scm @@ -359,10 +359,8 @@ Otherwise, it is shown in the echo area." ((symbol? argl) (insert-string " . " point) (insert-string (symbol->string argl) point))))) - (parameterize* - (list (cons param:print-uninterned-symbols-by-name? #t)) - (lambda () - (message procedure-name ": " argl))))) + (parameterize ((param:print-uninterned-symbols-by-name? #t)) + (message procedure-name ": " argl)))) (editor-error "Expression does not evaluate to a procedure: " (extract-string start end)))))))) diff --git a/src/edwin/winout.scm b/src/edwin/winout.scm index d525f8bf0..53d1f2979 100644 --- a/src/edwin/winout.scm +++ b/src/edwin/winout.scm @@ -33,8 +33,8 @@ USA. (with-output-to-window-point (current-window) thunk)) (define (with-output-to-window-point window thunk) - (parameterize* (list (cons current-output-port (window-output-port window))) - thunk)) + (parameterize ((current-output-port (window-output-port window))) + (thunk))) (define (window-output-port window) (make-port window-output-port-type window)) diff --git a/src/ffi/build.scm b/src/ffi/build.scm index 4c51d4fc7..b30e635a9 100644 --- a/src/ffi/build.scm +++ b/src/ffi/build.scm @@ -365,9 +365,8 @@ USA. (if (not (option-loaded? name)) (let ((kernel (lambda () - (parameterize* (list (cons param:suppress-loading-message? #t)) - (lambda () - (load-option name)))))) + (parameterize ((param:suppress-loading-message? #t)) + (load-option name))))) (if (nearest-cmdl/batch-mode?) (kernel) (with-notification diff --git a/src/ffi/cdecls.scm b/src/ffi/cdecls.scm index a63342dd6..8dff0c062 100644 --- a/src/ffi/cdecls.scm +++ b/src/ffi/cdecls.scm @@ -91,9 +91,8 @@ USA. (lambda (inport) (let loop () (let ((form - (parameterize* (list (cons param:reader-fold-case? #f)) - (lambda () - (read inport))))) + (parameterize ((param:reader-fold-case? #f)) + (read inport)))) (if (not (eof-object? form)) (begin (include-cdecl form new-cwd twd includes) diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm index 21459b2bf..f9defe1a3 100644 --- a/src/imail/imail-util.scm +++ b/src/imail/imail-util.scm @@ -249,10 +249,9 @@ USA. (if (< n (expt 10 (- k 1))) (string-append (string-pad-left (number->string n) (- k 1)) " ") (let ((s - (parameterize* (list (cons param:flonum-printer-cutoff - `(RELATIVE ,k ENGINEERING))) - (lambda () - (number->string (exact->inexact n)))))) + (parameterize ((param:flonum-printer-cutoff + `(RELATIVE ,k ENGINEERING))) + (number->string (exact->inexact n))))) (let ((regs (re-string-match "\\([0-9.]+\\)e\\([0-9]+\\)" s))) (let ((mantissa (re-match-extract s regs 1)) (exponent (string->number (re-match-extract s regs 2)))) diff --git a/src/runtime/advice.scm b/src/runtime/advice.scm index e98758f4d..749542637 100644 --- a/src/runtime/advice.scm +++ b/src/runtime/advice.scm @@ -84,31 +84,30 @@ USA. (lambda (original-body state) (call-with-current-continuation (lambda (continuation) - (parameterize* (list (cons advice-continuation continuation)) - (lambda () - (with-restart 'use-value - "Return a value from the advised procedure." - continuation - (lambda () - (prompt-for-evaluated-expression "Procedure value")) + (parameterize ((advice-continuation continuation)) + (with-restart 'use-value + "Return a value from the advised procedure." + continuation (lambda () + (prompt-for-evaluated-expression "Procedure value")) + (lambda () + (for-each (lambda (advice) + (with-simple-restart 'continue + "Continue with advised procedure." + (lambda () + (advice procedure arguments environment)))) + (car state)) + (let ((value (scode-eval original-body environment))) (for-each (lambda (advice) (with-simple-restart 'continue - "Continue with advised procedure." + "Return from advised procedure." (lambda () - (advice procedure arguments environment)))) - (car state)) - (let ((value (scode-eval original-body environment))) - (for-each (lambda (advice) - (with-simple-restart 'continue - "Return from advised procedure." - (lambda () - (advice procedure - arguments - value - environment)))) - (cdr state)) - value))))))))))) + (advice procedure + arguments + value + environment)))) + (cdr state)) + value)))))))))) (define advice-continuation) @@ -316,17 +315,15 @@ USA. ;;;; Break (define (break-entry-advice procedure arguments environment) - (parameterize* (list (cons the-procedure procedure) - (cons the-arguments arguments)) - (lambda () - (break-rep environment "Breakpoint on entry" procedure arguments)))) + (parameterize ((the-procedure procedure) + (the-arguments arguments)) + (break-rep environment "Breakpoint on entry" procedure arguments))) (define (break-exit-advice procedure arguments result environment) - (parameterize* (list (cons the-procedure procedure) - (cons the-arguments arguments) - (cons the-result result)) - (lambda () - (break-rep environment "Breakpoint on exit" procedure arguments result))) + (parameterize ((the-procedure procedure) + (the-arguments arguments) + (the-result result)) + (break-rep environment "Breakpoint on exit" procedure arguments result)) result) (define (break-rep environment message . info) diff --git a/src/runtime/command-line.scm b/src/runtime/command-line.scm index 401cbd5c6..289f1a387 100644 --- a/src/runtime/command-line.scm +++ b/src/runtime/command-line.scm @@ -79,14 +79,13 @@ USA. (set! *command-line-arguments* '()) (let ((unused (or ((ucode-primitive get-unused-command-line 0)) '#()))) - (parameterize* (list (cons param:load-init-file? #t)) - (lambda () - (process-keyword (vector->list unused) '()) - (for-each (lambda (act) (act)) - (reverse after-parsing-actions)) - (if (and (param:load-init-file?) - (not (nearest-cmdl/batch-mode?))) - (load-init-file))))))) + (parameterize ((param:load-init-file? #t)) + (process-keyword (vector->list unused) '()) + (for-each (lambda (act) (act)) + (reverse after-parsing-actions)) + (if (and (param:load-init-file?) + (not (nearest-cmdl/batch-mode?))) + (load-init-file)))))) (define (find-keyword-parser keyword) (let ((entry (assoc (strip-leading-hyphens keyword) *command-line-parsers*))) @@ -258,10 +257,9 @@ ADDITIONAL OPTIONS supported by this band:\n") (lambda (arg) (run-in-nearest-repl (lambda (repl) - (parameterize* (list (cons param:suppress-loading-message? - (cmdl/batch-mode? repl))) - (lambda () - (load arg (repl/environment repl))))))) + (parameterize ((param:suppress-loading-message? + (cmdl/batch-mode? repl))) + (load arg (repl/environment repl)))))) "Loads the argument files as if in the REPL." "In batch mode, loading messages are suppressed.") diff --git a/src/runtime/dbgutl.scm b/src/runtime/dbgutl.scm index 5b950410c..54079cf22 100644 --- a/src/runtime/dbgutl.scm +++ b/src/runtime/dbgutl.scm @@ -90,8 +90,8 @@ USA. (let ((x (call-with-truncated-output-string length (lambda (port) - (parameterize* (list (cons current-output-port port)) - thunk))))) + (parameterize ((current-output-port port)) + (thunk)))))) (if (and (car x) (> length 4)) (string-append (string-slice (cdr x) 0 (- length 4)) " ...") diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index 864b901d2..b69f7063c 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -473,9 +473,8 @@ USA. (output-to-string 50 (lambda () - (parameterize* (list (cons param:print-primitives-by-name? #t)) - (lambda () - (write (unsyntax expression))))))) + (parameterize ((param:print-primitives-by-name? #t)) + (write (unsyntax expression)))))) ((debugging-info/noise? expression) (output-to-string 50 @@ -808,12 +807,11 @@ USA. (define *port*) (define (command/internal dstate port) - (parameterize* (list (cons *dstate* dstate) - (cons *port* port)) - (lambda () - (debug/read-eval-print (->environment '(runtime debugger)) - "the debugger" - "the debugger environment")))) + (parameterize ((*dstate* dstate) + (*port* port)) + (debug/read-eval-print (->environment '(runtime debugger)) + "the debugger" + "the debugger environment"))) (define-command (command/frame dstate port) (debugger-presentation port @@ -954,14 +952,11 @@ using the read-eval-print environment instead.") (string-titlecase (if reason (string-append reason "; " message) message))) (define (debugger-pp expression indentation port) - (parameterize* (list (cons param:printer-list-depth-limit - debugger:list-depth-limit) - (cons param:printer-list-breadth-limit - debugger:list-breadth-limit) - (cons param:printer-string-length-limit - debugger:string-length-limit)) - (lambda () - (pretty-print expression port true indentation)))) + (parameterize ((param:printer-list-depth-limit debugger:list-depth-limit) + (param:printer-list-breadth-limit debugger:list-breadth-limit) + (param:printer-string-length-limit + debugger:string-length-limit)) + (pretty-print expression port true indentation))) (define expression-indentation 4) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index d9deb1f19..cf4459f14 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -334,11 +334,10 @@ USA. (error:wrong-type-argument effector "effector" 'with-restart)) (if (not (or (not interactor) (procedure? interactor))) (error:wrong-type-argument interactor "interactor" 'with-restart)) - (parameterize* - (list (cons param:bound-restarts - (cons (%make-restart name reporter effector interactor) - (param:bound-restarts)))) - thunk)) + (parameterize ((param:bound-restarts + (cons (%make-restart name reporter effector interactor) + (param:bound-restarts)))) + (thunk))) (define (with-simple-restart name reporter thunk) (call-with-current-continuation @@ -514,10 +513,9 @@ USA. (define (bind-condition-handler types handler thunk) (guarantee-condition-types types 'bind-condition-handler) (guarantee-condition-handler handler 'bind-condition-handler) - (parameterize* - (list (cons dynamic-handler-frames - (cons (cons types handler) (dynamic-handler-frames)))) - thunk)) + (parameterize ((dynamic-handler-frames + (cons (cons types handler) (dynamic-handler-frames)))) + (thunk))) (define-integrable (guarantee-condition-handler object caller) (guarantee unary-procedure? object caller)) @@ -548,28 +546,25 @@ USA. (if (let ((types (break-on-signals-types))) (and (pair? types) (intersect-generalizations? types))) - (parameterize* (list (cons break-on-signals-types '())) - (lambda () - (breakpoint-procedure 'inherit - "BKPT entered because of BREAK-ON-SIGNALS:" - condition)))) + (parameterize ((break-on-signals-types '())) + (breakpoint-procedure 'inherit + "BKPT entered because of BREAK-ON-SIGNALS:" + condition))) (do ((frames (dynamic-handler-frames) (cdr frames))) ((not (pair? frames))) (if (let ((types (caar frames))) (or (not (pair? types)) (intersect-generalizations? types))) - (parameterize* (list (cons dynamic-handler-frames (cdr frames))) - (lambda () - (hook/invoke-condition-handler (cdar frames) condition))))) + (parameterize ((dynamic-handler-frames (cdr frames))) + (hook/invoke-condition-handler (cdar frames) condition)))) (do ((frames (static-handler-frames) (cdr frames))) ((not (pair? frames))) (if (let ((types (caar frames))) (or (not (pair? types)) (intersect-generalizations? types))) - (parameterize* (list (cons dynamic-handler-frames '()) - (cons static-handler-frames (cdr frames))) - (lambda () - (hook/invoke-condition-handler (cdar frames) condition))))) + (parameterize ((dynamic-handler-frames '()) + (static-handler-frames (cdr frames))) + (hook/invoke-condition-handler (cdar frames) condition)))) unspecific))) ;;;; Standard Condition Signallers @@ -604,9 +599,8 @@ USA. standard-error-hook))) (if hook (fluid-let ((standard-error-hook #!default)) - (parameterize* (list (cons param:standard-error-hook #f)) - (lambda () - (hook condition)))))) + (parameterize ((param:standard-error-hook #f)) + (hook condition))))) (repl/start (push-repl 'inherit condition '() "error>"))) (define (standard-warning-handler condition) @@ -616,9 +610,8 @@ USA. standard-warning-hook))) (if hook (fluid-let ((standard-warning-hook #!default)) - (parameterize* (list (cons param:standard-warning-hook #f)) - (lambda () - (hook condition)))) + (parameterize ((param:standard-warning-hook #f)) + (hook condition))) (let ((port (notification-output-port))) (fresh-line port) (write-string ";Warning: " port) @@ -1293,20 +1286,19 @@ USA. (else (error "Unexpected value:" v))))))) (define (format-error-message message irritants port) - (parameterize* (list (cons param:printer-list-depth-limit 2) - (cons param:printer-list-breadth-limit 5)) - (lambda () - (for-each (lambda (irritant) - (if (and (pair? irritant) - (eq? (car irritant) error-irritant/noise-tag)) - (display (cdr irritant) port) - (begin - (write-char #\space port) - (write irritant port)))) - (cons (if (string? message) - (error-irritant/noise message) - message) - irritants))))) + (parameterize ((param:printer-list-depth-limit 2) + (param:printer-list-breadth-limit 5)) + (for-each (lambda (irritant) + (if (and (pair? irritant) + (eq? (car irritant) error-irritant/noise-tag)) + (display (cdr irritant) port) + (begin + (write-char #\space port) + (write irritant port)))) + (cons (if (string? message) + (error-irritant/noise message) + message) + irritants)))) (define-integrable (error-irritant/noise noise) (cons error-irritant/noise-tag noise)) diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index 3f0fda933..3be4c1d32 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -621,9 +621,8 @@ USA. (if (not (option-loaded? name)) (let ((kernel (lambda () - (parameterize* (list (cons param:suppress-loading-message? #t)) - (lambda () - (load-option name)))))) + (parameterize ((param:suppress-loading-message? #t)) + (load-option name))))) (if (nearest-cmdl/batch-mode?) (kernel) (with-notification diff --git a/src/runtime/file-io.scm b/src/runtime/file-io.scm index 914409be4..cf3971689 100644 --- a/src/runtime/file-io.scm +++ b/src/runtime/file-io.scm @@ -229,8 +229,8 @@ USA. (define ((make-with-input-from-file call) input-specifier thunk) (call input-specifier (lambda (port) - (parameterize* (list (cons current-input-port port)) - thunk)))) + (parameterize ((current-input-port port)) + (thunk))))) (define with-input-from-file (make-with-input-from-file call-with-input-file)) @@ -241,8 +241,8 @@ USA. (define ((make-with-output-to-file call) output-specifier thunk) (call output-specifier (lambda (port) - (parameterize* (list (cons current-output-port port)) - thunk)))) + (parameterize ((current-output-port port)) + (thunk))))) (define with-output-to-file (make-with-output-to-file call-with-output-file)) diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm index bfeaef6e4..e1ef3daab 100644 --- a/src/runtime/framex.scm +++ b/src/runtime/framex.scm @@ -186,9 +186,8 @@ USA. (define ((hardware-trap-noise frame) long?) (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port port)) - (lambda () - (hardware-trap-frame/describe frame long?)))))) + (parameterize ((current-output-port port)) + (hardware-trap-frame/describe frame long?))))) (define (method/compiled-code frame) (let ((get-environment diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 666e2d4b6..b4129cd89 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -218,12 +218,11 @@ USA. (make-settable-parameter '())) (define (with-directory-rewriting-rule match replace thunk) - (parameterize* - (list (cons directory-rewriting-rules - (cons (cons (pathname-as-directory (merge-pathnames match)) - replace) - (directory-rewriting-rules)))) - thunk)) + (parameterize ((directory-rewriting-rules + (cons (cons (pathname-as-directory (merge-pathnames match)) + replace) + (directory-rewriting-rules)))) + (thunk))) (define (add-directory-rewriting-rule! match replace) (let ((match (pathname-as-directory (merge-pathnames match)))) diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 622895fd4..a9ed8a812 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -155,10 +155,9 @@ USA. (define (wrap-loader pathname loader) (lambda (environment purify?) (lambda () - (parameterize* (list (cons current-load-pathname pathname) - (cons current-load-environment environment)) - (lambda () - (loader environment purify?)))))) + (parameterize ((current-load-pathname pathname) + (current-load-environment environment)) + (loader environment purify?))))) (define (fasload pathname #!optional suppress-notifications?) (receive (pathname* loader notifier) (choose-fasload-method pathname) @@ -261,11 +260,10 @@ USA. suppress-notifications?) #f (param:write-notifications?)))) - (parameterize* (list (cons param:write-notifications? notify?)) - (lambda () - (if notify? - (notifier loader) - (loader)))))) + (parameterize ((param:write-notifications? notify?)) + (if notify? + (notifier loader) + (loader))))) (define (loading-notifier pathname) (lambda (thunk) @@ -289,11 +287,10 @@ USA. (define (handle-load-hooks thunk) (receive (result hooks) (fluid-let ((load/loading? #t)) ;backwards compatibility - (parameterize* (list (cons param:loading? #t) - (cons param:after-load-hooks '())) - (lambda () - (let ((result (thunk))) - (values result (reverse (param:after-load-hooks))))))) + (parameterize ((param:loading? #t) + (param:after-load-hooks '())) + (let ((result (thunk))) + (values result (reverse (param:after-load-hooks)))))) (for-each (lambda (hook) (hook)) hooks) result)) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index c96542ee9..a970b7733 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -440,9 +440,8 @@ USA. (apply scons-begin (read-files filenames #t))))))) (define (read-files filenames fold-case?) - (parameterize* (list (cons param:reader-fold-case? fold-case?)) - (lambda () - (append-map read-file filenames)))) + (parameterize ((param:reader-fold-case? fold-case?)) + (append-map read-file filenames))) (define $define-values (spar-transformer->runtime diff --git a/src/runtime/ntdir.scm b/src/runtime/ntdir.scm index 50dfa8b6e..109125628 100644 --- a/src/runtime/ntdir.scm +++ b/src/runtime/ntdir.scm @@ -58,9 +58,8 @@ USA. (lambda (pathname) (merge-pathnames pathname directory-path))) (let ((fnames (generate-directory-pathnames pattern))) - (parameterize* (list (cons *expand-directory-prefixes?* #f)) - (lambda () - (map ->pathname fnames))))))) + (parameterize ((*expand-directory-prefixes?* #f)) + (map ->pathname fnames)))))) (define (generate-directory-pathnames pathname) (let ((channel (directory-channel-open (->namestring pathname)))) @@ -79,10 +78,9 @@ USA. (cons (merge-pathnames (car entry) directory-path) (cdr entry)))) (let ((entries (generate-directory-entries pattern))) - (parameterize* (list (cons *expand-directory-prefixes?* #f)) - (lambda () - (map (lambda (entry) (cons (->pathname (car entry)) (cdr entry))) - entries))))))) + (parameterize ((*expand-directory-prefixes?* #f)) + (map (lambda (entry) (cons (->pathname (car entry)) (cdr entry))) + entries)))))) (define (generate-directory-entries pathname) (let ((channel (directory-channel-open (->namestring pathname)))) diff --git a/src/runtime/option.scm b/src/runtime/option.scm index 1ed605308..981e4a2b8 100644 --- a/src/runtime/option.scm +++ b/src/runtime/option.scm @@ -46,12 +46,11 @@ USA. (define (search-parent pathname) (call-with-values (lambda () - (parameterize* (list (cons *options* '()) - (cons *parent* #f) - (cons param:suppress-loading-message? #t)) - (lambda () - (load pathname (simple-top-level-environment #t)) - (values (*options*) (*parent*))))) + (parameterize ((*options* '()) + (*parent* #f) + (param:suppress-loading-message? #t)) + (load pathname (simple-top-level-environment #t)) + (values (*options*) (*parent*)))) find-option)) (if (memq name loaded-options) diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 8b9780848..8dda0635d 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -303,28 +303,27 @@ USA. 0))) (define (pp-top-level expression port as-code? indentation list-depth) - (parameterize* (list (cons x-size - (- (or (get-param:pp-forced-x-size) - (output-port/x-size port)) - 1)) - (cons output-port port) - (cons param:print-uninterned-symbols-by-name? - (get-param:pp-uninterned-symbols-by-name?)) - (cons param:printer-abbreviate-quotations? - (or as-code? - (param:printer-abbreviate-quotations?)))) - (lambda () - (let* ((numerical-walk - (if (get-param:pp-avoid-circularity?) - numerical-walk-avoid-circularities - numerical-walk)) - (node (numerical-walk expression list-depth))) - (if (positive? indentation) - (*print-string (make-string indentation #\space))) - (if as-code? - (print-node node indentation list-depth) - (print-non-code-node node indentation list-depth)) - (output-port/discretionary-flush port))))) + (parameterize ((x-size + (- (or (get-param:pp-forced-x-size) + (output-port/x-size port)) + 1)) + (output-port port) + (param:print-uninterned-symbols-by-name? + (get-param:pp-uninterned-symbols-by-name?)) + (param:printer-abbreviate-quotations? + (or as-code? + (param:printer-abbreviate-quotations?)))) + (let* ((numerical-walk + (if (get-param:pp-avoid-circularity?) + numerical-walk-avoid-circularities + numerical-walk)) + (node (numerical-walk expression list-depth))) + (if (positive? indentation) + (*print-string (make-string indentation #\space))) + (if as-code? + (print-node node indentation list-depth) + (print-non-code-node node indentation list-depth)) + (output-port/discretionary-flush port)))) (define x-size) (define output-port) @@ -348,19 +347,17 @@ USA. (*print-char #\newline)) (define (print-non-code-node node column depth) - (parameterize* (list (cons dispatch-list '()) - (cons dispatch-default - (if (get-param:pp-lists-as-tables?) - print-data-table - print-data-column))) - (lambda () - (print-node node column depth)))) + (parameterize ((dispatch-list '()) + (dispatch-default + (if (get-param:pp-lists-as-tables?) + print-data-table + print-data-column))) + (print-node node column depth))) (define (print-code-node node column depth) - (parameterize* (list (cons dispatch-list (code-dispatch-list)) - (cons dispatch-default print-combination)) - (lambda () - (print-node node column depth)))) + (parameterize ((dispatch-list (code-dispatch-list)) + (dispatch-default print-combination)) + (print-node node column depth))) (define (print-data-column nodes column depth) (*print-open) @@ -840,20 +837,19 @@ USA. (define (walk-highlighted-object object list-depth numerical-walk) (let ((dl (pph/depth-limit object))) - (parameterize* (list (cons param:printer-list-breadth-limit - (let ((bl (pph/breadth-limit object))) - (if (eq? bl 'default) - (param:printer-list-breadth-limit) - bl))) - (cons param:printer-list-depth-limit - (if (eq? dl 'default) - (param:printer-list-depth-limit) - dl))) - (lambda () - (numerical-walk (pph/object object) - (if (eq? dl 'default) - list-depth - 0)))))) + (parameterize ((param:printer-list-breadth-limit + (let ((bl (pph/breadth-limit object))) + (if (eq? bl 'default) + (param:printer-list-breadth-limit) + bl))) + (param:printer-list-depth-limit + (if (eq? dl 'default) + (param:printer-list-depth-limit) + dl))) + (numerical-walk (pph/object object) + (if (eq? dl 'default) + list-depth + 0))))) ;;; The following are circular list/vector handing procedures. They allow diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm index 3adea0c8c..476c7d8fa 100644 --- a/src/runtime/prgcop.scm +++ b/src/runtime/prgcop.scm @@ -83,14 +83,12 @@ USA. ;; do not have enough information to determine what the ;; variable name was. The original block can be used for ;; this, but it may as well be copied then. - (parameterize* (list (cons *copy-constants?* - (if (default-object? copy-constants?) - *default/copy-constants?* - copy-constants?)) - (cons *object-copies* - (make-object-association-table))) - (lambda () - (copy-object exp)))) + (parameterize ((*copy-constants?* + (if (default-object? copy-constants?) + *default/copy-constants?* + copy-constants?)) + (*object-copies* (make-object-association-table))) + (copy-object exp))) (define (copy-object obj) (let ((association (object-association obj))) diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm index 8e4dbd8f8..f2f5f8fc0 100644 --- a/src/runtime/printer.scm +++ b/src/runtime/printer.scm @@ -181,9 +181,8 @@ USA. (textual-port-char-set (context-port context))) (define (with-current-unparser-state context procedure) - (parameterize* (list (cons initial-context context)) - (lambda () - (procedure (context-port context))))) + (parameterize ((initial-context context)) + (procedure (context-port context)))) (define-deferred initial-context (make-unsettable-parameter #f)) @@ -319,9 +318,8 @@ USA. context))))) (define (call-print-method print-method object context) - (parameterize* (list (cons initial-context context)) - (lambda () - (print-method object (context-port context))))) + (parameterize ((initial-context context)) + (print-method object (context-port context)))) (define (get-print-method-parts object) (let ((print-method (get-print-method object))) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 019e306a3..b45f47f6e 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -120,40 +120,40 @@ USA. (pathname-defaults (param:default-pathname-defaults))) (let ((thunk (lambda () - (parameterize* - (list (cons current-input-port #f) - (cons current-output-port #f) - (cons notification-output-port #f) - (cons trace-output-port #f) - (cons interaction-i/o-port #f) - (cons working-directory-pathname - (working-directory-pathname)) - (cons param:nearest-cmdl cmdl) - (cons param:standard-error-hook #f) - (cons param:standard-warning-hook #f) - (cons param:standard-breakpoint-hook #f) - (cons param:default-pathname-defaults pathname-defaults) - (cons dynamic-handler-frames '()) - (cons param:bound-restarts - (if (cmdl/parent cmdl) (param:bound-restarts) '()))) - (lambda () - (fluid-let ((*default-pathname-defaults* pathname-defaults)) - (let loop ((message message)) - (loop - (bind-abort-restart cmdl - (lambda () - (with-interrupt-mask interrupt-mask/all - (lambda (interrupt-mask) - interrupt-mask - (unblock-thread-events) - (ignore-errors - (lambda () - ((->cmdl-message message) cmdl))) - (call-with-current-continuation - (lambda (continuation) - (with-create-thread-continuation continuation - (lambda () - ((cmdl/driver cmdl) cmdl)))))))))))))))) + (parameterize ((current-input-port #f) + (current-output-port #f) + (notification-output-port #f) + (trace-output-port #f) + (interaction-i/o-port #f) + (working-directory-pathname + (working-directory-pathname)) + (param:nearest-cmdl cmdl) + (param:standard-error-hook #f) + (param:standard-warning-hook #f) + (param:standard-breakpoint-hook #f) + (param:default-pathname-defaults pathname-defaults) + (dynamic-handler-frames '()) + (param:bound-restarts + (if (cmdl/parent cmdl) + (param:bound-restarts) + '()))) + (fluid-let ((*default-pathname-defaults* pathname-defaults)) + (let loop ((message message)) + (loop + (bind-abort-restart cmdl + (lambda () + (with-interrupt-mask interrupt-mask/all + (lambda (interrupt-mask) + interrupt-mask + (unblock-thread-events) + (ignore-errors + (lambda () + ((->cmdl-message message) cmdl))) + (call-with-current-continuation + (lambda (continuation) + (with-create-thread-continuation continuation + (lambda () + ((cmdl/driver cmdl) cmdl))))))))))))))) (mutex (textual-port-thread-mutex port))) (let ((thread (current-thread)) (owner (thread-mutex-owner mutex))) @@ -547,12 +547,10 @@ USA. (or message (and condition (cmdl-message/strings - (parameterize* - (list (cons param:printer-list-depth-limit 25) - (cons param:printer-list-breadth-limit 100) - (cons param:printer-string-length-limit 500)) - (lambda () - (condition/report-string condition)))))) + (parameterize ((param:printer-list-depth-limit 25) + (param:printer-list-breadth-limit 100) + (param:printer-string-length-limit 500)) + (condition/report-string condition))))) (and condition repl:allow-restart-notifications? (condition-restarts-message condition)) @@ -958,9 +956,8 @@ USA. standard-breakpoint-hook))) (if hook (fluid-let ((standard-breakpoint-hook #!default)) - (parameterize* (list (cons param:standard-breakpoint-hook #f)) - (lambda () - (hook condition)))))) + (parameterize ((param:standard-breakpoint-hook #f)) + (hook condition))))) (repl/start (push-repl (breakpoint/environment condition) condition '() diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm index 01bcd4ee4..4f9513175 100644 --- a/src/runtime/savres.scm +++ b/src/runtime/savres.scm @@ -83,9 +83,8 @@ USA. (lambda () (set! time-world-saved time) (set! time-world-restored (get-universal-time)) - (parameterize* (list (cons *within-restore-window?* #t)) - (lambda () - (event-distributor/invoke! event:after-restore))) + (parameterize ((*within-restore-window?* #t)) + (event-distributor/invoke! event:after-restore)) (start-thread-timer) (cond ((string? id) (set! world-id id) diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index 41a7fab79..ebe350bbe 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -180,10 +180,9 @@ (let ((stack-frame (continuation/first-subproblem continuation))) (if (eq? stack-frame-type/compiled-return-address (stack-frame/type stack-frame)) - (parameterize* - (list (cons stack-sampling-return-address - (stack-frame/return-address stack-frame))) - thunk) + (parameterize ((stack-sampling-return-address + (stack-frame/return-address stack-frame))) + (thunk)) (thunk))))))) ;;;; Profile Data @@ -397,11 +396,10 @@ (define (profile-pp expression output-port) ;; Random parametrization. - (parameterize* (list (cons param:printer-list-breadth-limit 5) - (cons param:printer-list-depth-limit 3) - (cons param:printer-string-length-limit 40) - (cons param:print-primitives-by-name? #t) - (cons param:pp-save-vertical-space? #t) - (cons param:pp-default-as-code? #t)) - (lambda () - (pp expression output-port)))) \ No newline at end of file + (parameterize ((param:printer-list-breadth-limit 5) + (param:printer-list-depth-limit 3) + (param:printer-string-length-limit 40) + (param:print-primitives-by-name? #t) + (param:pp-save-vertical-space? #t) + (param:pp-default-as-code? #t)) + (pp expression output-port))) \ No newline at end of file diff --git a/src/runtime/string-io.scm b/src/runtime/string-io.scm index 7425590d2..8d60fdfc1 100644 --- a/src/runtime/string-io.scm +++ b/src/runtime/string-io.scm @@ -33,8 +33,8 @@ USA. ;; obsolete (define (with-input-from-string string thunk) - (parameterize* (list (cons current-input-port (open-input-string string))) - thunk)) + (parameterize ((current-input-port (open-input-string string))) + (thunk))) (define (call-with-input-string string procedure) (procedure (open-input-string string))) @@ -139,15 +139,15 @@ USA. (define (with-output-to-string thunk) (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port port)) - thunk)))) + (parameterize ((current-output-port port)) + (thunk))))) ;; deprecated (define (with-output-to-truncated-string limit thunk) (call-with-truncated-output-string limit (lambda (port) - (parameterize* (list (cons current-output-port port)) - thunk)))) + (parameterize ((current-output-port port)) + (thunk))))) (define (open-output-string) (make-textual-port string-output-type (make-ostate (string-builder) 0))) diff --git a/src/runtime/structure-parser.scm b/src/runtime/structure-parser.scm index 245c6b47e..79d12ca15 100644 --- a/src/runtime/structure-parser.scm +++ b/src/runtime/structure-parser.scm @@ -82,10 +82,9 @@ USA. ;;;; Compiler (define (compile-top-level pattern caller-context env) - (parameterize* (list (cons name-counters (make-strong-eq-hash-table))) - (lambda () - (optimize-result - (compile-pattern pattern caller-context env))))) + (parameterize ((name-counters (make-strong-eq-hash-table))) + (optimize-result + (compile-pattern pattern caller-context env)))) (define (compile-pattern pattern caller-context env) (let ((pattern* (rewrite-pattern pattern))) diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index d1aea604a..48b2c7063 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -117,9 +117,8 @@ USA. (do () (#f) (with-simple-restart 'abort "Return to SLIME top-level." (lambda () - (parameterize* (list (cons *top-level-restart* (find-restart 'abort))) - (lambda () - (process-one-message socket 0))))))) + (parameterize ((*top-level-restart* (find-restart 'abort))) + (process-one-message socket 0)))))) (define *top-level-restart*) @@ -219,11 +218,10 @@ USA. (define *index*) (define (emacs-rex socket sexp pstring id) - (parameterize* (list (cons *buffer-pstring* pstring) - (cons *index* id)) - (lambda () - (eval (cons* (car sexp) socket (map quote-special (cdr sexp))) - swank-env)))) + (parameterize ((*buffer-pstring* pstring) + (*index* id)) + (eval (cons* (car sexp) socket (map quote-special (cdr sexp))) + swank-env))) (define *buffer-pstring*) @@ -306,7 +304,7 @@ USA. (let ((p (make-textual-port repl-port-type socket))) (dynamic-wind (lambda () unspecific) - (lambda () (parameterize* (list (cons current-output-port p)) thunk)) + (lambda () (parameterize ((current-output-port p)) (thunk))) (lambda () (flush-output-port p))))) (define repl-port-type) @@ -385,11 +383,10 @@ USA. socket (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port port)) - (lambda () - ((environment-lookup #f 'compiler:disassemble) - (eval (read-from-string string) - (buffer-env)))))))) + (parameterize ((current-output-port port)) + ((environment-lookup #f 'compiler:disassemble) + (eval (read-from-string string) + (buffer-env))))))) ;;;; Directory Functions (define (swank:default-directory socket) @@ -496,11 +493,10 @@ USA. (lambda () (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port port)) - (lambda () - (carefully-pa - (eval (read-from-string name) - (pstring->env pstring))))))))))) + (parameterize ((current-output-port port)) + (carefully-pa + (eval (read-from-string name) + (pstring->env pstring)))))))))) (if (condition? v) 'nil v))) (define (carefully-pa o) @@ -552,9 +548,8 @@ USA. (string-trim (call-with-output-string (lambda (port) - (parameterize* - (list (cons current-output-port port)) - (lambda () (pa binding)))))))) + (parameterize ((current-output-port port)) + (pa binding))))))) #f)) (let ((extra (assq symbol swank-extra-documentation))) (if extra @@ -669,18 +664,16 @@ swank:xref (define *sldb-state*) (define (invoke-sldb socket level condition) - (parameterize* - (list (cons *sldb-state* - (make-sldb-state condition (bound-restarts-for-emacs)))) - (lambda () - (dynamic-wind - (lambda () #f) - (lambda () - (write-message `(:debug 0 ,level ,@(sldb-info (*sldb-state*) 0 20)) - socket) - (sldb-loop level socket)) - (lambda () - (write-message `(:debug-return 0 ,(- level 1) 'nil) socket)))))) + (parameterize ((*sldb-state* + (make-sldb-state condition (bound-restarts-for-emacs)))) + (dynamic-wind + (lambda () #f) + (lambda () + (write-message `(:debug 0 ,level ,@(sldb-info (*sldb-state*) 0 20)) + socket) + (sldb-loop level socket)) + (lambda () + (write-message `(:debug-return 0 ,(- level 1) 'nil) socket))))) (define (sldb-loop level socket) (write-message `(:debug-activate 0 ,level) socket) @@ -772,15 +765,14 @@ swank:xref (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (parameterize* (list (cons param:print-primitives-by-name? #t)) - (lambda () - (write - (unsyntax - (if (or (debugging-info/undefined-expression? subexpression) - (debugging-info/unknown-expression? subexpression)) - expression - subexpression)) - port)))) + (parameterize ((param:print-primitives-by-name? #t)) + (write + (unsyntax + (if (or (debugging-info/undefined-expression? subexpression) + (debugging-info/unknown-expression? subexpression)) + expression + subexpression)) + port))) ((debugging-info/noise? expression) (write-string ";" port) (write-string ((debugging-info/noise expression) #f) @@ -1078,10 +1070,9 @@ swank:xref (stream (iline "block" (compiled-entry/block o)) (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port port)) - (lambda () - ((environment-lookup #f 'compiler:disassemble) - o))))))))) + (parameterize ((current-output-port port)) + ((environment-lookup #f 'compiler:disassemble) + o)))))))) (define (inspect-code-block block) (let loop ((i (compiled-code-block/constants-start block))) @@ -1092,10 +1083,9 @@ swank:xref (iline "env" (compiled-code-block/environment block)) (call-with-output-string (lambda (port) - (parameterize* (list (cons current-output-port port)) - (lambda () - ((environment-lookup #f 'compiler:disassemble) - block))))))))) + (parameterize ((current-output-port port)) + ((environment-lookup #f 'compiler:disassemble) + block)))))))) (define (inspect-scode o) (stream (pprint-to-string o))) @@ -1131,11 +1121,10 @@ swank:xref (define (pprint-to-string o) (call-with-output-string (lambda (p) - (parameterize* (list (cons param:printer-list-breadth-limit 10) - (cons param:printer-list-depth-limit 4) - (cons param:printer-string-length-limit 100)) - (lambda () - (pp o p)))))) + (parameterize ((param:printer-list-breadth-limit 10) + (param:printer-list-depth-limit 4) + (param:printer-string-length-limit 100)) + (pp o p))))) ;; quote keywords, t and nil (define (quote-special x) diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm index 81ce7c41b..752b806e5 100644 --- a/src/runtime/syntax-rename.scm +++ b/src/runtime/syntax-rename.scm @@ -52,8 +52,8 @@ USA. ((rdb:identifier-renamer (rename-db)) new-identifier)) (define (with-identifier-renaming thunk) - (parameterize* (list (cons rename-db (initial-rename-db))) - (lambda () (post-process-output (thunk))))) + (parameterize ((rename-db (initial-rename-db))) + (post-process-output (thunk)))) (define-deferred rename-db (make-unsettable-parameter 'unbound)) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 31c2ecb4c..0dbaae971 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -316,8 +316,8 @@ USA. (make-unsettable-parameter unspecific)) (define (with-error-context form senv hist thunk) - (parameterize* (list (cons error-context (serror-ctx form senv hist))) - thunk)) + (parameterize ((error-context (serror-ctx form senv hist))) + (thunk))) ;;; External signaller for macros. (define (syntax-error message . irritants) diff --git a/src/runtime/textual-port.scm b/src/runtime/textual-port.scm index 33007cd4a..40977077d 100644 --- a/src/runtime/textual-port.scm +++ b/src/runtime/textual-port.scm @@ -788,33 +788,33 @@ USA. (current-input-port port)) (define (with-input-from-port port thunk) - (parameterize* (list (cons current-input-port port)) - thunk)) + (parameterize ((current-input-port port)) + (thunk))) (define (set-current-output-port! port) (current-output-port port)) (define (with-output-to-port port thunk) - (parameterize* (list (cons current-output-port port)) - thunk)) + (parameterize ((current-output-port port)) + (thunk))) (define (set-notification-output-port! port) (notification-output-port port)) (define (with-notification-output-port port thunk) - (parameterize* (list (cons notification-output-port port)) - thunk)) + (parameterize ((notification-output-port port)) + (thunk))) (define (set-trace-output-port! port) (trace-output-port port)) (define (with-trace-output-port port thunk) - (parameterize* (list (cons trace-output-port port)) - thunk)) + (parameterize ((trace-output-port port)) + (thunk))) (define (set-interaction-i/o-port! port) (interaction-i/o-port port)) (define (with-interaction-i/o-port port thunk) - (parameterize* (list (cons interaction-i/o-port port)) - thunk)) \ No newline at end of file + (parameterize ((interaction-i/o-port port)) + (thunk))) \ No newline at end of file diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 9c097fb61..19c163e24 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -259,8 +259,8 @@ USA. (error:wrong-type-argument continuation "continuation" with-create-thread-continuation)) - (parameterize* (list (cons root-continuation-default continuation)) - thunk)) + (parameterize ((root-continuation-default continuation)) + (thunk))) (define (current-thread) (or first-running-thread diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index b9ac5e294..b535b53ff 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -45,9 +45,8 @@ USA. (define (unsyntax-with-substitutions scode alist) (if (not (alist? alist)) (error:wrong-type-argument alist "alist" 'unsyntax-with-substitutions)) - (parameterize* (list (cons substitutions alist)) - (lambda () - (unsyntax scode)))) + (parameterize ((substitutions alist)) + (unsyntax scode))) (define-integrable (maybe-substitute object thunk) (let ((association (has-substitution? object))) diff --git a/src/runtime/unxdir.scm b/src/runtime/unxdir.scm index d57c77c44..35cd00ee2 100644 --- a/src/runtime/unxdir.scm +++ b/src/runtime/unxdir.scm @@ -56,10 +56,8 @@ USA. (merge-pathnames pathname directory-path)) (let ((pathnames (let ((fnames (generate-directory-pathnames directory-path))) - (parameterize* - (list (cons *expand-directory-prefixes?* false)) - (lambda () - (map ->pathname fnames)))))) + (parameterize ((*expand-directory-prefixes?* false)) + (map ->pathname fnames))))) (if (and (eq? (pathname-name pattern) 'wild) (eq? (pathname-type pattern) 'wild)) pathnames diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index 9f568840a..a22c94e42 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -387,9 +387,9 @@ USA. unspecific)) (lambda () (let ((v - (parameterize* (list (cons *notification-depth* - (1+ (*notification-depth*)))) - thunk))) + (parameterize ((*notification-depth* + (1+ (*notification-depth*)))) + (thunk)))) (set! done? #t) v)) (lambda () diff --git a/src/runtime/world-report.scm b/src/runtime/world-report.scm index 33d1d4625..4e0c0d922 100644 --- a/src/runtime/world-report.scm +++ b/src/runtime/world-report.scm @@ -53,9 +53,8 @@ USA. (thread-report port))) (define (ticks->string ticks) - (parameterize* (list (cons param:flonum-printer-cutoff '(absolute 3))) - (lambda () - (number->string (internal-time/ticks->seconds ticks) 10)))) + (parameterize ((param:flonum-printer-cutoff '(absolute 3))) + (number->string (internal-time/ticks->seconds ticks) 10))) (define (write-time-interval secs port) (let ((min/sec (integer-divide secs 60))) diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm index 981ccd055..b64ba58f5 100644 --- a/src/runtime/wrkdir.scm +++ b/src/runtime/wrkdir.scm @@ -75,9 +75,9 @@ USA. (define (with-working-directory-pathname name thunk) (let ((pathname (new-pathname name))) (fluid-let ((*default-pathname-defaults* pathname)) - (parameterize* (list (cons param:default-pathname-defaults pathname) - (cons working-directory-pathname pathname)) - thunk)))) + (parameterize ((param:default-pathname-defaults pathname) + (working-directory-pathname pathname)) + (thunk))))) (define (new-pathname name) (pathname-simplify diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index 837266e49..60d0bf310 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -247,8 +247,7 @@ USA. ;;; Debugging utility (define (pp-expression form #!optional port) - (parameterize* (list (cons param:pp-primitives-by-name? #f) - (cons param:pp-uninterned-symbols-by-name? #f) - (cons param:printer-abbreviate-quotations? #t)) - (lambda () - (pp (cgen/external-with-declarations form) port)))) \ No newline at end of file + (parameterize ((param:pp-primitives-by-name? #f) + (param:pp-uninterned-symbols-by-name? #f) + (param:printer-abbreviate-quotations? #t)) + (pp (cgen/external-with-declarations form) port))) \ No newline at end of file diff --git a/src/sos/microbench.scm b/src/sos/microbench.scm index 4145492c4..9ae6a21d1 100644 --- a/src/sos/microbench.scm +++ b/src/sos/microbench.scm @@ -262,15 +262,13 @@ USA. (let ((f1-time (run-test f1-test))) (let ((report (lambda (name time scale) - (parameterize* (list - (cons param:flonum-printer-cutoff '(ABSOLUTE 2))) - (lambda () - (newline) - (write name) - (write-string "-test:\t") - (write (exact->inexact time)) - (write-string "\t") - (write (exact->inexact (/ (/ time scale) f1-time)))))))) + (parameterize ((param:flonum-printer-cutoff '(absolute 2))) + (newline) + (write name) + (write-string "-test:\t") + (write (exact->inexact time)) + (write-string "\t") + (write (exact->inexact (/ (/ time scale) f1-time))))))) (report 'f1 f1-time 1) (for-each (lambda (name test scale) (report name (run-test test) scale)) diff --git a/src/ssp/xhtml-expander.scm b/src/ssp/xhtml-expander.scm index 7453975ad..75b270853 100644 --- a/src/ssp/xhtml-expander.scm +++ b/src/ssp/xhtml-expander.scm @@ -76,14 +76,13 @@ USA. (let ((pathname (merge-pathnames pathname))) (with-working-directory-pathname (directory-pathname pathname) (lambda () - (parameterize* (list (cons current-load-pathname pathname) - (cons current-load-environment environment)) - (lambda () - (fluid-let ((*sabbr-table* (make-strong-eq-hash-table))) - (read-xml-file pathname - `((scheme ,(pi-expander environment)) - (svar ,svar-expander) - (sabbr ,sabbr-expander)))))))))) + (parameterize ((current-load-pathname pathname) + (current-load-environment environment)) + (fluid-let ((*sabbr-table* (make-strong-eq-hash-table))) + (read-xml-file pathname + `((scheme ,(pi-expander environment)) + (svar ,svar-expander) + (sabbr ,sabbr-expander))))))))) (define (make-expansion-environment pathname) (let ((environment (extend-top-level-environment expander-environment))) @@ -94,15 +93,14 @@ USA. (define ((pi-expander environment) text) (fluid-let ((*outputs* (cons '() '()))) - (parameterize* (list (cons param:suppress-loading-message? #t)) - (lambda () - (let ((port (open-input-string text))) - (let loop () - (let ((expression (read port))) - (if (not (eof-object? expression)) - (begin - (expander-eval expression environment) - (loop)))))))) + (parameterize ((param:suppress-loading-message? #t)) + (let ((port (open-input-string text))) + (let loop () + (let ((expression (read port))) + (if (not (eof-object? expression)) + (begin + (expander-eval expression environment) + (loop))))))) (car *outputs*))) (define expander-eval eval) diff --git a/src/ssp/xmlrpc.scm b/src/ssp/xmlrpc.scm index 8933be6d0..5039d4d28 100644 --- a/src/ssp/xmlrpc.scm +++ b/src/ssp/xmlrpc.scm @@ -63,7 +63,6 @@ USA. (environment-define environment 'define-xmlrpc-method (lambda (name handler) (hash-table-set! methods name handler))) - (parameterize* (list (cons param:suppress-loading-message? #t)) - (lambda () - (load pathname environment)))) + (parameterize ((param:suppress-loading-message? #t)) + (load pathname environment))) (hash-table-ref/default methods name #f))) \ No newline at end of file diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index f1ddc971c..79cc5c0ba 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -284,9 +284,8 @@ USA. (define (write-expr-property tag p port) (write-tag tag port) (write-char #\space port) - (parameterize* (list (cons param:printer-abbreviate-quotations? #t)) - (lambda () - (write (cdr p) port)))) + (parameterize ((param:printer-abbreviate-quotations? #t)) + (write (cdr p) port))) (define (write-feature tag p port) (write-tag tag port) -- 2.25.1