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
(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))))))))
(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*)
(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))))
(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))))))))
(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))
(loop (instruction-stream)))))))
\f
(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)))
(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))
(loop (instruction-stream)))))))
\f
(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)))
(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))
(loop (instruction-stream)))))))
\f
(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)))
(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))
(loop (instruction-stream)))))))
\f
(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)))
(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))
(loop (instruction-stream)))))))
\f
(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)))
(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)
#t)))))
\f
(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)))
(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))
(loop (instruction-stream)))))))
\f
(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)))
(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))
(loop (instruction-stream)))))))
\f
(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)))
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))))))))))))
\f
(define (invalid-subexpression? subexpression)
(or (debugging-info/undefined-expression? subexpression)
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)
(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)
(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)))
(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
(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)))))
\f
(define (call-with-transcript-buffer procedure)
(let ((buffer (transcript-buffer)))
(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))
(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
((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))))))))
(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))
(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
(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)
\f
(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)
(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))
(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)
object))))
\f
(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
(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)))))))))))))
(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))))))
\f
;;; The following are circular list/vector handing procedures. They allow
;;; 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
"."
(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
half-pointer/queue list-depth)))))))))))))))
\f
(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
(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)
(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))
(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
'()
(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
(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)
(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)
(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
(*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)))
(*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 "#[")
(begin
(*unparse-char #\space)
(thunk))
- (if *unparse-with-datum?*
+ (if (fluid *unparse-with-datum?*)
(begin
(*unparse-char #\space)
(*unparse-datum object))))
(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 ()
(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)
(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)
(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)))
\f
(*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)
(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))
(*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)
(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
(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
(*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))
(*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))
(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.
;;; 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)))))
(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)
;; 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
(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
projects / mit-scheme.git / commitdiff