(if (not (default-object? value))
(begin
(write-string " --> " port)
- (parameterize* (list (cons *unparser-list-depth-limit* 2)
- (cons *unparser-list-breadth-limit* 10)
- (cons *unparser-string-length-limit* 30))
+ (parameterize* (list (cons param:unparser-list-depth-limit 2)
+ (cons param:unparser-list-breadth-limit 10)
+ (cons param:unparser-string-length-limit 30))
(lambda ()
(write value port))))))))
(define (write-instructions thunk)
(fluid-let ((*show-instruction* write))
- (parameterize* (list (cons *unparser-radix* 16)
- (cons *unparse-uninterned-symbols-by-name?* #t))
+ (parameterize* (list (cons param:unparser-radix 16)
+ (cons param:unparse-uninterned-symbols-by-name? #t))
thunk)))
(define (pp-instructions thunk)
(fluid-let ((*show-instruction* pretty-print))
(parameterize* (list (cons *pp-primitives-by-name* #f)
- (cons *unparser-radix* 16)
- (cons *unparse-uninterned-symbols-by-name?* #t))
+ (cons param:unparser-radix 16)
+ (cons param:unparse-uninterned-symbols-by-name? #t))
thunk)))
(define *show-instruction*)
(unparser/standard-method name))))
(define (tagged-vector/unparse state vector)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
((tagged-vector/unparser vector) state vector))))
(define (phase/lap-file-output scode port)
(compiler-phase "LAP File Output"
(lambda ()
- (parameterize* (list (cons *unparser-radix* 16)
- (cons *unparse-uninterned-symbols-by-name?* #t))
+ (parameterize* (list (cons param:unparser-radix 16)
+ (cons param:unparse-uninterned-symbols-by-name? #t))
(lambda ()
(with-output-to-port port
(lambda ()
*rtl-procedures*
*rtl-graphs*)
(import (runtime compiler-info)
- make-dbg-info-vector)
- (import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ make-dbg-info-vector))
The read-eval-print loop of Scheme evaluates all expressions in the
same environment. It is possible to change this environment using the
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (runtime load)
fasload-object-file)
(import (scode-optimizer build-utilities)
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(disassembler/instructions false start-address end-address false))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction)
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/constants-start block)))
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(disassembler/instructions false start-address end-address false))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction)
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/constants-start block)))
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(disassembler/instructions #f start-address end-address #f))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction comment)
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/marked-start block)))
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(disassembler/instructions false start-address end-address false))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction)
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/constants-start block)))
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(disassembler/instructions false start-address end-address false))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction)
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/constants-start block)))
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(make-cursor block start symbol-table)))
(define (write-instructions cursor)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (compiled-code-block/code-end (cursor-block cursor))))
(let loop ()
#t)))))
\f
(define (write-constants cursor)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let* ((block (cursor-block cursor))
(end (compiled-code-block/index->offset
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(disassembler/instructions false start-address end-address false))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction)
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/constants-start block)))
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*)
+ param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(import (runtime pretty-printer)
*pp-primitives-by-name*)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ param:unparse-uninterned-symbols-by-name?))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(disassembler/instructions #f start-address end-address #f))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction comment)
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons *unparser-radix* 16))
+ (parameterize* (list (cons param:unparser-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/marked-start block)))
port))))
(define (print-with-subexpression expression subexpression)
- (parameterize* (list (cons *unparse-primitives-by-name?* #t))
+ (parameterize* (list (cons param:unparse-primitives-by-name? #t))
(lambda ()
(if (invalid-subexpression? subexpression)
(write (unsyntax expression))
port))
(define (print-reduction-as-subexpression expression)
- (parameterize* (list (cons *unparse-primitives-by-name?* #t))
+ (parameterize* (list (cons param:unparse-primitives-by-name? #t))
(lambda ()
(write-string (ref-variable subexpression-start-marker))
(write (unsyntax expression))
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
- (parameterize* (list (cons *unparse-primitives-by-name?* #t))
+ (parameterize* (list (cons param:unparse-primitives-by-name?
+ #t))
(lambda ()
(write
(unsyntax (if (invalid-subexpression? subexpression)
(subproblem/number (reduction/subproblem reduction)))
port)))
(write-string " " port)
- (parameterize* (list (cons *unparse-primitives-by-name?* #t))
+ (parameterize* (list (cons param:unparse-primitives-by-name? #t))
(lambda ()
(write (unsyntax (reduction/expression reduction)) port)))))
(lambda (buffer)
(insert-string
(parameterize*
- (list (cons *unparse-with-maximum-readability?* #t))
+ (list (cons param: #t))
(lambda ()
(write-to-string expression)))
(buffer-end buffer)))))
(define (transcript-value-string value)
(if (undefined-value? value)
""
- (parameterize* (list (cons *unparser-list-depth-limit*
+ (parameterize* (list (cons param:unparser-list-depth-limit
(ref-variable transcript-list-depth-limit))
- (cons *unparser-list-breadth-limit*
+ (cons param:unparser-list-breadth-limit
(ref-variable transcript-list-breadth-limit)))
(lambda ()
(write-to-string value)))))
(lambda (mark)
(if mark
(insert-string
- (parameterize* (list (cons *unparse-with-maximum-readability?* #t))
+ (parameterize* (list (cons param:unparse-with-maximum-readability?
+ #t))
(lambda ()
(write-to-string expression)))
mark))))
(set-prompt-history-strings!
'REPEAT-COMPLEX-COMMAND
(map (lambda (command)
- (parameterize* (list (cons *unparse-with-maximum-readability?* #t))
+ (parameterize* (list (cons param:unparse-with-maximum-readability? #t))
(lambda ()
(write-to-string command))))
(command-history-list)))
(insert-string " . " point)
(insert-string (symbol-name argl) point)))))
(parameterize*
- (list (cons *unparse-uninterned-symbols-by-name?* #t))
+ (list (cons param:unparse-uninterned-symbols-by-name? #t))
(lambda ()
(message procedure-name ": " argl)))))
(editor-error "Expression does not evaluate to a procedure: "
(lambda (state object)
(let ((port (unparser-state/port state))
(hash-string (number->string (hash object))))
- (if (*unparse-with-maximum-readability?*)
+ (if (get-param:unparse-with-maximum-readability?)
(begin
(write-string "#@" port)
(write-string hash-string port))
(output-to-string
50
(lambda ()
- (parameterize* (list (cons *unparse-primitives-by-name?* true))
+ (parameterize* (list (cons param:unparse-primitives-by-name? #t))
(lambda ()
(write (unsyntax expression)))))))
((debugging-info/noise? expression)
(string-capitalize (if reason (string-append reason "; " message) message)))
(define (debugger-pp expression indentation port)
- (parameterize* (list (cons *unparser-list-depth-limit*
+ (parameterize* (list (cons param:unparser-list-depth-limit
debugger:list-depth-limit)
- (cons *unparser-list-breadth-limit*
+ (cons param:unparser-list-breadth-limit
debugger:list-breadth-limit)
- (cons *unparser-string-length-limit*
+ (cons param:unparser-string-length-limit
debugger:string-length-limit))
(lambda ()
(pretty-print expression port true indentation))))
(else (error "Unexpected value:" v)))))))
(define (format-error-message message irritants port)
- (parameterize* (list (cons *unparser-list-depth-limit* 2)
- (cons *unparser-list-breadth-limit* 5))
+ (parameterize* (list (cons param:unparser-list-depth-limit 2)
+ (cons param:unparser-list-breadth-limit 5))
(lambda ()
(for-each (lambda (irritant)
(if (and (pair? irritant)
(- (or (*pp-forced-x-size*)
(output-port/x-size port)) 1))
(cons output-port port)
- (cons *unparse-uninterned-symbols-by-name?*
+ (cons param:unparse-uninterned-symbols-by-name?
(*pp-uninterned-symbols-by-name*))
- (cons *unparse-abbreviate-quotations?*
+ (cons param:unparse-abbreviate-quotations?
(or as-code?
- (*unparse-abbreviate-quotations?*))))
+ (param:unparse-abbreviate-quotations?))))
(lambda ()
(let* ((numerical-walk
(if (*pp-avoid-circularity?*)
object))))
\f
(define (walk-pair pair list-depth)
- (if (let ((limit (*unparser-list-depth-limit*)))
+ (if (let ((limit (get-param:unparser-list-depth-limit)))
(and limit
(>= list-depth limit)
(no-highlights? pair)))
"..."
(let ((list-depth (+ list-depth 1)))
(let loop ((pair pair) (list-breadth 0))
- (cond ((let ((limit (*unparser-list-breadth-limit*)))
+ (cond ((let ((limit (get-param:unparser-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
(make-list-node
"."
(make-singleton-list-node
- (if (let ((limit (*unparser-list-breadth-limit*)))
+ (if (let ((limit
+ (get-param:unparser-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
(define (walk-highlighted-object object list-depth numerical-walk)
(let ((dl (pph/depth-limit object)))
- (parameterize* (list (cons *unparser-list-breadth-limit*
+ (parameterize* (list (cons param:unparser-list-breadth-limit
(let ((bl (pph/breadth-limit object)))
(if (eq? bl 'DEFAULT)
- (*unparser-list-breadth-limit*)
+ (param:unparser-list-breadth-limit)
bl)))
- (cons *unparser-list-depth-limit*
+ (cons param:unparser-list-depth-limit
(if (eq? dl 'DEFAULT)
- (*unparser-list-depth-limit*)
+ (param:unparser-list-depth-limit)
dl)))
(lambda ()
(numerical-walk (pph/object object)
;;; The following two procedures walk lists and vectors, respectively.
(define (walk-pair-terminating pair half-pointer/queue list-depth)
- (if (let ((limit (*unparser-list-depth-limit*)))
+ (if (let ((limit (get-param:unparser-list-depth-limit)))
(and limit
(>= list-depth limit)
(no-highlights? pair)))
(let ((list-depth (+ list-depth 1)))
(let loop ((pair pair) (list-breadth 0)
(half-pointer/queue half-pointer/queue))
- (cond ((let ((limit (*unparser-list-breadth-limit*)))
+ (cond ((let ((limit (get-param:unparser-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
"."
(make-singleton-list-node
(if
- (let ((limit (*unparser-list-breadth-limit*)))
+ (let ((limit (get-param:unparser-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
half-pointer/queue list-depth)))))))))))))))
\f
(define (walk-vector-terminating pair half-pointer/queue list-depth)
- (if (let ((limit (*unparser-list-depth-limit*)))
+ (if (let ((limit (get-param:unparser-list-depth-limit)))
(and limit
(>= list-depth limit)
(no-highlights? pair)))
"..."
(let ((list-depth (+ list-depth 1)))
(let loop ((pair pair) (list-breadth 0))
- (cond ((let ((limit (*unparser-list-breadth-limit*)))
+ (cond ((let ((limit (get-param:unparser-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
"."
(make-singleton-list-node
(if (let ((limit
- (*unparser-list-breadth-limit*)))
+ (get-param:unparser-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
(or message
(and condition
(cmdl-message/strings
- (parameterize* (list (cons *unparser-list-depth-limit* 25)
- (cons *unparser-list-breadth-limit* 100)
- (cons *unparser-string-length-limit* 500))
- (lambda ()
- (condition/report-string condition))))))
+ (parameterize*
+ (list (cons param:unparser-list-depth-limit 25)
+ (cons param:unparser-list-breadth-limit 100)
+ (cons param:unparser-string-length-limit 500))
+ (lambda ()
+ (condition/report-string condition))))))
(and condition
repl:allow-restart-notifications?
(condition-restarts-message condition))
guarantee-unparser-state
guarantee-unparser-table
make-unparser-table
+ param:unparse-abbreviate-quotations?
+ param:unparse-compound-procedure-names?
+ param:unparse-primitives-by-name?
+ param:unparse-streams?
+ param:unparse-uninterned-symbols-by-name?
+ param:unparse-with-datum?
+ param:unparse-with-maximum-readability?
+ param:unparser-list-breadth-limit
+ param:unparser-list-depth-limit
+ param:unparser-radix
+ param:unparser-string-length-limit
+ param:unparser-table
system-global-unparser-table
unparse-char
unparse-object
unparser-table?
user-object-type
with-current-unparser-state)
+ (export (runtime boot-definitions)
+ get-param:unparse-with-maximum-readability?)
(export (runtime record)
rtd:unparser-state)
(export (runtime output-port)
unparse-object/top-level)
(export (runtime pretty-printer)
+ get-param:unparser-list-breadth-limit
+ get-param:unparser-list-depth-limit
make-unparser-state
unparse-list/prefix-pair?
unparse-list/unparser
(define (profile-pp expression output-port)
;; Random parametrization.
- (parameterize* (list (cons *unparser-list-breadth-limit* 5)
- (cons *unparser-list-depth-limit* 3)
- (cons *unparser-string-length-limit* 40)
- (cons *unparse-primitives-by-name?* #t)
+ (parameterize* (list (cons param:unparser-list-breadth-limit 5)
+ (cons param:unparser-list-depth-limit 3)
+ (cons param:unparser-string-length-limit 40)
+ (cons param:unparse-primitives-by-name? #t)
(cons *pp-save-vertical-space?* #t)
(cons *pp-default-as-code?* #t))
(lambda ()
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
- (parameterize* (list (cons *unparse-primitives-by-name?* #t))
+ (parameterize* (list (cons param:unparse-primitives-by-name? #t))
(lambda ()
(write
(unsyntax
(define (pprint-to-string o)
(call-with-output-string
(lambda (p)
- (parameterize* (list (cons *unparser-list-breadth-limit* 10)
- (cons *unparser-list-depth-limit* 4)
- (cons *unparser-string-length-limit* 100))
+ (parameterize* (list (cons param:unparser-list-breadth-limit 10)
+ (cons param:unparser-list-depth-limit 4)
+ (cons param:unparser-string-length-limit 100))
(lambda ()
(pp o p))))))
(declare (usual-integrations))
\f
+(define hook/interned-symbol)
+(define hook/procedure-unparser)
+(define string-delimiters)
+(define non-canon-symbol-quoted)
+(define canon-symbol-quoted)
+(define system-global-unparser-table)
+
+(define *unparse-abbreviate-quotations?* #!default)
+(define *unparse-compound-procedure-names?* #!default)
+(define *unparse-primitives-by-name?* #!default)
+(define *unparse-streams?* #!default)
+(define *unparse-uninterned-symbols-by-name?* #!default)
+(define *unparse-with-datum?* #!default)
+(define *unparse-with-maximum-readability?* #!default)
+(define *unparser-list-breadth-limit* #!default)
+(define *unparser-list-depth-limit* #!default)
+(define *unparser-radix* #!default)
+(define *unparser-string-length-limit* #!default)
+(define *unparser-table* #!default)
+
+(define param:unparse-abbreviate-quotations?)
+(define param:unparse-compound-procedure-names?)
+(define param:unparse-primitives-by-name?)
+(define param:unparse-streams?)
+(define param:unparse-uninterned-symbols-by-name?)
+(define param:unparse-with-datum?)
+(define param:unparse-with-maximum-readability?)
+(define param:unparser-list-breadth-limit)
+(define param:unparser-list-depth-limit)
+(define param:unparser-radix)
+(define param:unparser-string-length-limit)
+(define param:unparser-table)
+
+(define param:default-unparser-state)
+(define param:dispatch-table)
+(define param:environment)
+(define param:list-depth)
+(define param:output-port)
+(define param:slashify?)
+;; Dynamically bound to #t if we are already unparsing a bracketed
+;; object so we can avoid nested brackets.
+(define param:unparsing-within-brackets?)
+
(define (initialize-package!)
- (set! string-delimiters
- (char-set-union char-set:not-graphic (char-set #\" #\\)))
(set! hook/interned-symbol unparse-symbol)
(set! hook/procedure-unparser #f)
- (set! *unparser-radix* (make-parameter 10))
- (set! *unparser-list-breadth-limit* (make-parameter #f))
- (set! *unparser-list-depth-limit* (make-parameter #f))
- (set! *unparser-string-length-limit* (make-parameter #f))
- (set! *unparse-primitives-by-name?* (make-parameter #f))
- (set! *unparse-uninterned-symbols-by-name?* (make-parameter #f))
- (set! *unparse-with-maximum-readability?* (make-parameter #f))
- (set! *unparse-compound-procedure-names?* (make-parameter #t))
- (set! *unparse-with-datum?* (make-parameter #f))
- (set! *unparse-abbreviate-quotations?* (make-parameter #f))
- (set! *unparse-streams?* (make-parameter #t))
- (set! system-global-unparser-table (make-system-global-unparser-table))
- (set! *unparser-table* (make-parameter system-global-unparser-table))
- (set! *default-unparser-state* (make-parameter #f))
+ (set! string-delimiters
+ (char-set-union char-set:not-graphic (char-set #\" #\\)))
(set! non-canon-symbol-quoted
- (char-set-union char-set/atom-delimiters
- char-set/symbol-quotes))
+ (char-set-union char-set/atom-delimiters char-set/symbol-quotes))
(set! canon-symbol-quoted
- (char-set-union non-canon-symbol-quoted
- char-set:upper-case))
- (set! *unparsing-within-brackets* (make-parameter #f))
- (set! *list-depth* (make-parameter #f))
- (set! *output-port* (make-parameter #f))
- (set! *slashify?* (make-parameter #f))
- (set! *environment* (make-parameter #f))
- (set! *dispatch-table* (make-parameter #f))
- unspecific)
-
-(define *unparser-radix*)
-(define *unparser-list-breadth-limit*)
-(define *unparser-list-depth-limit*)
-(define *unparser-string-length-limit*)
-(define *unparse-primitives-by-name?*)
-(define *unparse-uninterned-symbols-by-name?*)
-(define *unparse-with-maximum-readability?*)
-(define *unparse-compound-procedure-names?*)
-(define *unparse-with-datum?*)
-(define *unparse-abbreviate-quotations?*)
-(define *unparse-streams?*)
-(define system-global-unparser-table)
-(define *unparser-table*)
-(define *default-unparser-state*)
-(define non-canon-symbol-quoted)
-(define canon-symbol-quoted)
+ (char-set-union non-canon-symbol-quoted char-set:upper-case))
+ (set! system-global-unparser-table (make-system-global-unparser-table))
+ (set! param:unparse-abbreviate-quotations? (make-settable-parameter #f))
+ (set! param:unparse-compound-procedure-names? (make-settable-parameter #t))
+ (set! param:unparse-primitives-by-name? (make-settable-parameter #f))
+ (set! param:unparse-streams? (make-settable-parameter #t))
+ (set! param:unparse-uninterned-symbols-by-name? (make-settable-parameter #f))
+ (set! param:unparse-with-datum? (make-settable-parameter #f))
+ (set! param:unparse-with-maximum-readability? (make-settable-parameter #f))
+ (set! param:unparser-list-breadth-limit (make-settable-parameter #f))
+ (set! param:unparser-list-depth-limit (make-settable-parameter #f))
+ (set! param:unparser-radix (make-settable-parameter 10))
+ (set! param:unparser-string-length-limit (make-settable-parameter #f))
+ (set! param:unparser-table
+ (make-settable-parameter system-global-unparser-table))
+
+ (set! param:default-unparser-state (make-unsettable-parameter #f))
+ (set! param:dispatch-table (make-unsettable-parameter #f))
+ (set! param:environment (make-unsettable-parameter #f))
+ (set! param:list-depth (make-unsettable-parameter #f))
+ (set! param:output-port (make-unsettable-parameter #f))
+ (set! param:slashify? (make-unsettable-parameter #f))
+ (set! param:unparsing-within-brackets? (make-unsettable-parameter #f))
+ unspecific)
+\f
+(define (get-param:unparse-abbreviate-quotations?)
+ (if (default-object? *unparse-abbreviate-quotations?*)
+ (param:unparse-abbreviate-quotations?)
+ *unparse-abbreviate-quotations?*))
+
+(define (get-param:unparse-compound-procedure-names?)
+ (if (default-object? *unparse-compound-procedure-names?*)
+ (param:unparse-compound-procedure-names?)
+ *unparse-compound-procedure-names?*))
+
+(define (get-param:unparse-primitives-by-name?)
+ (if (default-object? *unparse-primitives-by-name?*)
+ (param:unparse-primitives-by-name?)
+ *unparse-primitives-by-name?*))
+
+(define (get-param:unparse-streams?)
+ (if (default-object? *unparse-streams?*)
+ (param:unparse-streams?)
+ *unparse-streams?*))
+
+(define (get-param:unparse-uninterned-symbols-by-name?)
+ (if (default-object? *unparse-uninterned-symbols-by-name?*)
+ (param:unparse-uninterned-symbols-by-name?)
+ *unparse-uninterned-symbols-by-name?*))
+
+(define (get-param:unparse-with-datum?)
+ (if (default-object? *unparse-with-datum?*)
+ (param:unparse-with-datum?)
+ *unparse-with-datum?*))
+
+(define (get-param:unparse-with-maximum-readability?)
+ (if (default-object? *unparse-with-maximum-readability?*)
+ (param:unparse-with-maximum-readability?)
+ *unparse-with-maximum-readability?*))
+
+(define (get-param:unparser-list-breadth-limit)
+ (if (default-object? *unparser-list-breadth-limit*)
+ (param:unparser-list-breadth-limit)
+ *unparser-list-breadth-limit*))
+
+(define (get-param:unparser-list-depth-limit)
+ (if (default-object? *unparser-list-depth-limit*)
+ (param:unparser-list-depth-limit)
+ *unparser-list-depth-limit*))
+
+(define (get-param:unparser-radix)
+ (if (default-object? *unparser-radix*)
+ (param:unparser-radix)
+ *unparser-radix*))
+
+(define (get-param:unparser-string-length-limit)
+ (if (default-object? *unparser-string-length-limit*)
+ (param:unparser-string-length-limit)
+ *unparser-string-length-limit*))
+
+(define (get-param:unparser-table)
+ (if (default-object? *unparser-table*)
+ (param:unparser-table)
+ *unparser-table*))
+\f
(define (make-system-global-unparser-table)
(let ((table (make-unparser-table unparse/default)))
(for-each (lambda (entry)
(define (with-current-unparser-state state procedure)
(guarantee-unparser-state state 'WITH-CURRENT-UNPARSER-STATE)
- (parameterize* (list (cons *default-unparser-state* state))
+ (parameterize* (list (cons param:default-unparser-state state))
(lambda ()
(procedure (unparser-state/port state)))))
\f
(unparser-state/environment state)))
(define (unparse-object/top-level object port slashify? environment)
- (let ((state (*default-unparser-state*)))
+ (let ((state (param:default-unparser-state)))
(unparse-object/internal
object
port
environment)))))
(define (unparse-object/internal object port list-depth slashify? environment)
- (parameterize* (list (cons *list-depth* list-depth)
- (cons *output-port* port)
- (cons *slashify?* slashify?)
- (cons *environment* environment)
- (cons *dispatch-table*
+ (parameterize* (list (cons param:list-depth list-depth)
+ (cons param:output-port port)
+ (cons param:slashify? slashify?)
+ (cons param:environment environment)
+ (cons param:dispatch-table
(unparser-table/dispatch-vector
- (let ((table (*unparser-table*)))
+ (let ((table (get-param:unparser-table)))
(guarantee-unparser-table table #f)
table))))
(lambda ()
(*unparse-object object))))
(define-integrable (invoke-user-method method object)
- (method (make-unparser-state (*output-port*)
- (*list-depth*)
- (*slashify?*)
- (*environment*))
+ (method (make-unparser-state (param:output-port)
+ (param:list-depth)
+ (param:slashify?)
+ (param:environment))
object))
-(define *list-depth*)
-(define *slashify?*)
-(define *environment*)
-(define *dispatch-table*)
-
(define (*unparse-object object)
- ((vector-ref (*dispatch-table*)
+ ((vector-ref (param:dispatch-table)
((ucode-primitive primitive-object-type 1) object))
object))
\f
;;;; Low Level Operations
-(define *output-port*)
-
(define-integrable (*unparse-char char)
- (output-port/write-char (*output-port*) char))
+ (output-port/write-char (param:output-port) char))
(define-integrable (*unparse-string string)
- (output-port/write-string (*output-port*) string))
+ (output-port/write-string (param:output-port) string))
(define-integrable (*unparse-substring string start end)
- (output-port/write-substring (*output-port*) string start end))
+ (output-port/write-substring (param:output-port) string start end))
(define-integrable (*unparse-datum object)
(*unparse-hex (object-datum object)))
(*unparse-string "#@")
(*unparse-hash object))
-;; Dynamically bound to #T if we are already unparsing a bracketed
-;; object so we can avoid nested brackets.
-(define *unparsing-within-brackets*)
-
;; Values to use while unparsing within brackets.
(define within-brackets-list-breadth-limit 5)
(define within-brackets-list-depth-limit 3)
(define (*unparse-with-brackets name object thunk)
- (if (or (and (*unparse-with-maximum-readability?*) object)
- (*unparsing-within-brackets*))
+ (if (or (and (get-param:unparse-with-maximum-readability?) object)
+ (param:unparsing-within-brackets?))
(*unparse-readable-hash object)
- (parameterize* (list (cons *unparsing-within-brackets* #t)
- (cons *unparser-list-breadth-limit*
- (if (*unparser-list-breadth-limit*)
- (min (*unparser-list-breadth-limit*)
+ (parameterize* (list (cons param:unparsing-within-brackets? #t)
+ (cons param:unparser-list-breadth-limit
+ (if (get-param:unparser-list-breadth-limit)
+ (min (get-param:unparser-list-breadth-limit)
within-brackets-list-breadth-limit)
within-brackets-list-breadth-limit))
- (cons *unparser-list-depth-limit*
- (if (*unparser-list-depth-limit*)
- (min (*unparser-list-depth-limit*)
+ (cons param:unparser-list-depth-limit
+ (if (get-param:unparser-list-depth-limit)
+ (min (get-param:unparser-list-depth-limit)
within-brackets-list-depth-limit)
within-brackets-list-depth-limit)))
(lambda ()
(begin
(*unparse-char #\space)
(limit-unparse-depth thunk))
- (if (*unparse-with-datum?*)
+ (if (get-param:unparse-with-datum?)
(begin
(*unparse-char #\space)
(*unparse-datum object))))
(define (unparse/interned-symbol symbol)
(hook/interned-symbol symbol))
-(define hook/interned-symbol)
-
(define (unparse/uninterned-symbol symbol)
- (if (*unparse-uninterned-symbols-by-name?*)
+ (if (get-param:unparse-uninterned-symbols-by-name?)
(unparse-symbol symbol)
(*unparse-with-brackets 'UNINTERNED-SYMBOL symbol
(lambda ()
(unparse-symbol-name (symbol-name symbol))))
(define (unparse-keyword-name s)
- (case (get-param:parser-keyword-style (*environment*))
+ (case (get-param:parser-keyword-style (param:environment))
((PREFIX)
(*unparse-char #\:)
(unparse-symbol-name s))
(define (unparse-symbol-name s)
(if (or (string-find-next-char-in-set
s
- (if (get-param:parser-canonicalize-symbols? (*environment*))
+ (if (get-param:parser-canonicalize-symbols? (param:environment))
canon-symbol-quoted
non-canon-symbol-quoted))
(fix:= (string-length s) 0)
(char=? (string-ref string 0) #\#))
(define (looks-like-keyword? string)
- (case (get-param:parser-keyword-style (*environment*))
+ (case (get-param:parser-keyword-style (param:environment))
((PREFIX)
(char=? (string-ref string 0) #\:))
((SUFFIX)
(else #f)))
(define (unparse/character character)
- (if (or (*slashify?*)
+ (if (or (param:slashify?)
(not (char-ascii? character)))
(begin
(*unparse-string "#\\")
(*unparse-char character)))
\f
(define (unparse/string string)
- (if (*slashify?*)
+ (if (param:slashify?)
(let ((end (string-length string)))
(let ((end*
- (let ((limit (*unparser-string-length-limit*)))
+ (let ((limit (get-param:unparser-string-length-limit)))
(if limit
(min limit end)
end))))
(digit->char (integer-divide-remainder qr2) 8)
(digit->char (integer-divide-remainder qr1) 8)))))
-(define string-delimiters)
-
(define (unparse/bit-string bit-string)
(*unparse-string "#*")
(let loop ((index (fix:- (bit-string-length bit-string) 1)))
(let loop ((index 1))
(cond ((fix:= index length)
(*unparse-char #\)))
- ((let ((limit (*unparser-list-breadth-limit*)))
+ ((let ((limit (get-param:unparser-list-breadth-limit)))
(and limit (>= index limit)))
(*unparse-string " ...)"))
(else
(map-reference-trap (lambda () (vector-ref vector index))))
(define (unparse/record record)
- (if (*unparse-with-maximum-readability?*)
+ (if (get-param:unparse-with-maximum-readability?)
(*unparse-readable-hash record)
(invoke-user-method unparse-record record)))
\f
=> (lambda (prefix) (unparse-list/prefix-pair prefix pair)))
((unparse-list/unparser pair)
=> (lambda (method) (invoke-user-method method pair)))
- ((and (*unparse-streams?*) (stream-pair? pair))
+ ((and (get-param:unparse-streams?) (stream-pair? pair))
(unparse-list/stream-pair pair))
(else
(unparse-list pair))))
(*unparse-char #\)))))
(define (limit-unparse-depth kernel)
- (let ((limit (*unparser-list-depth-limit*)))
+ (let ((limit (get-param:unparser-list-depth-limit)))
(if limit
- (let ((depth (*list-depth*)))
- (parameterize* (list (cons *list-depth* (1+ depth)))
+ (let ((depth (param:list-depth)))
+ (parameterize* (list (cons param:list-depth (1+ depth)))
(lambda ()
(if (> (1+ depth) limit)
(*unparse-string "...")
(begin
(*unparse-char #\space)
(*unparse-object (safe-car l))
- (if (let ((limit (*unparser-list-breadth-limit*)))
+ (if (let ((limit (get-param:unparser-list-breadth-limit)))
(and limit
(>= n limit)
(pair? (safe-cdr l))))
(*unparse-object (safe-car (safe-cdr pair))))
(define (unparse-list/prefix-pair? object)
- (and (*unparse-abbreviate-quotations?*)
+ (and (get-param:unparse-abbreviate-quotations?)
(pair? (safe-cdr object))
(null? (safe-cdr (safe-cdr object)))
(case (safe-car object)
((stream-pair? value)
(*unparse-char #\space)
(*unparse-object (safe-car value))
- (if (let ((limit (*unparser-list-breadth-limit*)))
+ (if (let ((limit (get-param:unparser-list-breadth-limit)))
(and limit
(>= n limit)))
(*unparse-string " ...")
\f
;;;; Procedures
-(define hook/procedure-unparser)
-
(define (unparse-procedure procedure usual-method)
(let ((method
(and hook/procedure-unparser
(unparse-procedure procedure
(lambda ()
(*unparse-with-brackets 'COMPOUND-PROCEDURE procedure
- (and (*unparse-compound-procedure-names?*)
+ (and (get-param:unparse-compound-procedure-names?)
(lambda-components* (procedure-lambda procedure)
(lambda (name required optional rest body)
required optional rest body
(let ((unparse-name
(lambda ()
(*unparse-object (primitive-procedure-name procedure)))))
- (cond ((*unparse-primitives-by-name?*)
+ (cond ((get-param:unparse-primitives-by-name?)
(unparse-name))
- ((*unparse-with-maximum-readability?*)
+ ((get-param:unparse-with-maximum-readability?)
(*unparse-readable-hash procedure))
(else
(*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f
(*unparse-string prefix))
radix)
10))))
- (case (*unparser-radix*)
+ (case (get-param:unparser-radix)
((2) (prefix "#b" 2 2))
((8) (prefix "#o" 8 8))
((16) (prefix "#x" 10 16))
(*unparse-with-brackets "floating-vector" v
(and (not (zero? length))
(lambda ()
- (let ((limit (let ((limit (*unparser-list-breadth-limit*)))
+ (let ((limit (let ((limit (get-param:unparser-list-breadth-limit)))
(if (not limit)
length
(min length limit)))))
(compiled-procedure/name proc))
=> named-arity-dispatched-procedure)
(else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
- ((*unparse-with-maximum-readability?*)
+ ((get-param:unparse-with-maximum-readability?)
(*unparse-readable-hash entity))
((record? (%entity-extra entity))
;; Kludge to make the generic dispatch mechanism work.
(*unparse-object (promise-value promise)))
(lambda ()
(*unparse-string "(unevaluated)")
- (if (*unparse-with-datum?*)
+ (if (get-param:unparse-with-datum?)
(begin
(*unparse-char #\space)
(*unparse-datum promise)))))))
\ No newline at end of file
(define (pp-expression form #!optional port)
(parameterize* (list (cons *pp-primitives-by-name* #f)
(cons *pp-uninterned-symbols-by-name* #f)
- (cons *unparse-abbreviate-quotations?* #t))
+ (cons param:unparse-abbreviate-quotations? #t))
(lambda ()
(pp (cgen/external-with-declarations form) port))))
\ No newline at end of file
(let ((newval (if (default-object? newval) false newval)))
(if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
(error:illegal-datum newval 'PRINT-DEPTH))
- (*unparser-list-depth-limit* newval)
- unspecific))
+ (param:unparser-list-depth-limit newval)))
(define (print-breadth #!optional newval)
(let ((newval (if (default-object? newval) false newval)))
(if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
(error:illegal-datum newval 'PRINT-BREADTH))
- (*unparser-list-breadth-limit* newval)
- unspecific))
+ (param:unparser-list-breadth-limit newval)))
(define (ceiling->exact number)
(inexact->exact (ceiling number)))
;; to make this possible to debug
-; (*unparser-list-breadth-limit* 10)
-; (*unparser-list-depth-limit* 10)
+; (param:unparser-list-breadth-limit 10)
+; (param:unparser-list-depth-limit 10)
;; GC stress test
(define (write-expr-property tag p port)
(write-tag tag port)
- (let-fluid *unparse-abbreviate-quotations?* #t
+ (parameterize* (list (cons param:unparse-abbreviate-quotations? #t))
(lambda ()
(write (cdr p) port))))
projects / mit-scheme.git / commitdiff