From: Matt Birkholz Date: Sun, 2 Feb 2014 21:39:38 +0000 (-0700) Subject: Fluidize *unparse...*, i.e. *unparser-table*, *unparser-radix*... X-Git-Tag: mit-scheme-pucked-9.2.12~401^2~27 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7a0ffdf13bdc0dff7ee4e06570f782158323fe26;p=mit-scheme.git Fluidize *unparse...*, i.e. *unparser-table*, *unparser-radix*... ... *unparse-abbreviate-quotations?*, *unparse-compound-procedure-names?*, *unparse-primitives-by-name?*, *unparse-uninterned-symbols-by-name?*, *unparse-with-datum?*, *unparse-with-maximum-readability?*, *unparser-list-breadth-limit*, *unparser-list-depth-limit*, and *unparser-string-length-limit*. --- diff --git a/doc/ref-manual/io.texi b/doc/ref-manual/io.texi index e2246174e..e36982518 100644 --- a/doc/ref-manual/io.texi +++ b/doc/ref-manual/io.texi @@ -882,74 +882,80 @@ The following variables may be dynamically bound to change the behavior of the @code{write} and @code{display} procedures. @defvr variable *unparser-radix* -This variable specifies the default radix used to print numbers. Its +This fluid specifies the default radix used to print numbers. Its value must be one of the exact integers @code{2}, @code{8}, @code{10}, or @code{16}; the default is @code{10}. If @code{*unparser-radix*} is not @code{10}, numbers are prefixed to indicate their radix. @end defvr @defvr variable *unparser-list-breadth-limit* -This variable specifies a limit on the length of the printed +This fluid specifies a limit on the length of the printed representation of a list or vector; for example, if the limit is @code{4}, only the first four elements of any list are printed, followed by ellipses to indicate any additional elements. The value of this -variable must be an exact non-negative integer, or @code{#f} meaning no +fluid must be an exact non-negative integer, or @code{#f} meaning no limit; the default is @code{#f}. @example @group -(fluid-let ((*unparser-list-breadth-limit* 4)) - (write-to-string '(a b c d))) +(let-fluid *unparser-list-breadth-limit* 4 + (lambda () + (write-to-string '(a b c d)))) @result{} "(a b c d)" -(fluid-let ((*unparser-list-breadth-limit* 4)) - (write-to-string '(a b c d e))) +(let-fluid *unparser-list-breadth-limit* 4 + (lambda () + (write-to-string '(a b c d e)))) @result{} "(a b c d ...)" @end group @end example @end defvr @defvr variable *unparser-list-depth-limit* -This variable specifies a limit on the nesting of lists and vectors in +This fluid specifies a limit on the nesting of lists and vectors in the printed representation. If lists (or vectors) are more deeply nested than the limit, the part of the representation that exceeds the -limit is replaced by ellipses. The value of this variable must be an +limit is replaced by ellipses. The value of this fluid must be an exact non-negative integer, or @code{#f} meaning no limit; the default is @code{#f}. @example @group -(fluid-let ((*unparser-list-depth-limit* 4)) - (write-to-string '((((a))) b c d))) +(let-fluid *unparser-list-depth-limit* 4 + (lambda () + (write-to-string '((((a))) b c d)))) @result{} "((((a))) b c d)" -(fluid-let ((*unparser-list-depth-limit* 4)) - (write-to-string '(((((a)))) b c d))) +(let-fluid *unparser-list-depth-limit* 4 + (lambda () + (write-to-string '(((((a)))) b c d)))) @result{} "((((...))) b c d)" @end group @end example @end defvr @defvr variable *unparser-string-length-limit* -This variable specifies a limit on the length of the printed +This fluid specifies a limit on the length of the printed representation of strings. If a string's length exceeds this limit, the part of the printed representation for the characters exceeding the -limit is replaced by ellipses. The value of this variable must be an +limit is replaced by ellipses. The value of this fluid must be an exact non-negative integer, or @code{#f} meaning no limit; the default is @code{#f}. @example @group -(fluid-let ((*unparser-string-length-limit* 4)) - (write-to-string "abcd")) +(let-fluid *unparser-string-length-limit* 4 + (lambda () + (write-to-string "abcd"))) @result{} "\"abcd\"" -(fluid-let ((*unparser-string-length-limit* 4)) - (write-to-string "abcde")) +(let-fluid *unparser-string-length-limit* 4 + (lambda () + (write-to-string "abcde"))) @result{} "\"abcd...\"" @end group @end example @end defvr @defvr variable *unparse-with-maximum-readability?* -This variable, which takes a boolean value, tells the printer to use a +This fluid, which takes a boolean value, tells the printer to use a special printed representation for objects that normally print in a form that cannot be recognized by @code{read}. These objects are printed using the representation @code{#@@@var{n}}, where @var{n} is the result diff --git a/src/6001/nodefs.scm b/src/6001/nodefs.scm index dbb4fcabf..04884beee 100644 --- a/src/6001/nodefs.scm +++ b/src/6001/nodefs.scm @@ -77,7 +77,8 @@ USA. (if (not (default-object? value)) (begin (write-string " --> " port) - (fluid-let ((*unparser-list-depth-limit* 2) - (*unparser-list-breadth-limit* 10) - (*unparser-string-length-limit* 30)) - (write value port))))))) \ No newline at end of file + (let-fluids *unparser-list-depth-limit* 2 + *unparser-list-breadth-limit* 10 + *unparser-string-length-limit* 30 + (lambda () + (write value port)))))))) diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm index 7a0e5ce47..114b8c8fa 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -104,17 +104,17 @@ USA. (newline)) (define (write-instructions thunk) - (fluid-let ((*show-instruction* write) - (*unparser-radix* 16) - (*unparse-uninterned-symbols-by-name?* #t)) - (thunk))) + (fluid-let ((*show-instruction* write)) + (let-fluids *unparser-radix* 16 + *unparse-uninterned-symbols-by-name?* #t + thunk))) (define (pp-instructions thunk) (fluid-let ((*show-instruction* pretty-print) - (*pp-primitives-by-name* #f) - (*unparser-radix* 16) - (*unparse-uninterned-symbols-by-name?* #t)) - (thunk))) + (*pp-primitives-by-name* #f)) + (let-fluids *unparser-radix* 16 + *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 7886cca6f..e5d5ed339 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -156,5 +156,6 @@ USA. (unparser/standard-method name)))) (define (tagged-vector/unparse state vector) - (fluid-let ((*unparser-radix* 16)) - ((tagged-vector/unparser vector) state vector))) \ No newline at end of file + (let-fluid *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 4c88a098b..c1a94708c 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -1055,41 +1055,42 @@ USA. (define (phase/lap-file-output scode port) (compiler-phase "LAP File Output" (lambda () - (fluid-let ((*unparser-radix* 16) - (*unparse-uninterned-symbols-by-name?* #t)) - (with-output-to-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))))))) \ No newline at end of file + (let-fluids *unparser-radix* 16 + *unparse-uninterned-symbols-by-name?* #t + (lambda () + (with-output-to-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)))))))) diff --git a/src/compiler/machines/alpha/dassm1.scm b/src/compiler/machines/alpha/dassm1.scm index ff8958cd9..3b5a5c9e8 100644 --- a/src/compiler/machines/alpha/dassm1.scm +++ b/src/compiler/machines/alpha/dassm1.scm @@ -131,12 +131,13 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (fluid-let ((*unparser-radix* 16)) - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction) - (disassembler/write-instruction symbol-table - offset - (lambda () (display instruction))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction symbol-table + offset + (lambda () (display instruction)))))))) (define (disassembler/for-each-instruction instruction-stream procedure) (let loop ((instruction-stream instruction-stream)) @@ -147,29 +148,30 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-radix* 16)) - (let ((end (system-vector-length block))) - (let loop ((index (compiled-code-block/constants-start block))) - (cond ((not (< index end)) 'DONE) - ((object-type? - ((sc-macro-transformer - (lambda (form environment) - environment - (apply microcode-type (cdr form)))) - 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)))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-start block))) + (cond ((not (< index end)) 'DONE) + ((object-type? + ((sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form)))) + 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/bobcat/dassm1.scm b/src/compiler/machines/bobcat/dassm1.scm index b12392d3e..5e1bbb5c9 100644 --- a/src/compiler/machines/bobcat/dassm1.scm +++ b/src/compiler/machines/bobcat/dassm1.scm @@ -117,12 +117,13 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (fluid-let ((*unparser-radix* 16)) - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction) - (disassembler/write-instruction symbol-table - offset - (lambda () (display instruction))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction symbol-table + offset + (lambda () (display instruction)))))))) (define (disassembler/for-each-instruction instruction-stream procedure) (let loop ((instruction-stream instruction-stream)) @@ -133,30 +134,31 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-radix* 16)) - (let ((end (system-vector-length block))) - (let loop ((index (compiled-code-block/constants-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)))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-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/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index c259fc388..1d4fee559 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -117,22 +117,23 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (fluid-let ((*unparser-radix* 16)) - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction comment) - (disassembler/write-instruction - symbol-table - offset - (lambda () - (if comment - (let ((s (with-output-to-string - (lambda () (display instruction))))) - (if (< (string-length s) 40) - (write-string (string-pad-right s 40)) - (write-string s)) - (write-string "; ") - (display comment)) - (write instruction)))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction comment) + (disassembler/write-instruction + symbol-table + offset + (lambda () + (if comment + (let ((s (with-output-to-string + (lambda () (display instruction))))) + (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)) @@ -143,30 +144,31 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-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)))))))) + (let-fluid *unparser-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))))))))) (define (write-constant block symbol-table constant) (write-string (cdr (write-to-string constant 60))) diff --git a/src/compiler/machines/mips/dassm1.scm b/src/compiler/machines/mips/dassm1.scm index b12392d3e..5e1bbb5c9 100644 --- a/src/compiler/machines/mips/dassm1.scm +++ b/src/compiler/machines/mips/dassm1.scm @@ -117,12 +117,13 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (fluid-let ((*unparser-radix* 16)) - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction) - (disassembler/write-instruction symbol-table - offset - (lambda () (display instruction))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction symbol-table + offset + (lambda () (display instruction)))))))) (define (disassembler/for-each-instruction instruction-stream procedure) (let loop ((instruction-stream instruction-stream)) @@ -133,30 +134,31 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-radix* 16)) - (let ((end (system-vector-length block))) - (let loop ((index (compiled-code-block/constants-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)))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-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/spectrum/dassm1.scm b/src/compiler/machines/spectrum/dassm1.scm index 72caaa052..e3a9647d3 100644 --- a/src/compiler/machines/spectrum/dassm1.scm +++ b/src/compiler/machines/spectrum/dassm1.scm @@ -117,12 +117,13 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (fluid-let ((*unparser-radix* 16)) - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction) - (disassembler/write-instruction symbol-table - offset - (lambda () (display instruction))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction symbol-table + offset + (lambda () (display instruction)))))))) (define (disassembler/for-each-instruction instruction-stream procedure) (let loop ((instruction-stream instruction-stream)) @@ -133,30 +134,31 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-radix* 16)) - (let ((end (system-vector-length block))) - (let loop ((index (compiled-code-block/constants-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)))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-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 30c37cbb7..c958b6600 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -110,13 +110,14 @@ USA. (make-cursor block start symbol-table))) (define (write-instructions cursor) - (fluid-let ((*unparser-radix* 16)) - (let ((end (compiled-code-block/code-end (cursor-block cursor)))) - (let loop () - (if (< (cursor-offset cursor) end) - (begin - (write-instruction cursor) - (loop))))))) + (let-fluid *unparser-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)))))))) (define (write-instruction cursor) (write-offset cursor) @@ -218,27 +219,28 @@ USA. #t))))) (define (write-constants cursor) - (fluid-let ((*unparser-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)))))))) + (let-fluid *unparser-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))))))))) (define (write-constant constant cursor) (write-string (cdr (write-to-string constant 60))) diff --git a/src/compiler/machines/vax/dassm1.scm b/src/compiler/machines/vax/dassm1.scm index d04f84a24..739c5f4d5 100644 --- a/src/compiler/machines/vax/dassm1.scm +++ b/src/compiler/machines/vax/dassm1.scm @@ -105,12 +105,13 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (fluid-let ((*unparser-radix* 16)) - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction) - (disassembler/write-instruction symbol-table - offset - (lambda () (display instruction))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction symbol-table + offset + (lambda () (display instruction)))))))) (define (disassembler/for-each-instruction instruction-stream procedure) (let loop ((instruction-stream instruction-stream)) @@ -121,30 +122,31 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-radix* 16)) - (let ((end (system-vector-length block))) - (let loop ((index (compiled-code-block/constants-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)))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-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/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index c259fc388..1d4fee559 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -117,22 +117,23 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (fluid-let ((*unparser-radix* 16)) - (disassembler/for-each-instruction instruction-stream - (lambda (offset instruction comment) - (disassembler/write-instruction - symbol-table - offset - (lambda () - (if comment - (let ((s (with-output-to-string - (lambda () (display instruction))))) - (if (< (string-length s) 40) - (write-string (string-pad-right s 40)) - (write-string s)) - (write-string "; ") - (display comment)) - (write instruction)))))))) + (let-fluid *unparser-radix* 16 + (lambda () + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction comment) + (disassembler/write-instruction + symbol-table + offset + (lambda () + (if comment + (let ((s (with-output-to-string + (lambda () (display instruction))))) + (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)) @@ -143,30 +144,31 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-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)))))))) + (let-fluid *unparser-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))))))))) (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 ff1a33b8d..d2ccb48f9 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -1013,19 +1013,20 @@ Prefix argument means do not kill the debugger buffer." port)))) (define (print-with-subexpression expression subexpression) - (fluid-let ((*unparse-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))))))))))) + (let-fluid *unparse-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)))))))))))) (define (invalid-subexpression? subexpression) (or (debugging-info/undefined-expression? subexpression) @@ -1042,10 +1043,11 @@ Prefix argument means do not kill the debugger buffer." port)) (define (print-reduction-as-subexpression expression) - (fluid-let ((*unparse-primitives-by-name?* #t)) - (write-string (ref-variable subexpression-start-marker)) - (write (unsyntax expression)) - (write-string (ref-variable subexpression-end-marker)))) + (let-fluid *unparse-primitives-by-name?* #t + (lambda () + (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) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index b5ef496d7..1dc72cd9a 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -1281,11 +1281,12 @@ 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)) - (fluid-let ((*unparse-primitives-by-name?* #t)) - (write - (unsyntax (if (invalid-subexpression? subexpression) - expression - subexpression))))) + (let-fluid *unparse-primitives-by-name?* #t + (lambda () + (write + (unsyntax (if (invalid-subexpression? subexpression) + expression + subexpression)))))) ((debugging-info/noise? expression) (write-string ";" port) (write-string ((debugging-info/noise expression) #f) @@ -1371,8 +1372,9 @@ it has been renamed, it will not be deleted automatically.") (subproblem/number (reduction/subproblem reduction))) port))) (write-string " " port) - (fluid-let ((*unparse-primitives-by-name?* #t)) - (write (unsyntax (reduction/expression reduction)) port)))) + (let-fluid *unparse-primitives-by-name?* #t + (lambda () + (write (unsyntax (reduction/expression reduction)) port))))) (define (reduction/write-description bline port) (let ((reduction (bline/object bline))) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index eae8320fe..9ea436e89 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -233,8 +233,9 @@ The values are printed in the typein window." (call-with-transcript-buffer (lambda (buffer) (insert-string - (fluid-let ((*unparse-with-maximum-readability?* #t)) - (write-to-string expression)) + (let-fluid *unparse-with-maximum-readability?* #t + (lambda () + (write-to-string expression))) (buffer-end buffer))))) (editor-eval buffer expression @@ -526,11 +527,12 @@ Set by Scheme evaluation code to update the mode line." (define (transcript-value-string value) (if (undefined-value? value) "" - (fluid-let ((*unparser-list-depth-limit* - (ref-variable transcript-list-depth-limit)) - (*unparser-list-breadth-limit* - (ref-variable transcript-list-breadth-limit))) - (write-to-string value)))) + (let-fluids *unparser-list-depth-limit* + (ref-variable transcript-list-depth-limit) + *unparser-list-breadth-limit* + (ref-variable transcript-list-breadth-limit) + (lambda () + (write-to-string value))))) (define (call-with-transcript-buffer procedure) (let ((buffer (transcript-buffer))) diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm index 73308ae5c..64d15114c 100644 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@ -728,8 +728,9 @@ If this is an error, the debugger examines the error condition." (lambda (mark) (if mark (insert-string - (fluid-let ((*unparse-with-maximum-readability?* #t)) - (write-to-string expression)) + (let-fluid *unparse-with-maximum-readability?* #t + (lambda () + (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 7372a63ed..93c952b22 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -978,8 +978,9 @@ it is added to the front of the command history." (set-prompt-history-strings! 'REPEAT-COMPLEX-COMMAND (map (lambda (command) - (fluid-let ((*unparse-with-maximum-readability?* #t)) - (write-to-string command))) + (let-fluid *unparse-with-maximum-readability?* #t + (lambda () + (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 9a208153f..d874f83ad 100644 --- a/src/edwin/schmod.scm +++ b/src/edwin/schmod.scm @@ -327,8 +327,9 @@ Otherwise, it is shown in the echo area." ((symbol? argl) (insert-string " . " point) (insert-string (symbol-name argl) point))))) - (fluid-let ((*unparse-uninterned-symbols-by-name?* #t)) - (message procedure-name ": " argl)))) + (let-fluid *unparse-uninterned-symbols-by-name?* #t + (lambda () + (message procedure-name ": " argl))))) (editor-error "Expression does not evaluate to a procedure: " (extract-string start end)))))))) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index d2f429718..ccec68b82 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 (fluid *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 7158a3409..ec28896d3 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -470,8 +470,9 @@ USA. (output-to-string 50 (lambda () - (fluid-let ((*unparse-primitives-by-name?* true)) - (write (unsyntax expression)))))) + (let-fluid *unparse-primitives-by-name?* true + (lambda () + (write (unsyntax expression))))))) ((debugging-info/noise? expression) (output-to-string 50 @@ -950,10 +951,11 @@ using the read-eval-print environment instead.") (string-capitalize (if reason (string-append reason "; " message) message))) (define (debugger-pp expression indentation port) - (fluid-let ((*unparser-list-depth-limit* debugger:list-depth-limit) - (*unparser-list-breadth-limit* debugger:list-breadth-limit) - (*unparser-string-length-limit* debugger:string-length-limit)) - (pretty-print expression port true indentation))) + (let-fluids *unparser-list-depth-limit* debugger:list-depth-limit + *unparser-list-breadth-limit* debugger:list-breadth-limit + *unparser-string-length-limit* debugger:string-length-limit + (lambda () + (pretty-print expression port true indentation)))) (define expression-indentation 4) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 50a32f14e..e97fadc00 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -602,16 +602,16 @@ USA. (let ((hook (fluid standard-error-hook))) (if hook (let-fluid standard-error-hook #f - (lambda () - (hook condition))))) + (lambda () + (hook condition))))) (repl/start (push-repl 'INHERIT condition '() "error>"))) (define (standard-warning-handler condition) (let ((hook (fluid standard-warning-hook))) (if hook (let-fluid standard-warning-hook #f - (lambda () - (hook condition))) + (lambda () + (hook condition))) (let ((port (notification-output-port))) (fresh-line port) (write-string ";Warning: " port) @@ -1243,19 +1243,20 @@ USA. (else (error "Unexpected value:" v))))))) (define (format-error-message message irritants port) - (fluid-let ((*unparser-list-depth-limit* 2) - (*unparser-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)))) + (let-fluids *unparser-list-depth-limit* 2 + *unparser-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))))) (define-integrable (error-irritant/noise noise) (cons error-irritant/noise-tag noise)) diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 5bf0de959..a7ec24010 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -216,23 +216,24 @@ USA. (define (pp-top-level expression port as-code? indentation list-depth) (fluid-let ((x-size (- (or *pp-forced-x-size* (output-port/x-size port)) 1)) - (output-port port) - (*unparse-uninterned-symbols-by-name?* - *pp-uninterned-symbols-by-name*) - (*unparse-abbreviate-quotations?* - (or as-code? - *unparse-abbreviate-quotations?*))) - (let* ((numerical-walk - (if *pp-avoid-circularity?* - numerical-walk-avoid-circularities - numerical-walk)) - (node (numerical-walk expression list-depth))) - (if (positive? indentation) - (*unparse-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)))) + (output-port port)) + (let-fluids *unparse-uninterned-symbols-by-name?* + *pp-uninterned-symbols-by-name* + *unparse-abbreviate-quotations?* + (or as-code? + (fluid *unparse-abbreviate-quotations?*)) + (lambda () + (let* ((numerical-walk + (if *pp-avoid-circularity?* + numerical-walk-avoid-circularities + numerical-walk)) + (node (numerical-walk expression list-depth))) + (if (positive? indentation) + (*unparse-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) @@ -697,15 +698,17 @@ USA. object)))) (define (walk-pair pair list-depth) - (if (and *unparser-list-depth-limit* - (>= list-depth *unparser-list-depth-limit*) - (no-highlights? pair)) + (if (let ((limit (fluid *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 ((and *unparser-list-breadth-limit* - (>= list-breadth *unparser-list-breadth-limit*) - (no-highlights? pair)) + (cond ((let ((limit (fluid *unparser-list-breadth-limit*))) + (and limit + (>= list-breadth limit) + (no-highlights? pair))) (make-singleton-list-node "...")) ((null? (cdr pair)) (make-singleton-list-node @@ -720,10 +723,11 @@ USA. (make-list-node "." (make-singleton-list-node - (if (and *unparser-list-breadth-limit* - (>= list-breadth - *unparser-list-breadth-limit*) - (no-highlights? pair)) + (if (let ((limit + (fluid *unparser-list-breadth-limit*))) + (and limit + (>= list-breadth limit) + (no-highlights? pair))) "..." (numerical-walk (cdr pair) list-depth))))))))))))) @@ -745,19 +749,20 @@ USA. (define (walk-highlighted-object object list-depth numerical-walk) (let ((dl (pph/depth-limit object))) - (fluid-let ((*unparser-list-breadth-limit* - (let ((bl (pph/breadth-limit object))) - (if (eq? bl 'DEFAULT) - *unparser-list-breadth-limit* - bl))) - (*unparser-list-depth-limit* - (if (eq? dl 'DEFAULT) - *unparser-list-depth-limit* - dl))) - (numerical-walk (pph/object object) - (if (eq? dl 'DEFAULT) - list-depth - 0))))) + (let-fluids *unparser-list-breadth-limit* + (let ((bl (pph/breadth-limit object))) + (if (eq? bl 'DEFAULT) + (fluid *unparser-list-breadth-limit*) + bl)) + *unparser-list-depth-limit* + (if (eq? dl 'DEFAULT) + (fluid *unparser-list-depth-limit*) + dl) + (lambda () + (numerical-walk (pph/object object) + (if (eq? dl 'DEFAULT) + list-depth + 0)))))) ;;; The following are circular list/vector handing procedures. They allow @@ -835,16 +840,18 @@ USA. ;;; The following two procedures walk lists and vectors, respectively. (define (walk-pair-terminating pair half-pointer/queue list-depth) - (if (and *unparser-list-depth-limit* - (>= list-depth *unparser-list-depth-limit*) - (no-highlights? pair)) + (if (let ((limit (fluid *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) (half-pointer/queue half-pointer/queue)) - (cond ((and *unparser-list-breadth-limit* - (>= list-breadth *unparser-list-breadth-limit*) - (no-highlights? pair)) + (cond ((let ((limit (fluid *unparser-list-breadth-limit*))) + (and limit + (>= list-breadth limit) + (no-highlights? pair))) (make-singleton-list-node "...")) ((null? (cdr pair)) (make-singleton-list-node @@ -884,10 +891,10 @@ USA. "." (make-singleton-list-node (if - (and *unparser-list-breadth-limit* - (>= list-breadth - *unparser-list-breadth-limit*) - (no-highlights? pair)) + (let ((limit (fluid *unparser-list-breadth-limit*))) + (and limit + (>= list-breadth limit) + (no-highlights? pair))) "..." (let ((half-pointer/queue (advance @@ -901,15 +908,17 @@ USA. half-pointer/queue list-depth))))))))))))))) (define (walk-vector-terminating pair half-pointer/queue list-depth) - (if (and *unparser-list-depth-limit* - (>= list-depth *unparser-list-depth-limit*) - (no-highlights? pair)) + (if (let ((limit (fluid *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 ((and *unparser-list-breadth-limit* - (>= list-breadth *unparser-list-breadth-limit*) - (no-highlights? pair)) + (cond ((let ((limit (fluid *unparser-list-breadth-limit*))) + (and limit + (>= list-breadth limit) + (no-highlights? pair))) (make-singleton-list-node "...")) ((null? (cdr pair)) (make-singleton-list-node @@ -938,10 +947,11 @@ USA. (make-list-node "." (make-singleton-list-node - (if (and *unparser-list-breadth-limit* - (>= list-breadth - *unparser-list-breadth-limit*) - (no-highlights? pair)) + (if (let ((limit + (fluid *unparser-list-breadth-limit*))) + (and limit + (>= list-breadth limit) + (no-highlights? pair))) "..." (numerical-walk-terminating (cdr pair) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index fc55b18cb..5c69c2690 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -542,10 +542,11 @@ USA. (or message (and condition (cmdl-message/strings - (fluid-let ((*unparser-list-depth-limit* 25) - (*unparser-list-breadth-limit* 100) - (*unparser-string-length-limit* 500)) - (condition/report-string condition))))) + (let-fluids *unparser-list-depth-limit* 25 + *unparser-list-breadth-limit* 100 + *unparser-string-length-limit* 500 + (lambda () + (condition/report-string condition)))))) (and condition repl:allow-restart-notifications? (condition-restarts-message condition)) @@ -947,8 +948,8 @@ USA. (let ((hook (fluid standard-breakpoint-hook))) (if hook (let-fluid standard-breakpoint-hook #f - (lambda () - (hook condition))))) + (lambda () + (hook condition))))) (repl/start (push-repl (breakpoint/environment condition) condition '() diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index bd9370d54..d2d86f171 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -395,10 +395,11 @@ (define (profile-pp expression output-port) ;; Random parametrization. - (fluid-let ((*unparser-list-breadth-limit* 5) - (*unparser-list-depth-limit* 3) - (*unparser-string-length-limit* 40) - (*unparse-primitives-by-name?* #t) - (*pp-save-vertical-space?* #t) - (*pp-default-as-code?* #t)) - (pp expression output-port))) \ No newline at end of file + (let-fluids *unparser-list-breadth-limit* 5 + *unparser-list-depth-limit* 3 + *unparser-string-length-limit* 40 + *unparse-primitives-by-name?* #t + (lambda () + (fluid-let ((*pp-save-vertical-space?* #t) + (*pp-default-as-code?* #t)) + (pp expression output-port))))) \ No newline at end of file diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index f3f57aaf1..df3db3f0c 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -749,14 +749,15 @@ swank:xref (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (fluid-let ((*unparse-primitives-by-name?* #t)) - (write - (unsyntax - (if (or (debugging-info/undefined-expression? subexpression) - (debugging-info/unknown-expression? subexpression)) - expression - subexpression)) - port))) + (let-fluid *unparse-primitives-by-name?* #t + (lambda () + (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) @@ -1100,10 +1101,11 @@ swank:xref (define (pprint-to-string o) (call-with-output-string (lambda (p) - (fluid-let ((*unparser-list-breadth-limit* 10) - (*unparser-list-depth-limit* 4) - (*unparser-string-length-limit* 100)) - (pp o p))))) + (let-fluids *unparser-list-breadth-limit* 10 + *unparser-list-depth-limit* 4 + *unparser-string-length-limit* 100 + (lambda () + (pp o p)))))) ;; quote keywords, t and nil (define (quote-special x) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 8310b64ab..de922547b 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -34,18 +34,18 @@ USA. (char-set-union char-set:not-graphic (char-set #\" #\\))) (set! hook/interned-symbol unparse-symbol) (set! hook/procedure-unparser #f) - (set! *unparser-radix* 10) - (set! *unparser-list-breadth-limit* #f) - (set! *unparser-list-depth-limit* #f) - (set! *unparser-string-length-limit* #f) - (set! *unparse-primitives-by-name?* #f) - (set! *unparse-uninterned-symbols-by-name?* #f) - (set! *unparse-with-maximum-readability?* #f) - (set! *unparse-compound-procedure-names?* #t) - (set! *unparse-with-datum?* #f) - (set! *unparse-abbreviate-quotations?* #f) + (set! *unparser-radix* (make-fluid 10)) + (set! *unparser-list-breadth-limit* (make-fluid #f)) + (set! *unparser-list-depth-limit* (make-fluid #f)) + (set! *unparser-string-length-limit* (make-fluid #f)) + (set! *unparse-primitives-by-name?* (make-fluid #f)) + (set! *unparse-uninterned-symbols-by-name?* (make-fluid #f)) + (set! *unparse-with-maximum-readability?* (make-fluid #f)) + (set! *unparse-compound-procedure-names?* (make-fluid #t)) + (set! *unparse-with-datum?* (make-fluid #f)) + (set! *unparse-abbreviate-quotations?* (make-fluid #f)) (set! system-global-unparser-table (make-system-global-unparser-table)) - (set! *unparser-table* system-global-unparser-table) + (set! *unparser-table* (make-fluid system-global-unparser-table)) (set! *default-unparser-state* #f) (set! non-canon-symbol-quoted (char-set-union char-set/atom-delimiters @@ -182,8 +182,7 @@ USA. (*environment* environment) (*dispatch-table* (unparser-table/dispatch-vector - (let ((table - (repl-environment-value environment '*UNPARSER-TABLE*))) + (let ((table (fluid *unparser-table*))) (guarantee-unparser-table table #f) table)))) (*unparse-object object))) @@ -233,7 +232,7 @@ USA. (*unparse-hash object)) (define (*unparse-with-brackets name object thunk) - (if (and *unparse-with-maximum-readability?* object) + (if (and (fluid *unparse-with-maximum-readability?*) object) (*unparse-readable-hash object) (begin (*unparse-string "#[") @@ -248,7 +247,7 @@ USA. (begin (*unparse-char #\space) (thunk)) - (if *unparse-with-datum?* + (if (fluid *unparse-with-datum?*) (begin (*unparse-char #\space) (*unparse-datum object)))) @@ -325,7 +324,7 @@ USA. (define hook/interned-symbol) (define (unparse/uninterned-symbol symbol) - (if *unparse-uninterned-symbols-by-name?* + (if (fluid *unparse-uninterned-symbols-by-name?*) (unparse-symbol symbol) (*unparse-with-brackets 'UNINTERNED-SYMBOL symbol (lambda () @@ -405,9 +404,10 @@ USA. (if *slashify?* (let ((end (string-length string))) (let ((end* - (if *unparser-string-length-limit* - (min *unparser-string-length-limit* end) - end))) + (let ((limit (fluid *unparser-string-length-limit*))) + (if limit + (min limit end) + end)))) (*unparse-char #\") (if (substring-find-next-char-in-set string 0 end* string-delimiters) @@ -493,8 +493,8 @@ USA. (let loop ((index 1)) (cond ((fix:= index length) (*unparse-char #\))) - ((and *unparser-list-breadth-limit* - (>= index *unparser-list-breadth-limit*)) + ((let ((limit (fluid *unparser-list-breadth-limit*))) + (and limit (>= index limit))) (*unparse-string " ...)")) (else (*unparse-char #\space) @@ -511,7 +511,7 @@ USA. (map-reference-trap (lambda () (vector-ref vector index)))) (define (unparse/record record) - (if *unparse-with-maximum-readability?* + (if (fluid *unparse-with-maximum-readability?*) (*unparse-readable-hash record) (invoke-user-method unparse-record record))) @@ -532,12 +532,13 @@ USA. (*unparse-char #\))))) (define (limit-unparse-depth kernel) - (if *unparser-list-depth-limit* - (fluid-let ((*list-depth* (+ *list-depth* 1))) - (if (> *list-depth* *unparser-list-depth-limit*) - (*unparse-string "...") - (kernel))) - (kernel))) + (let ((limit (fluid *unparser-list-depth-limit*))) + (if limit + (fluid-let ((*list-depth* (+ *list-depth* 1))) + (if (> *list-depth* limit) + (*unparse-string "...") + (kernel))) + (kernel)))) (define (unparse-tail l n) (cond ((pair? l) @@ -549,9 +550,10 @@ USA. (begin (*unparse-char #\space) (*unparse-object (safe-car l)) - (if (and *unparser-list-breadth-limit* - (>= n *unparser-list-breadth-limit*) - (pair? (safe-cdr l))) + (if (let ((limit (fluid *unparser-list-breadth-limit*))) + (and limit + (>= n limit) + (pair? (safe-cdr l)))) (*unparse-string " ...") (unparse-tail (safe-cdr l) (+ n 1))))))) ((not (null? l)) @@ -572,7 +574,7 @@ USA. (*unparse-object (safe-car (safe-cdr pair)))) (define (unparse-list/prefix-pair? object) - (and *unparse-abbreviate-quotations?* + (and (fluid *unparse-abbreviate-quotations?*) (pair? (safe-cdr object)) (null? (safe-cdr (safe-cdr object))) (case (safe-car object) @@ -608,7 +610,7 @@ USA. (unparse-procedure procedure (lambda () (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure - (and *unparse-compound-procedure-names?* + (and (fluid *unparse-compound-procedure-names?*) (lambda-components* (procedure-lambda procedure) (lambda (name required optional rest body) required optional rest body @@ -621,9 +623,9 @@ USA. (let ((unparse-name (lambda () (*unparse-object (primitive-procedure-name procedure))))) - (cond (*unparse-primitives-by-name?* + (cond ((fluid *unparse-primitives-by-name?*) (unparse-name)) - (*unparse-with-maximum-readability?* + ((fluid *unparse-with-maximum-readability?*) (*unparse-readable-hash procedure)) (else (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f @@ -705,7 +707,7 @@ USA. (*unparse-string prefix)) radix) 10)))) - (case *unparser-radix* + (case (fluid *unparser-radix*) ((2) (prefix "#b" 2 2)) ((8) (prefix "#o" 8 8)) ((16) (prefix "#x" 10 16)) @@ -721,9 +723,10 @@ USA. (*unparse-with-brackets "floating-vector" v (and (not (zero? length)) (lambda () - (let ((limit (if (not *unparser-list-breadth-limit*) - length - (min length *unparser-list-breadth-limit*)))) + (let ((limit (let ((limit (fluid *unparser-list-breadth-limit*))) + (if (not limit) + length + (min length limit))))) (unparse/flonum ((ucode-primitive floating-vector-ref) v 0)) (do ((i 1 (+ i 1))) ((>= i limit)) @@ -753,7 +756,7 @@ USA. (compiled-procedure/name proc)) => named-arity-dispatched-procedure) (else (plain 'ARITY-DISPATCHED-PROCEDURE))))) - (*unparse-with-maximum-readability?* + ((fluid *unparse-with-maximum-readability?*) (*unparse-readable-hash entity)) ((record? (entity-extra entity)) ;; Kludge to make the generic dispatch mechanism work. diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index 1f9debff4..3483726ab 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -244,6 +244,7 @@ USA. ;;; Debugging utility (define (pp-expression form #!optional port) (fluid-let ((*pp-primitives-by-name* #f) - (*pp-uninterned-symbols-by-name* #f) - (*unparse-abbreviate-quotations?* #t)) - (pp (cgen/external-with-declarations form) port))) \ No newline at end of file + (*pp-uninterned-symbols-by-name* #f)) + (let-fluid *unparse-abbreviate-quotations?* #t + (lambda () + (pp (cgen/external-with-declarations form) port))))) diff --git a/src/sicp/compat.scm b/src/sicp/compat.scm index 8f32c51a4..4e423d5c8 100644 --- a/src/sicp/compat.scm +++ b/src/sicp/compat.scm @@ -154,14 +154,14 @@ 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)) - (set! *unparser-list-depth-limit* newval) + (set-fluid! *unparser-list-depth-limit* newval) unspecific)) (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)) - (set! *unparser-list-breadth-limit* newval) + (set-fluid! *unparser-list-breadth-limit* newval) unspecific)) (define (ceiling->exact number) diff --git a/src/swat/scheme/other/rtest.scm b/src/swat/scheme/other/rtest.scm index 076b6fe88..2c5dd5cc5 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 -; (set! *unparser-list-breadth-limit* 10) -; (set! *unparser-list-depth-limit* 10) +; (set-fluid! *unparser-list-breadth-limit* 10) +; (set-fluid! *unparser-list-depth-limit* 10) ;; GC stress test diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index ab2fd3450..ed94c44c6 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -229,8 +229,9 @@ USA. (define (write-expr-property tag p port) (write-tag tag port) - (fluid-let ((*unparse-abbreviate-quotations?* #t)) - (write (cdr p) port))) + (let-fluid *unparse-abbreviate-quotations?* #t + (lambda () + (write (cdr p) port)))) (define (write-tag tag port) (if tag