The optional argument @var{environment} is an MIT/GNU Scheme extension
that is used to look up the values of control variables such as
-@code{param:parser-radix} (@pxref{reader-controls}). If not supplied,
+@code{param:reader-radix} (@pxref{reader-controls}). If not supplied,
it defaults to the @acronym{REP} environment.
@end deffn
local changes by shadowing the global bindings in the local
environment and assigning new parameters to them.
-@deffn parameter param:parser-radix
+@deffn parameter param:reader-radix
This parameter defines the radix used by the reader when it parses
numbers. This is similar to passing a radix argument to
@code{string->number}. The value of the parameter must be one of
Note that much of the number syntax is invalid for radixes other than
@code{10}. The reader detects cases where such invalid syntax is used
and signals an error. However, problems can still occur when
-@code{param:parser-radix} is bound to @code{16}, because syntax that
+@code{param:reader-radix} is bound to @code{16}, because syntax that
normally denotes symbols can now denote numbers (e.g.@: @code{abc}).
Because of this, it is usually undesirable to bind this parameter to
anything other than the default.
The default value of this parameter is @code{10}.
@end deffn
-@deffn parameter param:parser-fold-case?
+@deffn parameter param:reader-fold-case?
This parameter controls whether the parser folds the case of symbols,
character names, and certain other syntax. If it is bound to its
default value of @code{#t}, symbols read by the parser are case-folded
The following parameters may be used with @code{parameterize} to
change the behavior of the @code{write} and @code{display} procedures.
-@deffn parameter param:unparser-radix
+@deffn parameter param:printer-radix
This parameter 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}. For values other than
@code{10}, numbers are prefixed to indicate their radix.
@end deffn
-@deffn parameter param:unparser-list-breadth-limit
+@deffn parameter param:printer-list-breadth-limit
This parameter 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
@example
@group
-(parameterize ((param:unparser-list-breadth-limit 4))
+(parameterize ((param:printer-list-breadth-limit 4))
(lambda ()
(write-to-string '(a b c d))))
@result{} "(a b c d)"
-(parameterize ((param:unparser-list-breadth-limit 4))
+(parameterize ((param:printer-list-breadth-limit 4))
(lambda ()
(write-to-string '(a b c d e))))
@result{} "(a b c d ...)"
@end example
@end deffn
-@deffn parameter param:unparser-list-depth-limit
+@deffn parameter param:printer-list-depth-limit
This parameter 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
@example
@group
-(parameterize ((param:unparser-list-depth-limit 4))
+(parameterize ((param:printer-list-depth-limit 4))
(lambda ()
(write-to-string '((((a))) b c d))))
@result{} "((((a))) b c d)"
-(parameterize ((param:unparser-list-depth-limit 4))
+(parameterize ((param:printer-list-depth-limit 4))
(lambda ()
(write-to-string '(((((a)))) b c d))))
@result{} "((((...))) b c d)"
@end example
@end deffn
-@deffn parameter param:unparser-string-length-limit
+@deffn parameter param:printer-string-length-limit
This parameter 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
@example
@group
-(parameterize ((param:unparser-string-length-limit 4))
+(parameterize ((param:printer-string-length-limit 4))
(lambda ()
(write-to-string "abcd")))
@result{} "\"abcd\""
-(parameterize ((param:unparser-string-length-limit 4))
+(parameterize ((param:printer-string-length-limit 4))
(lambda ()
(write-to-string "abcde")))
@result{} "\"abcd...\""
@end example
@end deffn
-@deffn parameter param:unparse-with-maximum-readability?
+@deffn parameter param:print-with-maximum-readability?
This parameter, 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
@defvr variable flonum-unparser-cutoff
This variable is @strong{deprecated}; use
-@code{param:flonum-unparser-cutoff} instead.
+@code{param:flonum-printer-cutoff} instead.
@end defvr
-@defvr parameter param:flonum-unparser-cutoff
+@defvr parameter param:flonum-printer-cutoff
This parameter controls the action of @code{number->string} when
@var{number} is a flonum (and consequently controls all printing of
flonums). This parameter may be called with an argument to set its
@code{normal}.
@noindent
-The default value for @code{param:flonum-unparser-cutoff} is @code{normal}.
+The default value for @code{param:flonum-printer-cutoff} is @code{normal}.
If it is bound to a value different from those described here,
@code{number->string} issues a warning and acts as though the value had
been @code{normal}.
@end defvr
@noindent
-Some examples of @code{param:flonum-unparser-cutoff}:
+Some examples of @code{param:flonum-printer-cutoff}:
@example
(number->string (* 4 (atan 1 1)))
@result{} "3.141592653589793"
-(parameterize ((param:flonum-unparser-cutoff '(relative 5)))
+(parameterize ((param:flonum-printer-cutoff '(relative 5)))
(lambda ()
(number->string (* 4 (atan 1 1)))))
@result{} "3.1416"
-(parameterize ((param:flonum-unparser-cutoff '(relative 5)))
+(parameterize ((param:flonum-printer-cutoff '(relative 5)))
(lambda ()
(number->string (* 4000 (atan 1 1)))))
@result{} "3141.6"
-(parameterize ((param:flonum-unparser-cutoff '(relative 5 scientific)))
+(parameterize ((param:flonum-printer-cutoff '(relative 5 scientific)))
(lambda ()
(number->string (* 4000 (atan 1 1)))))
@result{} "3.1416e3"
-(parameterize ((param:flonum-unparser-cutoff '(relative 5 scientific)))
+(parameterize ((param:flonum-printer-cutoff '(relative 5 scientific)))
(lambda ()
(number->string (* 40000 (atan 1 1)))))
@result{} "3.1416e4"
-(parameterize ((param:flonum-unparser-cutoff '(relative 5 engineering)))
+(parameterize ((param:flonum-printer-cutoff '(relative 5 engineering)))
(lambda ()
(number->string (* 40000 (atan 1 1)))))
@result{} "31.416e3"
-(parameterize ((param:flonum-unparser-cutoff '(absolute 5)))
+(parameterize ((param:flonum-printer-cutoff '(absolute 5)))
(lambda ()
(number->string (* 4 (atan 1 1)))))
@result{} "3.14159"
-(parameterize ((param:flonum-unparser-cutoff '(absolute 5)))
+(parameterize ((param:flonum-printer-cutoff '(absolute 5)))
(lambda ()
(number->string (* 4000 (atan 1 1)))))
@result{} "3141.59265"
-(parameterize ((param:flonum-unparser-cutoff '(absolute -4)))
+(parameterize ((param:flonum-printer-cutoff '(absolute -4)))
(lambda ()
(number->string (* 4e10 (atan 1 1)))))
@result{} "31415930000."
-(parameterize ((param:flonum-unparser-cutoff '(absolute -4 scientific)))
+(parameterize ((param:flonum-printer-cutoff '(absolute -4 scientific)))
(lambda ()
(number->string (* 4e10 (atan 1 1)))))
@result{} "3.141593e10"
-(parameterize ((param:flonum-unparser-cutoff '(absolute -4 engineering)))
+(parameterize ((param:flonum-printer-cutoff '(absolute -4 engineering)))
(lambda ()
(number->string (* 4e10 (atan 1 1)))))
@result{} "31.41593e9"
-(parameterize ((param:flonum-unparser-cutoff '(absolute -5)))
+(parameterize ((param:flonum-printer-cutoff '(absolute -5)))
(lambda ()
(number->string (* 4e10 (atan 1 1)))))
@result{} "31415900000."
(if (not (default-object? value))
(begin
(write-string " --> " port)
- (parameterize* (list (cons param:unparser-list-depth-limit 2)
- (cons param:unparser-list-breadth-limit 10)
- (cons param:unparser-string-length-limit 30))
+ (parameterize* (list (cons param:printer-list-depth-limit 2)
+ (cons param:printer-list-breadth-limit 10)
+ (cons param:printer-string-length-limit 30))
(lambda ()
(write value port))))))))
(define (write-instructions thunk)
(fluid-let ((*show-instruction* write))
- (parameterize* (list (cons param:unparser-radix 16)
- (cons param:unparse-uninterned-symbols-by-name? #t))
+ (parameterize* (list (cons param:printer-radix 16)
+ (cons param:print-uninterned-symbols-by-name? #t))
thunk)))
(define (pp-instructions thunk)
(fluid-let ((*show-instruction* pretty-print))
(parameterize* (list (cons param:pp-primitives-by-name? #f)
- (cons param:unparser-radix 16)
- (cons param:unparse-uninterned-symbols-by-name? #t))
+ (cons param:printer-radix 16)
+ (cons param:print-uninterned-symbols-by-name? #t))
thunk)))
(define *show-instruction*)
(error "Not a tagged vector" object))))
(define (tagged-vector/unparse state vector)
- (parameterize* (list (cons param:unparser-radix 16))
+ (parameterize* (list (cons param:printer-radix 16))
(lambda ()
((tagged-vector/unparser vector) state vector))))
(list (procedure-label procedure))
(list type)))))))
-(define-integrable (unparse-label state label)
- (unparse-string state (symbol->string label)))
-
(define-integrable (rvalue/procedure? rvalue)
(eq? (tagged-vector/tag rvalue) procedure-tag))
(define (phase/lap-file-output scode port)
(compiler-phase "LAP File Output"
(lambda ()
- (parameterize* (list (cons param:unparser-radix 16)
- (cons param:unparse-uninterned-symbols-by-name? #t))
+ (parameterize* (list (cons param:printer-radix 16)
+ (cons param:print-uninterned-symbols-by-name? #t))
(lambda ()
(parameterize* (list (cons current-output-port port))
(lambda ()
(import (runtime compiler-info)
make-dbg-info-vector
split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
(import (runtime load)
fasload-object-file)
(import (scode-optimizer build-utilities)
show-fg
show-fg-node
show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
+ write-rtl-instructions))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(import (runtime compiler-info)
make-dbg-info-vector
split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
show-fg
show-fg-node
show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
+ write-rtl-instructions))
(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 param:unparser-radix 16))
+ (parameterize* (list (cons param:printer-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 param:unparser-radix 16))
+ (parameterize* (list (cons param:printer-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/marked-start block)))
(import (runtime compiler-info)
make-dbg-info-vector
split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
show-fg
show-fg-node
show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
+ write-rtl-instructions))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
(make-cursor block start symbol-table)))
(define (write-instructions cursor)
- (parameterize* (list (cons param:unparser-radix 16))
+ (parameterize* (list (cons param:printer-radix 16))
(lambda ()
(let ((end (compiled-code-block/code-end (cursor-block cursor))))
(let loop ()
#t)))))
\f
(define (write-constants cursor)
- (parameterize* (list (cons param:unparser-radix 16))
+ (parameterize* (list (cons param:printer-radix 16))
(lambda ()
(let* ((block (cursor-block cursor))
(end (compiled-code-block/index->offset
(import (runtime compiler-info)
make-dbg-info-vector
split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
(import (scode-optimizer build-utilities)
directory-processor))
\f
show-fg
show-fg-node
show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
+ write-rtl-instructions))
(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 param:unparser-radix 16))
+ (parameterize* (list (cons param:printer-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 param:unparser-radix 16))
+ (parameterize* (list (cons param:printer-radix 16))
(lambda ()
(let ((end (system-vector-length block)))
(let loop ((index (compiled-code-block/marked-start block)))
(define-structure (unparser-literal
(conc-name unparser-literal/)
(print-procedure
- (lambda (state instance)
- (unparse-string state
- (unparser-literal/string instance))))
+ (general-unparser-method
+ (lambda (instance port)
+ (write-string (unparser-literal/string instance)
+ port))))
(constructor unparser-literal/make))
string)
port))))
(define (print-with-subexpression expression subexpression)
- (parameterize* (list (cons param:unparse-primitives-by-name? #t))
+ (parameterize* (list (cons param:print-primitives-by-name? #t))
(lambda ()
(if (invalid-subexpression? subexpression)
(write (unsyntax expression))
port))
(define (print-reduction-as-subexpression expression)
- (parameterize* (list (cons param:unparse-primitives-by-name? #t))
+ (parameterize* (list (cons param:print-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 param:unparse-primitives-by-name?
+ (parameterize* (list (cons param:print-primitives-by-name?
#t))
(lambda ()
(write
(subproblem/number (reduction/subproblem reduction)))
port)))
(write-string " " port)
- (parameterize* (list (cons param:unparse-primitives-by-name? #t))
+ (parameterize* (list (cons param:print-primitives-by-name? #t))
(lambda ()
(write (unsyntax (reduction/expression reduction)) port)))))
(import (runtime microcode-tables)
fixed-objects-item
update-fixed-objects-item!)
- (import (runtime parser)
- get-param:parser-fold-case?)
(import (runtime port)
(make-port make-textual-port)
(make-port-type make-textual-port-type)
(lambda (buffer)
(insert-string
(parameterize*
- (list (cons param:unparse-with-maximum-readability? #t))
+ (list (cons param:print-with-maximum-readability? #t))
(lambda ()
(write-to-string expression)))
(buffer-end buffer)))))
(define (transcript-value-string value)
(if (undefined-value? value)
""
- (parameterize* (list (cons param:unparser-list-depth-limit
+ (parameterize* (list (cons param:printer-list-depth-limit
(ref-variable transcript-list-depth-limit))
- (cons param:unparser-list-breadth-limit
+ (cons param:printer-list-breadth-limit
(ref-variable transcript-list-breadth-limit)))
(lambda ()
(write-to-string value)))))
(lambda (mark)
(if mark
(insert-string
- (parameterize* (list (cons param:unparse-with-maximum-readability?
+ (parameterize* (list (cons param:print-with-maximum-readability?
#t))
(lambda ()
(write-to-string expression)))
(set-prompt-history-strings!
'REPEAT-COMPLEX-COMMAND
(map (lambda (command)
- (parameterize* (list (cons param:unparse-with-maximum-readability?
+ (parameterize* (list (cons param:print-with-maximum-readability?
#t))
(lambda ()
(write-to-string command))))
(let ((completions
(let ((environment (evaluation-environment #f)))
(obarray-completions
- (if (and bound-only? (get-param:parser-fold-case?))
+ (if (and bound-only? (param:reader-fold-case?))
(string-downcase prefix)
prefix)
(if bound-only?
(insert-string " . " point)
(insert-string (symbol->string argl) point)))))
(parameterize*
- (list (cons param:unparse-uninterned-symbols-by-name? #t))
+ (list (cons param:print-uninterned-symbols-by-name? #t))
(lambda ()
(message procedure-name ": " argl)))))
(editor-error "Expression does not evaluate to a procedure: "
(write-string (->namestring filename) port))
(lambda ()
(let ((code
- (parameterize ((param:parser-fold-case? #f))
+ (parameterize ((param:reader-fold-case? #f))
(ignore-errors
(lambda ()
(read-file filename))))))
(define (generate-property-table-1 prop-name exprs)
(let ((ucd-version (read-ucd-version-file)))
(parameterize ((param:pp-forced-x-size 1000)
- (param:unparse-char-in-unicode-syntax? #t))
+ (param:print-char-in-unicode-syntax? #t))
(call-with-output-file (prop-table-file-name prop-name)
(lambda (port)
(write-copyright-and-title prop-name ucd-version port)
(lambda (inport)
(let loop ()
(let ((form
- (parameterize* (list (cons param:parser-fold-case? #f))
+ (parameterize* (list (cons param:reader-fold-case? #f))
(lambda ()
(read inport)))))
(if (not (eof-object? form))
(if (< n (expt 10 (- k 1)))
(string-append (string-pad-left (number->string n) (- k 1)) " ")
(let ((s
- (parameterize* (list (cons param:flonum-unparser-cutoff
+ (parameterize* (list (cons param:flonum-printer-cutoff
`(RELATIVE ,k ENGINEERING)))
(lambda ()
(number->string (exact->inexact n))))))
(lambda (state object)
(with-current-unparser-state state
(lambda (port)
- (if (get-param:unparse-with-maximum-readability?)
+ (if (get-param:print-with-maximum-readability?)
(begin
(write-string "#@" port)
(write (hash-object object) port))
(output-to-string
50
(lambda ()
- (parameterize* (list (cons param:unparse-primitives-by-name? #t))
+ (parameterize* (list (cons param:print-primitives-by-name? #t))
(lambda ()
(write (unsyntax expression)))))))
((debugging-info/noise? expression)
(string-titlecase (if reason (string-append reason "; " message) message)))
(define (debugger-pp expression indentation port)
- (parameterize* (list (cons param:unparser-list-depth-limit
+ (parameterize* (list (cons param:printer-list-depth-limit
debugger:list-depth-limit)
- (cons param:unparser-list-breadth-limit
+ (cons param:printer-list-breadth-limit
debugger:list-breadth-limit)
- (cons param:unparser-string-length-limit
+ (cons param:printer-string-length-limit
debugger:string-length-limit))
(lambda ()
(pretty-print expression port true indentation))))
(declare (usual-integrations))
\f
-(define flonum-unparser-hook #f)
+(define flonum-printer-hook #f)
(define flonum-unparser-cutoff #!default)
-(define param:flonum-unparser-cutoff)
+(define param:flonum-printer-cutoff)
(define expt-radix)
(define (initialize-dragon4!)
- (set! param:flonum-unparser-cutoff
+ (set! param:flonum-printer-cutoff
(make-settable-parameter 'normal
(lambda (cutoff)
(guarantee-cutoff-spec cutoff)
(let ((p flo:significand-digits-base-2))
(call-with-values (lambda () (dragon4-normalize x p))
(lambda (f e)
- (call-with-values flonum-unparser-cutoff-args
+ (call-with-values flonum-printer-cutoff-args
(lambda (cutoff-mode cutoff display-procedure)
(dragon4 f e p radix cutoff-mode cutoff
(lambda (u k generate)
(cons (digit->char u radix)
(generate loop)))))))
(display-procedure digits k radix))))))))))))
- (or (and flonum-unparser-hook
- (flonum-unparser-hook x radix))
+ (or (and flonum-printer-hook
+ (flonum-printer-hook x radix))
(cond ((flo:nan? x)
(string-copy "+nan.0"))
((flo:positive? x)
(else
(string-copy "+nan.0"))))))
-(define (flonum-unparser:normal-output digits k radix)
+(define (flonum-printer:normal-output digits k radix)
(let ((k+1 (+ k 1)))
(let ((k+1-l (- k+1 (string-length digits)))
(n (flo:significand-digits radix)))
(else
(scientific-output digits k radix 0))))))
-(define (flonum-unparser:scientific-output digits k radix)
+(define (flonum-printer:scientific-output digits k radix)
(scientific-output digits k radix 0))
-(define (flonum-unparser:engineering-output digits k radix)
+(define (flonum-printer:engineering-output digits k radix)
(scientific-output digits k radix (modulo k 3)))
(define (scientific-output digits k radix kr)
"e"
exponent)))))
\f
-(define (flonum-unparser-cutoff-args)
+(define (flonum-printer-cutoff-args)
(let ((cutoff
(if (default-object? flonum-unparser-cutoff)
- (param:flonum-unparser-cutoff)
+ (param:flonum-printer-cutoff)
flonum-unparser-cutoff)))
(cond ((eq? 'normal cutoff)
- (values 'normal 0 flonum-unparser:normal-output))
+ (values 'normal 0 flonum-printer:normal-output))
((compound-cutoff-spec? cutoff)
(values (car cutoff)
(- (cadr cutoff))
(if (null? (cddr cutoff))
- flonum-unparser:normal-output
+ flonum-printer:normal-output
(lookup-symbolic-display-mode
(caddr cutoff)))))
(else
(warn "illegal flonum unparser cutoff parameter"
cutoff)
- (values 'normal 0 flonum-unparser:normal-output)))))
+ (values 'normal 0 flonum-printer:normal-output)))))
(define (cutoff-spec? cutoff)
(or (eq? 'normal cutoff)
(define (lookup-symbolic-display-mode mode)
(case mode
- ((engineering) flonum-unparser:engineering-output)
- ((scientific) flonum-unparser:scientific-output)
- ((normal) flonum-unparser:normal-output)
+ ((engineering) flonum-printer:engineering-output)
+ ((scientific) flonum-printer:scientific-output)
+ ((normal) flonum-printer:normal-output)
(else mode)))
(define (dragon4-normalize x precision)
("ordvec" (runtime ordered-vector))
("output-port" (runtime output-port))
("packag" (package))
- ("parser" (runtime parser))
("parser-buffer" (runtime parser-buffer))
("pathname" (runtime pathname))
("pgsql" (runtime postgresql))
("prgcop" (runtime program-copier))
("primitive-arithmetic" (runtime primitive-arithmetic))
("primitive-io" (runtime primitive-io))
+ ("printer" (runtime printer))
("procedure" (runtime procedure))
("process" (runtime subprocess))
("prop1d" (runtime 1d-property))
("queue" (runtime simple-queue))
("random" (runtime random-number))
("rbtree" (runtime rb-tree))
+ ("reader" (runtime reader))
("record" (runtime record))
("reference-trap" (runtime reference-trap))
("regexp" (runtime regular-expression))
("thread-queue" (runtime thread-queue))
("transcript" (runtime transcript))
("unix-pathname" (runtime pathname unix))
- ("unpars" (runtime unparser))
("unsyn" (runtime unsyntaxer))
("unxdir" (runtime directory))
("unxprm" (runtime os-primitives))
(else (error "Unexpected value:" v)))))))
(define (format-error-message message irritants port)
- (parameterize* (list (cons param:unparser-list-depth-limit 2)
- (cons param:unparser-list-breadth-limit 5))
+ (parameterize* (list (cons param:printer-list-depth-limit 2)
+ (cons param:printer-list-breadth-limit 5))
(lambda ()
(for-each (lambda (irritant)
(if (and (pair? irritant)
((ucode-primitive unbind-variable 2) (->environment environment) name))
(define (simple-top-level-environment fold-case?)
- (make-top-level-environment (list 'param:parser-fold-case?
+ (make-top-level-environment (list 'param:reader-fold-case?
'*parser-canonicalize-symbols?*)
(list (make-settable-parameter fold-case?)
#!default)))
\f
(define (read #!optional port environment)
(declare (ignore environment))
- (parse-object (optional-input-port port 'read)))
+ (read-top-level (optional-input-port port 'read)))
(define (read-file pathname #!optional environment)
(declare (ignore environment))
;; Syntax
(runtime number-parser)
(runtime options)
- (runtime parser)
+ (runtime reader)
(runtime file-attributes)
((runtime pathname) initialize-parser-method!)
- (runtime unparser)
+ (runtime printer)
(runtime unsyntaxer)
(runtime pretty-printer)
(runtime extended-scode-eval)
((textual-port-operation/discretionary-flush-output port) port))
(define (output-port/write-object port object environment)
- (unparse-object/top-level object port #t environment))
+ (print-top-level object port #t environment))
(define (output-port/x-size port)
(or (let ((operation (textual-port-operation port 'x-size)))
(define (display object #!optional port environment)
(let ((port (optional-output-port port 'display)))
- (unparse-object/top-level object port #f environment)
+ (print-top-level object port #f environment)
(output-port/discretionary-flush port)))
(define (write object #!optional port environment)
(add-event-receiver! event:after-restore reset-package!))
(define (initialize-parser-method!)
- (define-bracketed-object-parser-method 'pathname pathname-parser-method))
\ No newline at end of file
+ (define-bracketed-reader-method 'pathname pathname-parser-method))
\ No newline at end of file
(output-port/x-size port))
1))
(cons output-port port)
- (cons param:unparse-uninterned-symbols-by-name?
+ (cons param:print-uninterned-symbols-by-name?
(get-param:pp-uninterned-symbols-by-name?))
- (cons param:unparse-abbreviate-quotations?
+ (cons param:printer-abbreviate-quotations?
(or as-code?
- (param:unparse-abbreviate-quotations?))))
+ (param:printer-abbreviate-quotations?))))
(lambda ()
(let* ((numerical-walk
(if (get-param:pp-avoid-circularity?)
(define (numerical-walk-no-auto-highlight object list-depth)
(cond ((and (pair? object)
(not (named-list? object)))
- (let ((prefix (unparse-list/prefix-pair? object)))
+ (let ((prefix (prefix-pair? object)))
(if prefix
(make-prefix-node prefix
(numerical-walk (cadr object)
(if (or (get-param:pp-uninterned-symbols-by-name?)
(interned-symbol? object))
object
- (walk-custom unparse-object object list-depth)))
+ (walk-custom object list-depth)))
((pretty-printer-highlight? object)
;; (1) see note below.
(let ((rest (walk-highlighted-object
((and (vector? object)
(not (named-vector? object)))
(if (zero? (vector-length object))
- (walk-custom unparse-object object list-depth)
+ (walk-custom object list-depth)
(make-prefix-node "#"
(walk-pair (vector->list object)
list-depth))))
((primitive-procedure? object)
(if (get-param:pp-primitives-by-name?)
(primitive-procedure-name object)
- (walk-custom unparse-object object list-depth)))
+ (walk-custom object list-depth)))
(else
- (walk-custom unparse-object object list-depth))))
+ (walk-custom object list-depth))))
;; We do the following test first and the test above at (1) for a
;; PRETTY-PRINTER-HIGHLIGHT because the highlighted object may
(else
(numerical-walk-no-auto-highlight object list-depth))))
-(define (walk-custom unparser object list-depth)
+(define (walk-custom object list-depth)
(call-with-output-string
- (lambda (port)
- (unparser (make-unparser-state port
- list-depth
- #t
- (nearest-repl/environment))
- object))))
+ (lambda (port)
+ (parameterize* (list (cons param:printer-list-depth-limit list-depth))
+ (lambda ()
+ (write object port))))))
\f
(define (walk-pair pair list-depth)
- (if (let ((limit (get-param:unparser-list-depth-limit)))
+ (if (let ((limit (get-param:printer-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 (get-param:unparser-list-breadth-limit)))
+ (cond ((let ((limit (get-param:printer-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
"."
(make-singleton-list-node
(if (let ((limit
- (get-param:unparser-list-breadth-limit)))
+ (get-param:printer-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 param:unparser-list-breadth-limit
+ (parameterize* (list (cons param:printer-list-breadth-limit
(let ((bl (pph/breadth-limit object)))
(if (eq? bl 'default)
- (param:unparser-list-breadth-limit)
+ (param:printer-list-breadth-limit)
bl)))
- (cons param:unparser-list-depth-limit
+ (cons param:printer-list-depth-limit
(if (eq? dl 'default)
- (param:unparser-list-depth-limit)
+ (param:printer-list-depth-limit)
dl)))
(lambda ()
(numerical-walk (pph/object object)
(define queue (cdr half-pointer/queue))
(define half-pointer (car half-pointer/queue))
(cond ((pair? object)
- (let ((prefix (unparse-list/prefix-pair? object)))
+ (let ((prefix (prefix-pair? object)))
(if prefix
(make-prefix-node
prefix
(if (or (get-param:pp-uninterned-symbols-by-name?)
(interned-symbol? object))
object
- (walk-custom unparse-object object list-depth)))
+ (walk-custom object list-depth)))
((pretty-printer-highlight? object)
(let ((rest (walk-highlighted-object object list-depth)))
(make-highlighted-node (+ (pph/start-string-length object)
rest)))
((vector? object)
(if (zero? (vector-length object))
- (walk-custom unparse-object object list-depth)
+ (walk-custom object list-depth)
(make-prefix-node
"#"
(walk-vector-terminating
((primitive-procedure? object)
(if (get-param:pp-primitives-by-name?)
(primitive-procedure-name object)
- (walk-custom unparse-object object list-depth)))
+ (walk-custom object list-depth)))
(else
- (walk-custom unparse-object object list-depth))))
+ (walk-custom object list-depth))))
\f
;;; The following two procedures walk lists and vectors, respectively.
(define (walk-pair-terminating pair half-pointer/queue list-depth)
- (if (let ((limit (get-param:unparser-list-depth-limit)))
+ (if (let ((limit (get-param:printer-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 (get-param:unparser-list-breadth-limit)))
+ (cond ((let ((limit (get-param:printer-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
"."
(make-singleton-list-node
(if
- (let ((limit (get-param:unparser-list-breadth-limit)))
+ (let ((limit (get-param:printer-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 (get-param:unparser-list-depth-limit)))
+ (if (let ((limit (get-param:printer-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 (get-param:unparser-list-breadth-limit)))
+ (cond ((let ((limit (get-param:printer-list-breadth-limit)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Scheme Printer
+;;; package: (runtime printer)
+
+(declare (usual-integrations))
+\f
+(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-deferred param:print-char-in-unicode-syntax?
+ (make-unsettable-parameter #f boolean-converter))
+
+(define-deferred param:print-compound-procedure-names?
+ (make-unsettable-parameter #t boolean-converter))
+
+(define-deferred param:print-primitives-by-name?
+ (make-unsettable-parameter #f boolean-converter))
+
+(define-deferred param:print-streams?
+ (make-unsettable-parameter #t boolean-converter))
+
+(define-deferred param:print-uninterned-symbols-by-name?
+ (make-unsettable-parameter #f boolean-converter))
+
+(define-deferred param:print-with-datum?
+ (make-unsettable-parameter #f boolean-converter))
+
+(define-deferred param:print-with-maximum-readability?
+ (make-unsettable-parameter #f boolean-converter))
+
+(define-deferred param:printer-abbreviate-quotations?
+ (make-unsettable-parameter #f boolean-converter))
+
+(define-deferred param:printer-list-breadth-limit
+ (make-unsettable-parameter #f limit-converter))
+
+(define-deferred param:printer-list-depth-limit
+ (make-unsettable-parameter #f limit-converter))
+
+(define-deferred param:printer-radix
+ (make-unsettable-parameter 10 radix-converter))
+
+(define-deferred param:printer-string-length-limit
+ (make-unsettable-parameter #f limit-converter))
+
+(define (boolean-converter value)
+ (guarantee boolean? value))
+
+(define (limit-converter value)
+ (if value (guarantee exact-positive-integer? value))
+ value)
+
+(define (radix-converter value)
+ (if (not (memv value '(2 8 10 16)))
+ (error "Invalid printer radix:" value))
+ value)
+\f
+(define (resolve-fluids param fluid)
+ (if (default-object? fluid)
+ (param)
+ ((parameter-converter param) fluid)))
+
+(define (get-param:print-compound-procedure-names?)
+ (resolve-fluids param:print-compound-procedure-names?
+ *unparse-compound-procedure-names?*))
+
+(define (get-param:print-primitives-by-name?)
+ (resolve-fluids param:print-primitives-by-name?
+ *unparse-primitives-by-name?*))
+
+(define (get-param:print-streams?)
+ (resolve-fluids param:print-streams?
+ *unparse-streams?*))
+
+(define (get-param:print-uninterned-symbols-by-name?)
+ (resolve-fluids param:print-uninterned-symbols-by-name?
+ *unparse-uninterned-symbols-by-name?*))
+
+(define (get-param:print-with-datum?)
+ (resolve-fluids param:print-with-datum?
+ *unparse-with-datum?*))
+
+(define (get-param:print-with-maximum-readability?)
+ (resolve-fluids param:print-with-maximum-readability?
+ *unparse-with-maximum-readability?*))
+
+(define (get-param:printer-abbreviate-quotations?)
+ (resolve-fluids param:printer-abbreviate-quotations?
+ *unparse-abbreviate-quotations?*))
+
+(define (get-param:printer-list-breadth-limit)
+ (resolve-fluids param:printer-list-breadth-limit
+ *unparser-list-breadth-limit*))
+
+(define (get-param:printer-list-depth-limit)
+ (resolve-fluids param:printer-list-depth-limit
+ *unparser-list-depth-limit*))
+
+(define (get-param:printer-radix)
+ (resolve-fluids param:printer-radix
+ *unparser-radix*))
+
+(define (get-param:printer-string-length-limit)
+ (resolve-fluids param:printer-string-length-limit
+ *unparser-string-length-limit*))
+\f
+(define-record-type <context>
+ (make-context port mode environment list-depth in-brackets?
+ list-breadth-limit list-depth-limit)
+ context?
+ (port context-port)
+ (mode context-mode)
+ (environment context-environment)
+ (list-depth context-list-depth)
+ (in-brackets? context-in-brackets?)
+ (list-breadth-limit context-list-breadth-limit)
+ (list-depth-limit context-list-depth-limit))
+
+(define (context-down-list context)
+ (make-context (context-port context)
+ (context-mode context)
+ (context-environment context)
+ (+ 1 (context-list-depth context))
+ (context-in-brackets? context)
+ (context-list-breadth-limit context)
+ (context-list-depth-limit context)))
+
+(define (context-in-brackets context)
+ (make-context (context-port context)
+ (context-mode context)
+ (context-environment context)
+ 0
+ #t
+ within-brackets:list-breadth-limit
+ within-brackets:list-depth-limit))
+
+(define within-brackets:list-breadth-limit 5)
+(define within-brackets:list-depth-limit 3)
+
+(define (context-slashify? context)
+ (eq? 'normal (context-mode context)))
+
+(define (context-char-set context)
+ (textual-port-char-set (context-port context)))
+
+(define (make-unparser-state port list-depth slashify? environment)
+ (guarantee output-port? port)
+ (guarantee environment? environment)
+ (guarantee exact-nonnegative-integer? list-depth)
+ (make-context port
+ (if slashify? 'normal 'display)
+ environment
+ list-depth
+ #f
+ (get-param:printer-list-breadth-limit)
+ (get-param:printer-list-depth-limit)))
+
+(define (with-current-unparser-state context procedure)
+ (parameterize* (list (cons initial-context context))
+ (lambda ()
+ (procedure (context-port context)))))
+
+(define-deferred initial-context
+ (make-unsettable-parameter #f))
+\f
+;;;; Top Level
+
+(define (print-top-level object port slashify? environment)
+ (guarantee output-port? port)
+ (if (not (default-object? environment))
+ (guarantee environment? environment))
+ (print-object object
+ (top-level-context port
+ (if slashify? 'normal 'display)
+ environment)))
+
+(define (top-level-context port mode environment)
+ (let ((context (initial-context)))
+ (if context
+ (make-context port
+ mode
+ (if (default-object? environment)
+ (context-environment context)
+ environment)
+ (context-list-depth context)
+ (context-in-brackets? context)
+ (context-list-breadth-limit context)
+ (context-list-depth-limit context))
+ (make-context port
+ mode
+ (if (default-object? environment)
+ (nearest-repl/environment)
+ environment)
+ 0
+ #f
+ (get-param:printer-list-breadth-limit)
+ (get-param:printer-list-depth-limit)))))
+
+(define (printer-mode? object)
+ (or (eq? 'normal object)
+ (eq? 'display object)))
+
+(define-deferred print-object
+ (standard-predicate-dispatcher 'print-object 2))
+
+(add-boot-init!
+ (lambda ()
+ (define-predicate-dispatch-default-handler print-object
+ (lambda (object context)
+ ((vector-ref dispatch-table
+ ((ucode-primitive primitive-object-type 1) object))
+ object
+ context)))
+ (set! define-unparser-method
+ (named-lambda (define-unparser-method predicate unparser)
+ (define-predicate-dispatch-handler print-object
+ (list predicate context?)
+ unparser)))
+ (run-deferred-boot-actions 'unparser-methods)))
+\f
+(define dispatch-table)
+(add-boot-init!
+ (lambda ()
+ (set! dispatch-table
+ (make-vector (microcode-type/code-limit) print-default))
+ (for-each (lambda (entry)
+ (vector-set! dispatch-table
+ (microcode-type (car entry))
+ (cadr entry)))
+ `((assignment ,print-assignment)
+ (bignum ,print-number)
+ (bytevector ,print-bytevector)
+ (character ,print-character)
+ (compiled-entry ,print-compiled-entry)
+ (complex ,print-number)
+ (constant ,print-constant)
+ (definition ,print-definition)
+ (entity ,print-entity)
+ (extended-procedure ,print-compound-procedure)
+ (flonum ,print-flonum)
+ (interned-symbol ,print-interned-symbol)
+ (lambda ,print-lambda)
+ (list ,print-pair)
+ (negative-fixnum ,print-number)
+ (false ,print-false)
+ (positive-fixnum ,print-number)
+ (primitive ,print-primitive-procedure)
+ (procedure ,print-compound-procedure)
+ (promise ,print-promise)
+ (ratnum ,print-number)
+ (record ,print-record)
+ (return-address ,print-return-address)
+ (string ,print-string)
+ (tagged-object ,print-tagged-object)
+ (unicode-string ,print-string)
+ (uninterned-symbol ,print-uninterned-symbol)
+ (variable ,print-variable)
+ (vector ,print-vector)
+ (vector-1b ,print-bit-string)))))
+\f
+;;;; Low Level Operations
+
+(define-integrable (*print-char char context)
+ (output-port/write-char (context-port context) char))
+
+(define-integrable (*print-string string context)
+ (output-port/write-string (context-port context) string))
+
+(define-integrable (*print-substring string start end context)
+ (output-port/write-substring (context-port context) string start end))
+
+(define-integrable (*print-datum object context)
+ (*print-hex (object-datum object) context))
+
+(define (*print-hex number context)
+ (*print-string "#x" context)
+ (*print-string (number->string number 16) context))
+
+(define-integrable (*print-hash object context)
+ (*print-string (number->string (hash-object object)) context))
+
+(define (*print-readable-hash object context)
+ (*print-string "#@" context)
+ (*print-hash object context))
+
+(define (allowed-char? char context)
+ (char-in-set? char (context-char-set context)))
+
+(define (*print-with-brackets name object context procedure)
+ (if (or (and (get-param:print-with-maximum-readability?) object)
+ (context-in-brackets? context))
+ (*print-readable-hash object context)
+ (begin
+ (*print-string "#[" context)
+ (let ((context* (context-in-brackets context)))
+ (if (string? name)
+ (*print-string name context*)
+ (print-object name context*))
+ (if object
+ (begin
+ (*print-char #\space context*)
+ (*print-hash object context*)))
+ (cond (procedure
+ (*print-char #\space context*)
+ (procedure context*))
+ ((get-param:print-with-datum?)
+ (*print-char #\space context*)
+ (*print-datum object context*))))
+ (*print-char #\] context))))
+\f
+;;;; Printer methods
+
+(define (print-default object context)
+ (let ((type (user-object-type object)))
+ (case (object-gc-type object)
+ ((cell pair triple quadruple vector compiled-entry)
+ (*print-with-brackets type object context #f))
+ ((non-pointer)
+ (*print-with-brackets type object context
+ (lambda (context*)
+ (*print-datum object context*))))
+ (else ;UNDEFINED, GC-INTERNAL
+ (*print-with-brackets type #f context
+ (lambda (context*)
+ (*print-datum object context*)))))))
+
+(define (user-object-type object)
+ (let ((type-code (object-type object)))
+ (let ((type-name (microcode-type/code->name type-code)))
+ (if type-name
+ (rename-user-object-type type-name)
+ (intern
+ (string-append "undefined-type:" (number->string type-code)))))))
+
+(define (rename-user-object-type type-name)
+ (let ((entry (assq type-name renamed-user-object-types)))
+ (if entry
+ (cdr entry)
+ type-name)))
+
+(define renamed-user-object-types
+ '((negative-fixnum . number)
+ (positive-fixnum . number)
+ (bignum . number)
+ (flonum . number)
+ (complex . number)
+ (interned-symbol . symbol)
+ (uninterned-symbol . symbol)
+ (extended-procedure . procedure)
+ (primitive . primitive-procedure)
+ (lexpr . lambda)
+ (extended-lambda . lambda)))
+
+(define (print-false object context)
+ (if (eq? object #f)
+ (*print-string "#f" context)
+ (print-default object context)))
+
+(define (print-constant object context)
+ (let ((string
+ (cond ((null? object) "()")
+ ((eq? object #t) "#t")
+ ((default-object? object) "#!default")
+ ((eof-object? object) "#!eof")
+ ((eq? object lambda-tag:aux) "#!aux")
+ ((eq? object lambda-tag:key) "#!key")
+ ((eq? object lambda-tag:optional) "#!optional")
+ ((eq? object lambda-tag:rest) "#!rest")
+ ((eq? object unspecific) "#!unspecific")
+ (else #f))))
+ (if string
+ (*print-string string context)
+ (print-default object context))))
+\f
+(define (print-interned-symbol symbol context)
+ (print-symbol symbol context))
+
+(define (print-uninterned-symbol symbol context)
+ (if (get-param:print-uninterned-symbols-by-name?)
+ (print-symbol-name (symbol->string symbol) context)
+ (*print-with-brackets 'uninterned-symbol symbol context
+ (lambda (context*)
+ (*print-string (symbol->string symbol) context*)))))
+
+(define (print-symbol symbol context)
+ (if (keyword? symbol)
+ (print-keyword-name (keyword->string symbol) context)
+ (print-symbol-name (symbol->string symbol) context)))
+
+(define (print-keyword-name s context)
+ (case (param:reader-keyword-style)
+ ((prefix)
+ (*print-char #\: context)
+ (print-symbol-name s context))
+ ((suffix)
+ (print-symbol-name s context)
+ (*print-char #\: context))
+ (else
+ (*print-string "#[keyword " context)
+ (print-symbol-name s context)
+ (*print-char #\] context))))
+
+(define (print-symbol-name s context)
+ (if (and (fix:> (string-length s) 0)
+ (not (string=? s "."))
+ (not (string-prefix? "#" s))
+ (char-in-set? (string-ref s 0) char-set:symbol-initial)
+ (string-every (symbol-name-no-quoting-predicate context) s)
+ (not (case (param:reader-keyword-style)
+ ((prefix) (string-prefix? ":" s))
+ ((suffix) (string-suffix? ":" s))
+ (else #f)))
+ (not (string->number s)))
+ (*print-string s context)
+ (begin
+ (*print-char #\| context)
+ (string-for-each (lambda (char)
+ (print-string-char char context))
+ s)
+ (*print-char #\| context))))
+
+(define (symbol-name-no-quoting-predicate context)
+ (conjoin (char-set-predicate
+ (if (get-param:reader-fold-case?)
+ char-set:folded-symbol-constituent
+ char-set:symbol-constituent))
+ (lambda (char)
+ (allowed-char? char context))))
+\f
+(define (print-character char context)
+ (cond ((and (param:print-char-in-unicode-syntax?)
+ (bitless-char? char))
+ (*print-string "#\\u+" context)
+ (*print-string (number->string (char->integer char) 16) context))
+ ((context-slashify? context)
+ (*print-string "#\\" context)
+ (if (and (char-in-set? char char-set:normal-printing)
+ (not (eq? 'separator:space (char-general-category char)))
+ (allowed-char? char context))
+ (*print-char char context)
+ (*print-string (char->name char) context)))
+ (else
+ (*print-char char context))))
+
+(define (print-string string context)
+ (if (context-slashify? context)
+ (let* ((end (string-length string))
+ (end*
+ (let ((limit (get-param:printer-string-length-limit)))
+ (if limit
+ (min limit end)
+ end))))
+ (*print-char #\" context)
+ (do ((index 0 (fix:+ index 1)))
+ ((not (fix:< index end*)))
+ (print-string-char (string-ref string index) context))
+ (if (< end* end)
+ (*print-string "..." context))
+ (*print-char #\" context))
+ (*print-string string context)))
+
+(define (print-string-char char context)
+ (case char
+ ((#\bel)
+ (*print-char #\\ context)
+ (*print-char #\a context))
+ ((#\bs)
+ (*print-char #\\ context)
+ (*print-char #\b context))
+ ((#\newline)
+ (*print-char #\\ context)
+ (*print-char #\n context))
+ ((#\return)
+ (*print-char #\\ context)
+ (*print-char #\r context))
+ ((#\tab)
+ (*print-char #\\ context)
+ (*print-char #\t context))
+ ((#\\ #\" #\|)
+ (*print-char #\\ context)
+ (*print-char char context))
+ (else
+ (if (and (char-in-set? char char-set:normal-printing)
+ (allowed-char? char context))
+ (*print-char char context)
+ (begin
+ (*print-char #\\ context)
+ (*print-char #\x context)
+ (*print-string (number->string (char->integer char) 16) context)
+ (*print-char #\; context))))))
+
+(define (print-bit-string bit-string context)
+ (*print-string "#*" context)
+ (let loop ((index (fix:- (bit-string-length bit-string) 1)))
+ (if (fix:>= index 0)
+ (begin
+ (*print-char (if (bit-string-ref bit-string index) #\1 #\0) context)
+ (loop (fix:- index 1))))))
+\f
+(define (print-vector vector context)
+ (let ((printer (named-vector-with-unparser? vector)))
+ (if printer
+ (printer context vector)
+ (limit-print-depth context
+ (lambda (context*)
+ (let ((end (vector-length vector)))
+ (if (fix:> end 0)
+ (begin
+ (*print-string "#(" context*)
+ (print-object (safe-vector-ref vector 0) context*)
+ (let loop ((index 1))
+ (if (fix:< index end)
+ (if (let ((limit
+ (context-list-breadth-limit context*)))
+ (and limit
+ (>= index limit)))
+ (*print-string " ...)" context*)
+ (begin
+ (*print-char #\space context*)
+ (print-object (safe-vector-ref vector index)
+ context*)
+ (loop (fix:+ index 1))))))
+ (*print-char #\) context*))
+ (*print-string "#()" context*))))))))
+
+(define (safe-vector-ref vector index)
+ (if (with-absolutely-no-interrupts
+ (lambda ()
+ (object-type? (ucode-type manifest-nm-vector)
+ (vector-ref vector index))))
+ (error "Attempt to print partially marked vector."))
+ (map-reference-trap (lambda () (vector-ref vector index))))
+
+(define (print-bytevector bytevector context)
+ (limit-print-depth context
+ (lambda (context*)
+ (let ((end (bytevector-length bytevector)))
+ (if (fix:> end 0)
+ (begin
+ (*print-string "#u8(" context*)
+ (print-object (bytevector-u8-ref bytevector 0) context*)
+ (let loop ((index 1))
+ (if (fix:< index end)
+ (if (let ((limit (get-param:printer-list-breadth-limit)))
+ (and limit
+ (>= index limit)))
+ (*print-string " ...)" context*)
+ (begin
+ (*print-char #\space context*)
+ (print-object (bytevector-u8-ref bytevector index)
+ context*)
+ (loop (fix:+ index 1))))))
+ (*print-char #\) context*))
+ (*print-string "#u8()" context*))))))
+
+(define (print-record record context)
+ (cond ((string? record) (print-string record context))
+ ((uri? record) (print-uri record context))
+ ((get-param:print-with-maximum-readability?)
+ (*print-readable-hash record context))
+ (else
+ (*print-with-brackets 'record record context #f))))
+
+(define (print-uri uri context)
+ (*print-string "#<" context)
+ (*print-string (uri->string uri) context)
+ (*print-string ">" context))
+\f
+(define (print-pair pair context)
+ (cond ((prefix-pair? pair)
+ => (lambda (prefix) (print-prefix-pair prefix pair context)))
+ ((and (get-param:print-streams?) (stream-pair? pair))
+ (print-stream-pair pair context))
+ ((named-list-with-unparser? pair)
+ => (lambda (printer) (printer context pair)))
+ (else
+ (print-list pair context))))
+
+(define (print-list list context)
+ (limit-print-depth context
+ (lambda (context*)
+ (*print-char #\( context*)
+ (print-object (safe-car list) context*)
+ (print-tail (safe-cdr list) 2 context*)
+ (*print-char #\) context*))))
+
+(define (limit-print-depth context kernel)
+ (let ((context* (context-down-list context))
+ (limit (context-list-depth-limit context)))
+ (if (and limit
+ (> (context-list-depth-limit context*) limit))
+ (*print-string "..." context*)
+ (kernel context*))))
+
+(define (print-tail l n context)
+ (cond ((pair? l)
+ (*print-char #\space context)
+ (print-object (safe-car l) context)
+ (if (let ((limit (context-list-breadth-limit context)))
+ (and limit
+ (>= n limit)
+ (pair? (safe-cdr l))))
+ (*print-string " ..." context)
+ (print-tail (safe-cdr l) (+ n 1) context)))
+ ((not (null? l))
+ (*print-string " . " context)
+ (print-object l context))))
+\f
+(define (prefix-pair? object)
+ (and (get-param:printer-abbreviate-quotations?)
+ (pair? (safe-cdr object))
+ (null? (safe-cdr (safe-cdr object)))
+ (case (safe-car object)
+ ((quote) "'")
+ ((quasiquote) "`")
+ ((unquote) ",")
+ ((unquote-splicing) ",@")
+ (else #f))))
+
+(define (print-prefix-pair prefix pair context)
+ (*print-string prefix context)
+ (print-object (safe-car (safe-cdr pair)) context))
+
+(define (print-stream-pair stream-pair context)
+ (limit-print-depth context
+ (lambda (context*)
+ (*print-char #\{ context*)
+ (print-object (safe-car stream-pair) context*)
+ (print-stream-tail (safe-cdr stream-pair) 2 context*)
+ (*print-char #\} context*))))
+
+(define (print-stream-tail tail n context)
+ (cond ((not (promise? tail))
+ (*print-string " . " context)
+ (print-object tail context))
+ ((not (promise-forced? tail))
+ (*print-string " ..." context))
+ (else
+ (let ((value (promise-value tail)))
+ (cond ((empty-stream? value))
+ ((stream-pair? value)
+ (*print-char #\space context)
+ (print-object (safe-car value) context)
+ (if (let ((limit (context-list-breadth-limit context)))
+ (and limit
+ (>= n limit)))
+ (*print-string " ..." context)
+ (print-stream-tail (safe-cdr value) (+ n 1) context)))
+ (else
+ (*print-string " . " context)
+ (print-object value context)))))))
+
+(define (safe-car pair)
+ (map-reference-trap (lambda () (car pair))))
+
+(define (safe-cdr pair)
+ (map-reference-trap (lambda () (cdr pair))))
+\f
+;;;; Procedures
+
+(define (print-compound-procedure procedure context)
+ (*print-with-brackets 'compound-procedure procedure context
+ (and (get-param:print-compound-procedure-names?)
+ (lambda-components* (procedure-lambda procedure)
+ (lambda (name required optional rest body)
+ required optional rest body
+ (and (not (eq? name scode-lambda-name:unnamed))
+ (lambda (context*)
+ (print-object name context*))))))))
+
+(define (print-primitive-procedure procedure context)
+ (let ((print-name
+ (lambda (context)
+ (print-object (primitive-procedure-name procedure) context))))
+ (cond ((get-param:print-primitives-by-name?)
+ (print-name context))
+ ((get-param:print-with-maximum-readability?)
+ (*print-readable-hash procedure context))
+ (else
+ (*print-with-brackets 'primitive-procedure #f context print-name)))))
+
+(define (print-compiled-entry entry context)
+ (let* ((type (compiled-entry-type entry))
+ (procedure? (eq? type 'compiled-procedure))
+ (closure?
+ (and procedure?
+ (compiled-code-block/manifest-closure?
+ (compiled-code-address->block entry)))))
+ (*print-with-brackets (if closure? 'compiled-closure type)
+ entry
+ context
+ (lambda (context*)
+ (let ((name (and procedure? (compiled-procedure/name entry))))
+ (receive (filename block-number)
+ (compiled-entry/filename-and-index entry)
+ (*print-char #\( context*)
+ (if name
+ (*print-string name context*))
+ (if filename
+ (begin
+ (if name
+ (*print-char #\space context*))
+ (print-object (pathname-name filename) context*)
+ (if block-number
+ (begin
+ (*print-char #\space context*)
+ (*print-hex block-number context*)))))
+ (*print-char #\) context*)))
+ (*print-char #\space context*)
+ (*print-hex (compiled-entry/offset entry) context*)
+ (if closure?
+ (begin
+ (*print-char #\space context*)
+ (*print-datum (compiled-closure->entry entry)
+ context*)))
+ (*print-char #\space context*)
+ (*print-datum entry context*)))))
+\f
+;;;; Miscellaneous
+
+(define (print-return-address return-address context)
+ (*print-with-brackets 'return-address return-address context
+ (lambda (context*)
+ (print-object (return-address/name return-address) context*))))
+
+(define (print-assignment assignment context)
+ (*print-with-brackets 'assignment assignment context
+ (lambda (context*)
+ (print-object (scode-assignment-name assignment) context*))))
+
+(define (print-definition definition context)
+ (*print-with-brackets 'definition definition context
+ (lambda (context*)
+ (print-object (scode-definition-name definition) context*))))
+
+(define (print-lambda lambda-object context)
+ (*print-with-brackets 'lambda lambda-object context
+ (lambda (context*)
+ (print-object (scode-lambda-name lambda-object) context*))))
+
+(define (print-variable variable context)
+ (*print-with-brackets 'variable variable context
+ (lambda (context*)
+ (print-object (scode-variable-name variable) context*))))
+
+(define (print-number object context)
+ (*print-string (number->string
+ object
+ (let ((prefix
+ (lambda (prefix limit radix)
+ (if (exact-rational? object)
+ (begin
+ (if (not (and (exact-integer? object)
+ (< (abs object) limit)))
+ (*print-string prefix context))
+ radix)
+ 10))))
+ (case (get-param:printer-radix)
+ ((2) (prefix "#b" 2 2))
+ ((8) (prefix "#o" 8 8))
+ ((16) (prefix "#x" 10 16))
+ (else 10))))
+ context))
+
+(define (print-flonum flonum context)
+ (if (= (system-vector-length flonum) (system-vector-length 0.0))
+ (print-number flonum context)
+ (print-floating-vector flonum context)))
+
+(define (print-floating-vector v context)
+ (let ((length ((ucode-primitive floating-vector-length) v)))
+ (*print-with-brackets "floating-vector" v context
+ (and (not (zero? length))
+ (lambda (context*)
+ (let ((limit
+ (let ((limit (get-param:printer-list-breadth-limit)))
+ (if limit
+ (min length limit)
+ length))))
+ (print-flonum ((ucode-primitive floating-vector-ref) v 0)
+ context*)
+ (do ((i 1 (+ i 1)))
+ ((>= i limit))
+ (*print-char #\space context*)
+ (print-flonum ((ucode-primitive floating-vector-ref) v i)
+ context*))
+ (if (< limit length)
+ (*print-string " ..." context*))))))))
+\f
+(define (print-entity entity context)
+
+ (define (plain name)
+ (*print-with-brackets name entity context #f))
+
+ (define (named-arity-dispatched-procedure name)
+ (*print-with-brackets 'arity-dispatched-procedure entity context
+ (lambda (context*)
+ (*print-string name context*))))
+
+ (cond ((continuation? entity)
+ (plain 'continuation))
+ ((apply-hook? entity)
+ (plain 'apply-hook))
+ ((arity-dispatched-procedure? entity)
+ (let ((proc (%entity-procedure entity)))
+ (cond ((and (compiled-code-address? proc)
+ (compiled-procedure? proc)
+ (compiled-procedure/name proc))
+ => named-arity-dispatched-procedure)
+ (else (plain 'arity-dispatched-procedure)))))
+ ((get-param:print-with-maximum-readability?)
+ (*print-readable-hash entity context))
+ (else (plain 'entity))))
+
+(define (print-promise promise context)
+ (*print-with-brackets 'promise promise context
+ (if (promise-forced? promise)
+ (lambda (context*)
+ (*print-string "(evaluated) " context*)
+ (print-object (promise-value promise) context*))
+ (lambda (context*)
+ (*print-string "(unevaluated)" context*)
+ (if (get-param:print-with-datum?)
+ (begin
+ (*print-char #\space context*)
+ (*print-datum promise context*)))))))
+
+(define (print-tagged-object object context)
+ (*print-with-brackets 'tagged-object object context
+ (lambda (context*)
+ (print-object (let ((tag (%tagged-object-tag object)))
+ (if (dispatch-tag? tag)
+ (dispatch-tag-name tag)
+ tag))
+ context*)
+ (*print-string " " context*)
+ (print-object (%tagged-object-datum object) context*))))
\ No newline at end of file
|#
-;;;; Scheme Parser
-;;; package: (runtime parser)
+;;;; Scheme Reader
+;;; package: (runtime reader)
(declare (usual-integrations))
\f
(define (boolean-converter value)
(guarantee boolean? value))
-(define-deferred param:parser-associate-positions?
+(define-deferred param:reader-associate-positions?
(make-unsettable-parameter #f boolean-converter))
-(define-deferred param:parser-fold-case?
+(define-deferred param:reader-fold-case?
(make-unsettable-parameter #t boolean-converter))
-(define-deferred param:parser-enable-attributes?
+(define-deferred param:reader-enable-attributes?
(make-unsettable-parameter #t boolean-converter))
-(define-deferred param:parser-keyword-style
+(define-deferred param:reader-keyword-style
(make-unsettable-parameter #f
(lambda (value)
(if (memq value '(#f prefix suffix))
value
(error "Invalid keyword style:" value)))))
-(define-deferred param:parser-radix
+(define-deferred param:reader-radix
(make-unsettable-parameter 10
(lambda (value)
(if (memv value '(2 8 10 16))
value
- (error "Invalid parser radix:" value)))))
+ (error "Invalid reader radix:" value)))))
-(define (get-param:parser-associate-positions?)
+(define (get-param:reader-associate-positions?)
(if (default-object? *parser-associate-positions?*)
- (param:parser-associate-positions?)
+ (param:reader-associate-positions?)
*parser-associate-positions?*))
-(define (get-param:parser-fold-case?)
+(define (get-param:reader-fold-case?)
(if (default-object? *parser-canonicalize-symbols?*)
- (param:parser-fold-case?)
+ (param:reader-fold-case?)
(and *parser-canonicalize-symbols?* 'symbols-only)))
-(define (get-param:parser-radix)
+(define (get-param:reader-radix)
(if (default-object? *parser-radix*)
- (param:parser-radix)
+ (param:reader-radix)
*parser-radix*))
\f
-(define (parse-object port)
+(define (read-top-level port)
(let ((read-operation (textual-port-operation port 'read)))
(if read-operation
(read-operation port)
(let restart ()
(let* ((db (initial-db port))
(object (dispatch db (ctx:top-level))))
- (if (eq? object restart-parsing)
+ (if (eq? object restart-reading)
(restart)
(begin
(let ((read-finish
(if (eof-object? char)
char
(let ((object ((get-initial-handler char) db ctx char)))
- (cond ((eq? object continue-parsing) (dispatch db ctx))
- ((eq? object restart-parsing) object)
+ (cond ((eq? object continue-reading) (dispatch db ctx))
+ ((eq? object restart-reading) object)
(else
(record-object-position! position object db)
object))))))
;; Causes the dispatch to be re-run.
;; Used to discard things like whitespace and comments.
-(define continue-parsing
- (list 'continue-parsing))
+(define continue-reading
+ (list 'continue-reading))
-;; Causes the dispatch to finish, but the top-level parser will return
+;; Causes the dispatch to finish, but the top-level reader will return
;; back into the dispatch after re-initializing the db. This is used
-;; to reset the parser when changing read syntax as specified by the
+;; to reset the reader when changing read syntax as specified by the
;; file attributes list.
-(define restart-parsing
- (list 'restart-parsing))
+(define restart-reading
+ (list 'restart-reading))
(define (handler:special db ctx char1)
(let ((char2 (%read-char/no-eof db)))
(define (read-in-context db get-ctx)
(let ((object (dispatch db (get-ctx))))
(cond ((eof-object? object) (error:premature-eof db))
- ((eq? object restart-parsing) (error:unexpected-restart db))
+ ((eq? object restart-reading) (error:unexpected-restart db))
(else object))))
(define (ctx:object)
(define (handler:whitespace db ctx char)
db ctx char
- continue-parsing)
+ continue-reading)
;; It would be better if we could skip over the object without
;; creating it, but for now this will work.
(define (handler:expression-comment db ctx char1 char2)
ctx char1 char2
(read-object db)
- continue-parsing)
+ continue-reading)
\f
(define (start-attributes-comment db)
(and (db-enable-attributes? db)
(if attributes
(begin
(process-file-attributes attributes db)
- restart-parsing)
- continue-parsing)))
+ restart-reading)
+ continue-reading)))
(define (handler:comment db ctx char)
(declare (ignore ctx char))
\f
(define (handler:atom db ctx char)
ctx
- (let ((string (parse-atom db (list char))))
+ (let ((string (read-atom db (list char))))
(or (maybe-keyword db string)
- (string->number string (get-param:parser-radix))
+ (string->number string (get-param:reader-radix))
(make-symbol db string))))
(define (handler:symbol db ctx char)
ctx
- (let ((string (parse-atom db (list char))))
+ (let ((string (read-atom db (list char))))
(or (maybe-keyword db string)
(if (string=? string "nan.0")
(flo:nan.0)
(define (handler:number db ctx char1 char2)
ctx
- (parse-number db (list char1 char2)))
+ (read-number db (list char1 char2)))
-(define (parse-number db prefix)
- (let ((string (parse-atom db prefix)))
- (or (string->number string (get-param:parser-radix))
+(define (read-number db prefix)
+ (let ((string (read-atom db prefix)))
+ (or (string->number string (get-param:reader-radix))
(error:illegal-number string))))
-(define (parse-atom db prefix)
+(define (read-atom db prefix)
(let ((builder (string-builder)))
(for-each builder prefix)
(let loop ()
(define (handler:unsigned-vector db ctx char1 char2)
ctx
- (let ((atom (parse-atom db '())))
+ (let ((atom (read-atom db '())))
(if (not (and atom (string=? atom "8")))
(error:unsupported-vector (string char1 char2 (or atom "")))))
(let ((char (%read-char/no-eof db)))
(if (and ignore-extra-list-closes
(top-level-ctx? ctx)
(console-i/o-port? (db-port db)))
- continue-parsing
+ continue-reading
(begin
(if (not (close-paren-ok? ctx))
(error:unbalanced-close char))
(default-method
(lambda (objects lose)
(if (pair? (cdr objects))
- (parse-unhash (cadr objects))
+ (read-unhash (cadr objects))
(lose))))
(method
(and (pair? objects)
(error:unbalanced-close char))
(close-bracket-token))
-(define (define-bracketed-object-parser-method name method)
- (guarantee interned-symbol? name 'define-bracketed-object-parser-method)
- (guarantee binary-procedure? method 'define-bracketed-object-parser-method)
+(define (define-bracketed-reader-method name method)
+ (guarantee interned-symbol? name 'define-bracketed-reader-method)
+ (guarantee binary-procedure? method 'define-bracketed-reader-method)
(hash-table-set! hashed-object-interns name method))
(define-deferred hashed-object-interns
(define (handler:unhash db ctx char1 char2)
ctx char1 char2
- (let ((object (parse-unhash (parse-number db '()))))
+ (let ((object (read-unhash (read-number db '()))))
;; This may seem a little random, because #@N doesn't just
;; return an object. However, the motivation for this piece of
;; syntax is convenience -- and 99.99% of the time the result of
;; confused.
(make-scode-quotation object)))
-(define (parse-unhash object)
+(define (read-unhash object)
(if (not (exact-nonnegative-integer? object))
(error:illegal-unhash object))
(if (eq? object 0)
(define (handler:string db ctx char)
ctx char
- (parse-delimited-string db #\" #t))
+ (read-delimited-string db #\" #t))
(define (handler:quoted-symbol db ctx char)
ctx char
- (string->symbol (parse-delimited-string db #\| #f)))
+ (string->symbol (read-delimited-string db #\| #f)))
\f
-(define (parse-delimited-string db delimiter allow-newline-escape?)
+(define (read-delimited-string db delimiter allow-newline-escape?)
(let ((builder (string-builder)))
(define (loop)
(define (dispatch char)
(cond ((char=? delimiter char) unspecific)
- ((char=? #\\ char) (parse-quoted))
+ ((char=? #\\ char) (read-quoted))
(else (emit char))))
- (define (parse-quoted)
+ (define (read-quoted)
(let ((char (%read-char/no-eof db)))
(cond ((char=? char #\a) (emit #\bel))
((char=? char #\b) (emit #\bs))
((char=? char #\n) (emit #\newline))
((char=? char #\r) (emit #\return))
((char=? char #\t) (emit #\tab))
- ((char=? char #\x) (emit (parse-hex-escape 0 '())))
+ ((char=? char #\x) (emit (read-hex-escape 0 '())))
((and allow-newline-escape?
(or (char=? char #\newline)
(char=? char #\space)
((char=? char #\f) (emit #\page))
((char=? char #\v) (emit #\vt))
((char->digit char 3)
- => (lambda (d) (emit (parse-octal-escape char d))))
+ => (lambda (d) (emit (read-octal-escape char d))))
(else (emit char)))))
(define (emit char)
(skip-space)
char)))
- (define (parse-hex-escape sv chars)
+ (define (read-hex-escape sv chars)
(let* ((char (%read-char/no-eof db))
(chars (cons char chars)))
(if (char=? #\; char)
(let ((digit (char->digit char 16)))
(if (not digit)
(ill-formed-hex chars))
- (parse-hex-escape (+ (* sv #x10) digit) chars)))))
+ (read-hex-escape (+ (* sv #x10) digit) chars)))))
(define (ill-formed-hex chars)
(error:illegal-string-escape
(list->string (cons* #\\ #\x (reverse chars)))))
- (define (parse-octal-escape c1 d1)
+ (define (read-octal-escape c1 d1)
(let* ((c2 (%read-char/no-eof db))
(d2 (char->digit c2 8))
(c3 (%read-char/no-eof db))
\f
(define (handler:false db ctx char1 char2)
ctx char1
- (let ((string (parse-atom db (list char2))))
+ (let ((string (read-atom db (list char2))))
(if (not (or (string-maybe-ci=? db string "f")
(string-maybe-ci=? db string "false")))
(error:illegal-boolean string)))
(define (handler:true db ctx char1 char2)
ctx char1
- (let ((string (parse-atom db (list char2))))
+ (let ((string (read-atom db (list char2))))
(if (not (or (string-maybe-ci=? db string "t")
(string-maybe-ci=? db string "true")))
(error:illegal-boolean string)))
(define (handler:bit-string db ctx char1 char2)
ctx char1 char2
- (let ((string (parse-atom db '())))
+ (let ((string (read-atom db '())))
(let ((n-bits (string-length string)))
(unsigned-integer->bit-string
n-bits
(%atom-end? db))
char)
((char=? char #\x)
- (let* ((string (parse-atom db '()))
+ (let* ((string (read-atom db '()))
(cp (string->number string 16 #t)))
(if (not (unicode-code-point? cp))
(error:illegal-code-point string))
\f
(define (handler:named-constant db ctx char1 char2)
ctx char1 char2
- (let ((name (parse-atom db '())))
+ (let ((name (read-atom db '())))
(cond ((string-maybe-ci=? db name "null") '())
((string-maybe-ci=? db name "false") #f)
((string-maybe-ci=? db name "true") #t)
((string-maybe-ci=? db name "unspecific") unspecific)
((string=? name "fold-case")
(set-db-fold-case! db #t)
- continue-parsing)
+ continue-reading)
((string=? name "no-fold-case")
(set-db-fold-case! db #f)
- continue-parsing)
+ continue-reading)
(else
(error:illegal-named-constant name)))))
(if operation
(lambda (char) (operation port char))
(lambda (char) char unspecific)))
- (if (get-param:parser-associate-positions?)
+ (if (get-param:reader-associate-positions?)
(optional-unary-port-operation port 'position #f)
(lambda () #f))
(optional-unary-port-operation port 'input-line #f)
(set-port-property! (db-port db) name value))
(define (db-fold-case? db)
- (db-property db 'parser-fold-case? (get-param:parser-fold-case?)))
+ (db-property db 'reader-fold-case? (get-param:reader-fold-case?)))
(define (set-db-fold-case! db value)
- (set-db-property! db 'parser-fold-case? value))
+ (set-db-property! db 'reader-fold-case? value))
(define (db-enable-attributes? db)
- (db-property db 'parser-enable-attributes? (param:parser-enable-attributes?)))
+ (db-property db 'reader-enable-attributes? (param:reader-enable-attributes?)))
(define (db-keyword-style db)
- (db-property db 'parser-keyword-style (param:parser-keyword-style)))
+ (db-property db 'reader-keyword-style (param:reader-keyword-style)))
(define (record-object-position! position object db)
(if (and position (object-pointer? object))
(db-position-mapping db)))))
(define (finish-parsing object db)
- (if (get-param:parser-associate-positions?)
+ (if (get-param:reader-associate-positions?)
(cons object (db-position-mapping db))
object))
\f
(define (process-file-attributes file-attribute-alist db)
;; Disable further attributes parsing.
- (set-db-property! db 'parser-enable-attributes? #f)
+ (set-db-property! db 'reader-enable-attributes? #f)
;; Save all the attributes; this helps with testing.
- (set-db-property! db 'parser-file-attributes file-attribute-alist)
+ (set-db-property! db 'reader-file-attributes file-attribute-alist)
(process-keyword-attribute file-attribute-alist db)
(process-mode-attribute file-attribute-alist db)
(process-studly-case-attribute file-attribute-alist db))
(cond ((and (symbol? value)
(or (string-ci=? (symbol->string value) "none")
(string-ci=? (symbol->string value) "false")))
- (set-db-property! db 'parser-keyword-style #f))
+ (set-db-property! db 'reader-keyword-style #f))
((and (symbol? value)
(string-ci=? (symbol->string value) "prefix"))
- (set-db-property! db 'parser-keyword-style 'prefix))
+ (set-db-property! db 'reader-keyword-style 'prefix))
((and (symbol? value)
(string-ci=? (symbol->string value) "suffix"))
- (set-db-property! db 'parser-keyword-style 'suffix))
+ (set-db-property! db 'reader-keyword-style 'suffix))
(else
(warn "Unrecognized value for keyword-style" value)))))))
(warn "Attribute value mismatch. Expected True.")
#f)
(else
- (set-db-property! db 'parser-fold-case? #f))))
+ (set-db-property! db 'reader-fold-case? #f))))
((or (not value)
(and (symbol? value)
(string-ci=? (symbol->string value) "false")))
- (set-db-property! db 'parser-fold-case? #t))
+ (set-db-property! db 'reader-fold-case? #t))
(else
(warn "Unrecognized value for sTuDly-case" value)))))))
\f
-(define-deferred condition-type:parse-error
- (make-condition-type 'parse-error condition-type:error '()
+(define-deferred condition-type:read-error
+ (make-condition-type 'read-error condition-type:error '()
(lambda (condition port)
condition
- (write-string "Anonymous parsing error." port))))
+ (write-string "Anonymous reading error." port))))
(define-deferred read-error?
- (condition-predicate condition-type:parse-error))
+ (condition-predicate condition-type:read-error))
-(define-syntax define-parse-error
+(define-syntax define-read-error
(sc-macro-transformer
(lambda (form environment)
environment
(let ((ct (symbol 'condition-type: name)))
`(begin
(define-deferred ,ct
- (make-condition-type ',name condition-type:parse-error
+ (make-condition-type ',name condition-type:read-error
',field-names
(lambda (condition port)
(,reporter
standard-error-handler)))))
(ill-formed-syntax form)))))
-(define-parse-error (illegal-bit-string string)
+(define-read-error (illegal-bit-string string)
(lambda (string port)
(write-string "Ill-formed bit string: #*" port)
(write-string string port)))
-(define-parse-error (illegal-boolean string)
+(define-read-error (illegal-boolean string)
(lambda (string port)
(write-string "Ill-formed boolean: " port)
(write-string string port)))
-(define-parse-error (illegal-char char)
+(define-read-error (illegal-char char)
(lambda (char port)
(write-string "Illegal character: " port)
(write char port)))
-(define-parse-error (illegal-dot-usage objects)
+(define-read-error (illegal-dot-usage objects)
(lambda (objects port)
(write-string "Ill-formed dotted list: " port)
(write objects port)))
-(define-parse-error (illegal-hashed-object objects)
+(define-read-error (illegal-hashed-object objects)
(lambda (objects port)
(write-string "Ill-formed object syntax: #[" port)
(if (pair? objects)
(cdr objects))))
(write-string "]" port)))
\f
-(define-parse-error (illegal-code-point string)
+(define-read-error (illegal-code-point string)
(lambda (string port)
(write-string "Ill-formed code point: " port)
(write string port)))
-(define-parse-error (illegal-named-constant name)
+(define-read-error (illegal-named-constant name)
(lambda (name port)
(write-string "Ill-formed named constant: #!" port)
(write name port)))
-(define-parse-error (illegal-string-escape string)
+(define-read-error (illegal-string-escape string)
(lambda (string port)
(write-string "Ill-formed string escape: " port)
(write-string string port)))
-(define-parse-error (illegal-number string)
+(define-read-error (illegal-number string)
(lambda (string port)
(write-string "Ill-formed number: " port)
(write-string string port)))
-(define-parse-error (illegal-unhash object)
+(define-read-error (illegal-unhash object)
(lambda (object port)
(write-string "Ill-formed unhash syntax: #@" port)
(write object port)))
-(define-parse-error (undefined-hash object)
+(define-read-error (undefined-hash object)
(lambda (object port)
(write-string "Undefined hash number: #@" port)
(write object port)))
-(define-parse-error (no-quoting-allowed string)
+(define-read-error (no-quoting-allowed string)
(lambda (string port)
(write-string "Quoting not permitted: " port)
(write-string string port)))
-(define-parse-error (premature-eof db)
+(define-read-error (premature-eof db)
(lambda (db port)
(write-string "Premature EOF on " port)
(write (db-port db) port)))
-(define-parse-error (re-shared-object n object)
+(define-read-error (re-shared-object n object)
(lambda (n object port)
(write-string "Can't re-share object: #" port)
(write n port)
(write-string "=" port)
(write object port)))
-(define-parse-error (non-shared-object n)
+(define-read-error (non-shared-object n)
(lambda (n port)
(write-string "Reference to non-shared object: #" port)
(write n port)
(write-string "#" port)))
-(define-parse-error (unbalanced-close char)
+(define-read-error (unbalanced-close char)
(lambda (char port)
(write-string "Unbalanced close parenthesis: " port)
(write char port)))
-(define-parse-error (unexpected-restart db)
+(define-read-error (unexpected-restart db)
(lambda (db port)
- (write-string "Unexpected parse restart on: " port)
+ (write-string "Unexpected read restart on: " port)
(write (db-port db) port)))
-(define-parse-error (unsupported-vector string)
+(define-read-error (unsupported-vector string)
(lambda (string port)
(write-string "Unsupported vector prefix: " port)
(write-string string port)))
\ No newline at end of file
(and condition
(cmdl-message/strings
(parameterize*
- (list (cons param:unparser-list-depth-limit 25)
- (cons param:unparser-list-breadth-limit 100)
- (cons param:unparser-string-length-limit 500))
+ (list (cons param:printer-list-depth-limit 25)
+ (cons param:printer-list-breadth-limit 100)
+ (cons param:printer-string-length-limit 500))
(lambda ()
(condition/report-string condition))))))
(and condition
(define-package (runtime number)
(files "arith" "dragon4")
(parent (runtime))
+ (export () deprecated:number
+ (flonum-unparser:engineering-output flonum-printer:engineering-output)
+ (flonum-unparser:normal-output flonum-printer:normal-output)
+ (flonum-unparser:scientific-output flonum-printer:scientific-output))
(export ()
(-1+ complex:-1+)
(1+ complex:1+)
exact-positive-integer?
flo:significand-digits-base-10
flo:significand-digits-base-2
+ flonum-printer:engineering-output
+ flonum-printer:normal-output
+ flonum-printer:scientific-output
flonum-unparser-cutoff
- flonum-unparser:engineering-output
- flonum-unparser:normal-output
- flonum-unparser:scientific-output
gcd
inexact?
integer-divide-quotient
non-positive?
number->string
odd?
- param:flonum-unparser-cutoff
+ param:flonum-printer-cutoff
quotient
remainder
square)
standard-system-loader)
(initialization (initialize-package!)))
-(define-package (runtime parser)
- (files "parser")
+(define-package (runtime reader)
+ (files "reader")
(parent (runtime))
(export () deprecated:parser
- (param:parser-canonicalize-symbols? param:parser-fold-case?)
+ (param:parser-canonicalize-symbols? param:reader-fold-case?)
*parser-associate-positions?*
*parser-canonicalize-symbols?*
*parser-radix*)
(export ()
- param:parser-associate-positions?
- param:parser-enable-attributes?
- param:parser-fold-case?
- param:parser-keyword-style
- param:parser-radix
+ condition-type:read-error
+ param:reader-associate-positions?
+ param:reader-enable-attributes?
+ param:reader-fold-case?
+ param:reader-keyword-style
+ param:reader-radix
read-error? ;R7RS
)
(export (runtime)
- define-bracketed-object-parser-method)
+ define-bracketed-reader-method)
(export (runtime input-port)
- parse-object)
+ read-top-level)
(export (runtime swank)
- get-param:parser-fold-case?)
- (export (runtime unparser)
- get-param:parser-fold-case?))
+ get-param:reader-fold-case?)
+ (export (runtime printer)
+ get-param:reader-fold-case?))
(define-package (runtime file-attributes)
(files "file-attributes")
(export (runtime pathname)
record-type-proxy:host
record-type-proxy:pathname)
- (export (runtime unparser)
+ (export (runtime printer)
named-list-with-unparser?
named-vector-with-unparser?)
(initialization (initialize-package!)))
increment-non-runtime!)
(initialization (initialize-package!)))
-(define-package (runtime unparser)
- (files "unpars")
+(define-package (runtime printer)
+ (files "printer")
(parent (runtime))
(export () deprecated:unparser
*unparse-abbreviate-quotations?*
*unparser-radix*
*unparser-string-length-limit*)
(export ()
- param:unparse-abbreviate-quotations?
- param:unparse-char-in-unicode-syntax?
- 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
- unparse-char
- unparse-object
- unparse-string
+ param:print-char-in-unicode-syntax?
+ param:print-compound-procedure-names?
+ param:print-primitives-by-name?
+ param:print-streams?
+ param:print-uninterned-symbols-by-name?
+ param:print-with-datum?
+ param:print-with-maximum-readability?
+ param:printer-abbreviate-quotations?
+ param:printer-list-breadth-limit
+ param:printer-list-depth-limit
+ param:printer-radix
+ param:printer-string-length-limit
+ print-object
user-object-type
with-current-unparser-state)
(export (runtime boot-definitions)
- get-param:unparse-with-maximum-readability?)
+ get-param:print-with-maximum-readability?)
(export (runtime global-database)
(unparser-state/port context-port))
(export (runtime output-port)
- unparse-object/top-level)
+ print-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?)
+ get-param:printer-list-breadth-limit
+ get-param:printer-list-depth-limit
+ prefix-pair?
+ make-unparser-state)
(export (runtime record)
(rtd:unparser-state <context>)))
(define (profile-pp expression output-port)
;; Random parametrization.
- (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)
+ (parameterize* (list (cons param:printer-list-breadth-limit 5)
+ (cons param:printer-list-depth-limit 3)
+ (cons param:printer-string-length-limit 40)
+ (cons param:print-primitives-by-name? #t)
(cons param:pp-save-vertical-space? #t)
(cons param:pp-default-as-code? #t))
(lambda ()
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
- (parameterize* (list (cons param:unparse-primitives-by-name? #t))
+ (parameterize* (list (cons param:print-primitives-by-name? #t))
(lambda ()
(write
(unsyntax
(define (all-completions prefix environment)
(let ((prefix
- (if (get-param:parser-fold-case?)
+ (if (get-param:reader-fold-case?)
(string-downcase prefix)
prefix))
(completions '()))
(define (pprint-to-string o)
(call-with-output-string
(lambda (p)
- (parameterize* (list (cons param:unparser-list-breadth-limit 10)
- (cons param:unparser-list-depth-limit 4)
- (cons param:unparser-string-length-limit 100))
+ (parameterize* (list (cons param:printer-list-breadth-limit 10)
+ (cons param:printer-list-depth-limit 4)
+ (cons param:printer-string-length-limit 100))
(lambda ()
(pp o p))))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Unparser
-;;; package: (runtime unparser)
-
-(declare (usual-integrations))
-\f
-(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 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:unparse-char-in-unicode-syntax?)
-
-(add-boot-init!
- (lambda ()
- (set! param:unparse-abbreviate-quotations?
- (make-unsettable-parameter #f
- boolean-converter))
- (set! param:unparse-compound-procedure-names?
- (make-unsettable-parameter #t
- boolean-converter))
- (set! param:unparse-primitives-by-name?
- (make-unsettable-parameter #f
- boolean-converter))
- (set! param:unparse-streams?
- (make-unsettable-parameter #t
- boolean-converter))
- (set! param:unparse-uninterned-symbols-by-name?
- (make-unsettable-parameter #f
- boolean-converter))
- (set! param:unparse-with-datum?
- (make-unsettable-parameter #f
- boolean-converter))
- (set! param:unparse-with-maximum-readability?
- (make-unsettable-parameter #f
- boolean-converter))
- (set! param:unparser-list-breadth-limit
- (make-unsettable-parameter #f
- limit-converter))
- (set! param:unparser-list-depth-limit
- (make-unsettable-parameter #f
- limit-converter))
- (set! param:unparser-radix
- (make-unsettable-parameter 10
- radix-converter))
- (set! param:unparser-string-length-limit
- (make-unsettable-parameter #f
- limit-converter))
- (set! param:unparse-char-in-unicode-syntax?
- (make-unsettable-parameter #f
- boolean-converter))
- unspecific))
-
-(define (boolean-converter value)
- (guarantee boolean? value))
-
-(define (limit-converter value)
- (if value (guarantee exact-positive-integer? value))
- value)
-
-(define (radix-converter value)
- (if (not (memv value '(2 8 10 16)))
- (error "Invalid unparser radix:" value))
- value)
-\f
-(define (resolve-fluids param fluid)
- (if (default-object? fluid)
- (param)
- ((parameter-converter param) fluid)))
-
-(define (get-param:unparse-abbreviate-quotations?)
- (resolve-fluids param:unparse-abbreviate-quotations?
- *unparse-abbreviate-quotations?*))
-
-(define (get-param:unparse-compound-procedure-names?)
- (resolve-fluids param:unparse-compound-procedure-names?
- *unparse-compound-procedure-names?*))
-
-(define (get-param:unparse-primitives-by-name?)
- (resolve-fluids param:unparse-primitives-by-name?
- *unparse-primitives-by-name?*))
-
-(define (get-param:unparse-streams?)
- (resolve-fluids param:unparse-streams?
- *unparse-streams?*))
-
-(define (get-param:unparse-uninterned-symbols-by-name?)
- (resolve-fluids param:unparse-uninterned-symbols-by-name?
- *unparse-uninterned-symbols-by-name?*))
-
-(define (get-param:unparse-with-datum?)
- (resolve-fluids param:unparse-with-datum?
- *unparse-with-datum?*))
-
-(define (get-param:unparse-with-maximum-readability?)
- (resolve-fluids param:unparse-with-maximum-readability?
- *unparse-with-maximum-readability?*))
-
-(define (get-param:unparser-list-breadth-limit)
- (resolve-fluids param:unparser-list-breadth-limit
- *unparser-list-breadth-limit*))
-
-(define (get-param:unparser-list-depth-limit)
- (resolve-fluids param:unparser-list-depth-limit
- *unparser-list-depth-limit*))
-
-(define (get-param:unparser-radix)
- (resolve-fluids param:unparser-radix
- *unparser-radix*))
-
-(define (get-param:unparser-string-length-limit)
- (resolve-fluids param:unparser-string-length-limit
- *unparser-string-length-limit*))
-\f
-(define-record-type <context>
- (make-context port mode environment list-depth in-brackets?
- list-breadth-limit list-depth-limit)
- context?
- (port context-port)
- (mode context-mode)
- (environment context-environment)
- (list-depth context-list-depth)
- (in-brackets? context-in-brackets?)
- (list-breadth-limit context-list-breadth-limit)
- (list-depth-limit context-list-depth-limit))
-
-(define (context-down-list context)
- (make-context (context-port context)
- (context-mode context)
- (context-environment context)
- (+ 1 (context-list-depth context))
- (context-in-brackets? context)
- (context-list-breadth-limit context)
- (context-list-depth-limit context)))
-
-(define (context-in-brackets context)
- (make-context (context-port context)
- (context-mode context)
- (context-environment context)
- 0
- #t
- within-brackets:list-breadth-limit
- within-brackets:list-depth-limit))
-
-(define within-brackets:list-breadth-limit 5)
-(define within-brackets:list-depth-limit 3)
-
-(define (context-slashify? context)
- (eq? 'normal (context-mode context)))
-
-(define (context-char-set context)
- (textual-port-char-set (context-port context)))
-
-(define (make-unparser-state port list-depth slashify? environment)
- (guarantee output-port? port)
- (guarantee environment? environment)
- (guarantee exact-nonnegative-integer? list-depth)
- (make-context port
- (if slashify? 'normal 'display)
- environment
- list-depth
- #f
- (get-param:unparser-list-breadth-limit)
- (get-param:unparser-list-depth-limit)))
-
-(define (with-current-unparser-state context procedure)
- (parameterize* (list (cons initial-context context))
- (lambda ()
- (procedure (context-port context)))))
-
-(define initial-context)
-(add-boot-init!
- (lambda ()
- (set! initial-context (make-unsettable-parameter #f))
- unspecific))
-\f
-;;;; Top Level
-
-(define (unparse-object/top-level object port slashify? environment)
- (guarantee output-port? port)
- (if (not (default-object? environment))
- (guarantee environment? environment))
- (unparse-object (top-level-context port
- (if slashify? 'normal 'display)
- environment)
- object))
-
-(define (top-level-context port mode environment)
- (let ((context (initial-context)))
- (if context
- (make-context port
- mode
- (if (default-object? environment)
- (context-environment context)
- environment)
- (context-list-depth context)
- (context-in-brackets? context)
- (context-list-breadth-limit context)
- (context-list-depth-limit context))
- (make-context port
- mode
- (if (default-object? environment)
- (nearest-repl/environment)
- environment)
- 0
- #f
- (get-param:unparser-list-breadth-limit)
- (get-param:unparser-list-depth-limit)))))
-
-(define (unparser-mode? object)
- (or (eq? 'normal object)
- (eq? 'display object)))
-
-(define (unparse-char context char)
- (guarantee context? context 'unparse-char)
- (write-char char (context-port context)))
-
-(define (unparse-string context string)
- (guarantee context? context 'unparse-string)
- (write-string string (context-port context)))
-
-(define unparse-object)
-(add-boot-init!
- (lambda ()
- (set! unparse-object
- (standard-predicate-dispatcher 'unparse-object 2))
-
- (define-predicate-dispatch-default-handler unparse-object
- (lambda (context object)
- ((vector-ref dispatch-table
- ((ucode-primitive primitive-object-type 1) object))
- object
- context)))
-
- (set! define-unparser-method
- (named-lambda (define-unparser-method predicate unparser)
- (define-predicate-dispatch-handler unparse-object
- (list context? predicate)
- unparser)))
- (run-deferred-boot-actions 'unparser-methods)))
-
-(define-integrable (*unparse-object object context)
- (unparse-object context object))
-\f
-(define dispatch-table)
-(add-boot-init!
- (lambda ()
- (set! dispatch-table
- (make-vector (microcode-type/code-limit) unparse/default))
- (for-each (lambda (entry)
- (vector-set! dispatch-table
- (microcode-type (car entry))
- (cadr entry)))
- `((assignment ,unparse/assignment)
- (bignum ,unparse/number)
- (bytevector ,unparse/bytevector)
- (character ,unparse/character)
- (compiled-entry ,unparse/compiled-entry)
- (complex ,unparse/number)
- (constant ,unparse/constant)
- (definition ,unparse/definition)
- (entity ,unparse/entity)
- (extended-procedure ,unparse/compound-procedure)
- (flonum ,unparse/flonum)
- (interned-symbol ,unparse/interned-symbol)
- (lambda ,unparse/lambda)
- (list ,unparse/pair)
- (negative-fixnum ,unparse/number)
- (false ,unparse/false)
- (positive-fixnum ,unparse/number)
- (primitive ,unparse/primitive-procedure)
- (procedure ,unparse/compound-procedure)
- (promise ,unparse/promise)
- (ratnum ,unparse/number)
- (record ,unparse/record)
- (return-address ,unparse/return-address)
- (string ,unparse/string)
- (tagged-object ,unparse/tagged-object)
- (unicode-string ,unparse/string)
- (uninterned-symbol ,unparse/uninterned-symbol)
- (variable ,unparse/variable)
- (vector ,unparse/vector)
- (vector-1b ,unparse/bit-string)))))
-\f
-;;;; Low Level Operations
-
-(define-integrable (*unparse-char char context)
- (output-port/write-char (context-port context) char))
-
-(define-integrable (*unparse-string string context)
- (output-port/write-string (context-port context) string))
-
-(define-integrable (*unparse-substring string start end context)
- (output-port/write-substring (context-port context) string start end))
-
-(define-integrable (*unparse-datum object context)
- (*unparse-hex (object-datum object) context))
-
-(define (*unparse-hex number context)
- (*unparse-string "#x" context)
- (*unparse-string (number->string number 16) context))
-
-(define-integrable (*unparse-hash object context)
- (*unparse-string (number->string (hash-object object)) context))
-
-(define (*unparse-readable-hash object context)
- (*unparse-string "#@" context)
- (*unparse-hash object context))
-
-(define (allowed-char? char context)
- (char-in-set? char (context-char-set context)))
-
-(define (*unparse-with-brackets name object context procedure)
- (if (or (and (get-param:unparse-with-maximum-readability?) object)
- (context-in-brackets? context))
- (*unparse-readable-hash object context)
- (begin
- (*unparse-string "#[" context)
- (let ((context* (context-in-brackets context)))
- (if (string? name)
- (*unparse-string name context*)
- (*unparse-object name context*))
- (if object
- (begin
- (*unparse-char #\space context*)
- (*unparse-hash object context*)))
- (cond (procedure
- (*unparse-char #\space context*)
- (procedure context*))
- ((get-param:unparse-with-datum?)
- (*unparse-char #\space context*)
- (*unparse-datum object context*))))
- (*unparse-char #\] context))))
-\f
-;;;; Unparser Methods
-
-(define (unparse/default object context)
- (let ((type (user-object-type object)))
- (case (object-gc-type object)
- ((cell pair triple quadruple vector compiled-entry)
- (*unparse-with-brackets type object context #f))
- ((non-pointer)
- (*unparse-with-brackets type object context
- (lambda (context*)
- (*unparse-datum object context*))))
- (else ;UNDEFINED, GC-INTERNAL
- (*unparse-with-brackets type #f context
- (lambda (context*)
- (*unparse-datum object context*)))))))
-
-(define (user-object-type object)
- (let ((type-code (object-type object)))
- (let ((type-name (microcode-type/code->name type-code)))
- (if type-name
- (rename-user-object-type type-name)
- (intern
- (string-append "undefined-type:" (number->string type-code)))))))
-
-(define (rename-user-object-type type-name)
- (let ((entry (assq type-name renamed-user-object-types)))
- (if entry
- (cdr entry)
- type-name)))
-
-(define renamed-user-object-types
- '((negative-fixnum . number)
- (positive-fixnum . number)
- (bignum . number)
- (flonum . number)
- (complex . number)
- (interned-symbol . symbol)
- (uninterned-symbol . symbol)
- (extended-procedure . procedure)
- (primitive . primitive-procedure)
- (lexpr . lambda)
- (extended-lambda . lambda)))
-
-(define (unparse/false object context)
- (if (eq? object #f)
- (*unparse-string "#f" context)
- (unparse/default object context)))
-
-(define (unparse/constant object context)
- (let ((string
- (cond ((null? object) "()")
- ((eq? object #t) "#t")
- ((default-object? object) "#!default")
- ((eof-object? object) "#!eof")
- ((eq? object lambda-tag:aux) "#!aux")
- ((eq? object lambda-tag:key) "#!key")
- ((eq? object lambda-tag:optional) "#!optional")
- ((eq? object lambda-tag:rest) "#!rest")
- ((eq? object unspecific) "#!unspecific")
- (else #f))))
- (if string
- (*unparse-string string context)
- (unparse/default object context))))
-\f
-(define (unparse/interned-symbol symbol context)
- (unparse-symbol symbol context))
-
-(define (unparse/uninterned-symbol symbol context)
- (if (get-param:unparse-uninterned-symbols-by-name?)
- (unparse-symbol-name (symbol->string symbol) context)
- (*unparse-with-brackets 'uninterned-symbol symbol context
- (lambda (context*)
- (*unparse-string (symbol->string symbol) context*)))))
-
-(define (unparse-symbol symbol context)
- (if (keyword? symbol)
- (unparse-keyword-name (keyword->string symbol) context)
- (unparse-symbol-name (symbol->string symbol) context)))
-
-(define (unparse-keyword-name s context)
- (case (param:parser-keyword-style)
- ((prefix)
- (*unparse-char #\: context)
- (unparse-symbol-name s context))
- ((suffix)
- (unparse-symbol-name s context)
- (*unparse-char #\: context))
- (else
- (*unparse-string "#[keyword " context)
- (unparse-symbol-name s context)
- (*unparse-char #\] context))))
-
-(define (unparse-symbol-name s context)
- (if (and (fix:> (string-length s) 0)
- (not (string=? s "."))
- (not (string-prefix? "#" s))
- (char-in-set? (string-ref s 0) char-set:symbol-initial)
- (string-every (symbol-name-no-quoting-predicate context) s)
- (not (case (param:parser-keyword-style)
- ((prefix) (string-prefix? ":" s))
- ((suffix) (string-suffix? ":" s))
- (else #f)))
- (not (string->number s)))
- (*unparse-string s context)
- (begin
- (*unparse-char #\| context)
- (string-for-each (lambda (char)
- (unparse-string-char char context))
- s)
- (*unparse-char #\| context))))
-
-(define (symbol-name-no-quoting-predicate context)
- (conjoin (char-set-predicate
- (if (get-param:parser-fold-case?)
- char-set:folded-symbol-constituent
- char-set:symbol-constituent))
- (lambda (char)
- (allowed-char? char context))))
-\f
-(define (unparse/character char context)
- (cond ((and (param:unparse-char-in-unicode-syntax?)
- (bitless-char? char))
- (*unparse-string "#\\u+" context)
- (*unparse-string (number->string (char->integer char) 16) context))
- ((context-slashify? context)
- (*unparse-string "#\\" context)
- (if (and (char-in-set? char char-set:normal-printing)
- (not (eq? 'separator:space (char-general-category char)))
- (allowed-char? char context))
- (*unparse-char char context)
- (*unparse-string (char->name char) context)))
- (else
- (*unparse-char char context))))
-
-(define (unparse/string string context)
- (if (context-slashify? context)
- (let* ((end (string-length string))
- (end*
- (let ((limit (get-param:unparser-string-length-limit)))
- (if limit
- (min limit end)
- end))))
- (*unparse-char #\" context)
- (do ((index 0 (fix:+ index 1)))
- ((not (fix:< index end*)))
- (unparse-string-char (string-ref string index) context))
- (if (< end* end)
- (*unparse-string "..." context))
- (*unparse-char #\" context))
- (*unparse-string string context)))
-
-(define (unparse-string-char char context)
- (case char
- ((#\bel)
- (*unparse-char #\\ context)
- (*unparse-char #\a context))
- ((#\bs)
- (*unparse-char #\\ context)
- (*unparse-char #\b context))
- ((#\newline)
- (*unparse-char #\\ context)
- (*unparse-char #\n context))
- ((#\return)
- (*unparse-char #\\ context)
- (*unparse-char #\r context))
- ((#\tab)
- (*unparse-char #\\ context)
- (*unparse-char #\t context))
- ((#\\ #\" #\|)
- (*unparse-char #\\ context)
- (*unparse-char char context))
- (else
- (if (and (char-in-set? char char-set:normal-printing)
- (allowed-char? char context))
- (*unparse-char char context)
- (begin
- (*unparse-char #\\ context)
- (*unparse-char #\x context)
- (*unparse-string (number->string (char->integer char) 16) context)
- (*unparse-char #\; context))))))
-
-(define (unparse/bit-string bit-string context)
- (*unparse-string "#*" context)
- (let loop ((index (fix:- (bit-string-length bit-string) 1)))
- (if (fix:>= index 0)
- (begin
- (*unparse-char (if (bit-string-ref bit-string index) #\1 #\0) context)
- (loop (fix:- index 1))))))
-\f
-(define (unparse/vector vector context)
- (let ((unparser (named-vector-with-unparser? vector)))
- (if unparser
- (unparser context vector)
- (limit-unparse-depth context
- (lambda (context*)
- (let ((end (vector-length vector)))
- (if (fix:> end 0)
- (begin
- (*unparse-string "#(" context*)
- (*unparse-object (safe-vector-ref vector 0) context*)
- (let loop ((index 1))
- (if (fix:< index end)
- (if (let ((limit
- (context-list-breadth-limit context*)))
- (and limit
- (>= index limit)))
- (*unparse-string " ...)" context*)
- (begin
- (*unparse-char #\space context*)
- (*unparse-object (safe-vector-ref vector index)
- context*)
- (loop (fix:+ index 1))))))
- (*unparse-char #\) context*))
- (*unparse-string "#()" context*))))))))
-
-(define (safe-vector-ref vector index)
- (if (with-absolutely-no-interrupts
- (lambda ()
- (object-type? (ucode-type manifest-nm-vector)
- (vector-ref vector index))))
- (error "Attempt to unparse partially marked vector."))
- (map-reference-trap (lambda () (vector-ref vector index))))
-
-(define (unparse/bytevector bytevector context)
- (limit-unparse-depth context
- (lambda (context*)
- (let ((end (bytevector-length bytevector)))
- (if (fix:> end 0)
- (begin
- (*unparse-string "#u8(" context*)
- (*unparse-object (bytevector-u8-ref bytevector 0) context*)
- (let loop ((index 1))
- (if (fix:< index end)
- (if (let ((limit (get-param:unparser-list-breadth-limit)))
- (and limit
- (>= index limit)))
- (*unparse-string " ...)" context*)
- (begin
- (*unparse-char #\space context*)
- (*unparse-object (bytevector-u8-ref bytevector index)
- context*)
- (loop (fix:+ index 1))))))
- (*unparse-char #\) context*))
- (*unparse-string "#u8()" context*))))))
-
-(define (unparse/record record context)
- (cond ((string? record) (unparse/string record context))
- ((uri? record) (unparse/uri record context))
- ((get-param:unparse-with-maximum-readability?)
- (*unparse-readable-hash record context))
- (else
- (*unparse-with-brackets 'record record context #f))))
-
-(define (unparse/uri uri context)
- (*unparse-string "#<" context)
- (*unparse-string (uri->string uri) context)
- (*unparse-string ">" context))
-\f
-(define (unparse/pair pair context)
- (cond ((unparse-list/prefix-pair? pair)
- => (lambda (prefix) (unparse-list/prefix-pair prefix pair context)))
- ((and (get-param:unparse-streams?) (stream-pair? pair))
- (unparse-list/stream-pair pair context))
- ((named-list-with-unparser? pair)
- => (lambda (unparser) (unparser context pair)))
- (else
- (unparse-list pair context))))
-
-(define (unparse-list list context)
- (limit-unparse-depth context
- (lambda (context*)
- (*unparse-char #\( context*)
- (*unparse-object (safe-car list) context*)
- (unparse-tail (safe-cdr list) 2 context*)
- (*unparse-char #\) context*))))
-
-(define (limit-unparse-depth context kernel)
- (let ((context* (context-down-list context))
- (limit (context-list-depth-limit context)))
- (if (and limit
- (> (context-list-depth-limit context*) limit))
- (*unparse-string "..." context*)
- (kernel context*))))
-
-(define (unparse-tail l n context)
- (cond ((pair? l)
- (*unparse-char #\space context)
- (*unparse-object (safe-car l) context)
- (if (let ((limit (context-list-breadth-limit context)))
- (and limit
- (>= n limit)
- (pair? (safe-cdr l))))
- (*unparse-string " ..." context)
- (unparse-tail (safe-cdr l) (+ n 1) context)))
- ((not (null? l))
- (*unparse-string " . " context)
- (*unparse-object l context))))
-\f
-(define (unparse-list/prefix-pair prefix pair context)
- (*unparse-string prefix context)
- (*unparse-object (safe-car (safe-cdr pair)) context))
-
-(define (unparse-list/prefix-pair? object)
- (and (get-param:unparse-abbreviate-quotations?)
- (pair? (safe-cdr object))
- (null? (safe-cdr (safe-cdr object)))
- (case (safe-car object)
- ((quote) "'")
- ((quasiquote) "`")
- ((unquote) ",")
- ((unquote-splicing) ",@")
- (else #f))))
-
-(define (unparse-list/stream-pair stream-pair context)
- (limit-unparse-depth context
- (lambda (context*)
- (*unparse-char #\{ context*)
- (*unparse-object (safe-car stream-pair) context*)
- (unparse-stream-tail (safe-cdr stream-pair) 2 context*)
- (*unparse-char #\} context*))))
-
-(define (unparse-stream-tail tail n context)
- (cond ((not (promise? tail))
- (*unparse-string " . " context)
- (*unparse-object tail context))
- ((not (promise-forced? tail))
- (*unparse-string " ..." context))
- (else
- (let ((value (promise-value tail)))
- (cond ((empty-stream? value))
- ((stream-pair? value)
- (*unparse-char #\space context)
- (*unparse-object (safe-car value) context)
- (if (let ((limit (context-list-breadth-limit context)))
- (and limit
- (>= n limit)))
- (*unparse-string " ..." context)
- (unparse-stream-tail (safe-cdr value) (+ n 1) context)))
- (else
- (*unparse-string " . " context)
- (*unparse-object value context)))))))
-
-(define (safe-car pair)
- (map-reference-trap (lambda () (car pair))))
-
-(define (safe-cdr pair)
- (map-reference-trap (lambda () (cdr pair))))
-\f
-;;;; Procedures
-
-(define (unparse/compound-procedure procedure context)
- (*unparse-with-brackets 'compound-procedure procedure context
- (and (get-param:unparse-compound-procedure-names?)
- (lambda-components* (procedure-lambda procedure)
- (lambda (name required optional rest body)
- required optional rest body
- (and (not (eq? name scode-lambda-name:unnamed))
- (lambda (context*)
- (*unparse-object name context*))))))))
-
-(define (unparse/primitive-procedure procedure context)
- (let ((unparse-name
- (lambda (context)
- (*unparse-object (primitive-procedure-name procedure) context))))
- (cond ((get-param:unparse-primitives-by-name?)
- (unparse-name context))
- ((get-param:unparse-with-maximum-readability?)
- (*unparse-readable-hash procedure context))
- (else
- (*unparse-with-brackets 'primitive-procedure #f context
- unparse-name)))))
-
-(define (unparse/compiled-entry entry context)
- (let* ((type (compiled-entry-type entry))
- (procedure? (eq? type 'compiled-procedure))
- (closure?
- (and procedure?
- (compiled-code-block/manifest-closure?
- (compiled-code-address->block entry)))))
- (*unparse-with-brackets (if closure? 'compiled-closure type)
- entry
- context
- (lambda (context*)
- (let ((name (and procedure? (compiled-procedure/name entry))))
- (receive (filename block-number)
- (compiled-entry/filename-and-index entry)
- (*unparse-char #\( context*)
- (if name
- (*unparse-string name context*))
- (if filename
- (begin
- (if name
- (*unparse-char #\space context*))
- (*unparse-object (pathname-name filename) context*)
- (if block-number
- (begin
- (*unparse-char #\space context*)
- (*unparse-hex block-number context*)))))
- (*unparse-char #\) context*)))
- (*unparse-char #\space context*)
- (*unparse-hex (compiled-entry/offset entry) context*)
- (if closure?
- (begin
- (*unparse-char #\space context*)
- (*unparse-datum (compiled-closure->entry entry)
- context*)))
- (*unparse-char #\space context*)
- (*unparse-datum entry context*)))))
-\f
-;;;; Miscellaneous
-
-(define (unparse/return-address return-address context)
- (*unparse-with-brackets 'return-address return-address context
- (lambda (context*)
- (*unparse-object (return-address/name return-address) context*))))
-
-(define (unparse/assignment assignment context)
- (*unparse-with-brackets 'assignment assignment context
- (lambda (context*)
- (*unparse-object (scode-assignment-name assignment) context*))))
-
-(define (unparse/definition definition context)
- (*unparse-with-brackets 'definition definition context
- (lambda (context*)
- (*unparse-object (scode-definition-name definition) context*))))
-
-(define (unparse/lambda lambda-object context)
- (*unparse-with-brackets 'lambda lambda-object context
- (lambda (context*)
- (*unparse-object (scode-lambda-name lambda-object) context*))))
-
-(define (unparse/variable variable context)
- (*unparse-with-brackets 'variable variable context
- (lambda (context*)
- (*unparse-object (scode-variable-name variable) context*))))
-
-(define (unparse/number object context)
- (*unparse-string (number->string
- object
- (let ((prefix
- (lambda (prefix limit radix)
- (if (exact-rational? object)
- (begin
- (if (not (and (exact-integer? object)
- (< (abs object) limit)))
- (*unparse-string prefix context))
- radix)
- 10))))
- (case (get-param:unparser-radix)
- ((2) (prefix "#b" 2 2))
- ((8) (prefix "#o" 8 8))
- ((16) (prefix "#x" 10 16))
- (else 10))))
- context))
-
-(define (unparse/flonum flonum context)
- (if (= (system-vector-length flonum) (system-vector-length 0.0))
- (unparse/number flonum context)
- (unparse/floating-vector flonum context)))
-
-(define (unparse/floating-vector v context)
- (let ((length ((ucode-primitive floating-vector-length) v)))
- (*unparse-with-brackets "floating-vector" v context
- (and (not (zero? length))
- (lambda (context*)
- (let ((limit
- (let ((limit (get-param:unparser-list-breadth-limit)))
- (if limit
- (min length limit)
- length))))
- (unparse/flonum ((ucode-primitive floating-vector-ref) v 0)
- context*)
- (do ((i 1 (+ i 1)))
- ((>= i limit))
- (*unparse-char #\space context*)
- (unparse/flonum ((ucode-primitive floating-vector-ref) v i)
- context*))
- (if (< limit length)
- (*unparse-string " ..." context*))))))))
-\f
-(define (unparse/entity entity context)
-
- (define (plain name)
- (*unparse-with-brackets name entity context #f))
-
- (define (named-arity-dispatched-procedure name)
- (*unparse-with-brackets 'arity-dispatched-procedure entity context
- (lambda (context*)
- (*unparse-string name context*))))
-
- (cond ((continuation? entity)
- (plain 'continuation))
- ((apply-hook? entity)
- (plain 'apply-hook))
- ((arity-dispatched-procedure? entity)
- (let ((proc (%entity-procedure entity)))
- (cond ((and (compiled-code-address? proc)
- (compiled-procedure? proc)
- (compiled-procedure/name proc))
- => named-arity-dispatched-procedure)
- (else (plain 'arity-dispatched-procedure)))))
- ((get-param:unparse-with-maximum-readability?)
- (*unparse-readable-hash entity context))
- (else (plain 'entity))))
-
-(define (unparse/promise promise context)
- (*unparse-with-brackets 'promise promise context
- (if (promise-forced? promise)
- (lambda (context*)
- (*unparse-string "(evaluated) " context*)
- (*unparse-object (promise-value promise) context*))
- (lambda (context*)
- (*unparse-string "(unevaluated)" context*)
- (if (get-param:unparse-with-datum?)
- (begin
- (*unparse-char #\space context*)
- (*unparse-datum promise context*)))))))
-
-(define (unparse/tagged-object object context)
- (*unparse-with-brackets 'tagged-object object context
- (lambda (context*)
- (*unparse-object (let ((tag (%tagged-object-tag object)))
- (if (dispatch-tag? tag)
- (dispatch-tag-name tag)
- tag))
- context*)
- (*unparse-string " " context*)
- (*unparse-object (%tagged-object-datum object) context*))))
\ No newline at end of file
(thread-report flags port)))
(define (ticks->string ticks)
- (parameterize* (list (cons param:flonum-unparser-cutoff '(absolute 3)))
+ (parameterize* (list (cons param:flonum-printer-cutoff '(absolute 3)))
(lambda ()
(number->string (internal-time/ticks->seconds ticks) 10))))
(define (pp-expression form #!optional port)
(parameterize* (list (cons param:pp-primitives-by-name? #f)
(cons param:pp-uninterned-symbols-by-name? #f)
- (cons param:unparse-abbreviate-quotations? #t))
+ (cons param:printer-abbreviate-quotations? #t))
(lambda ()
(pp (cgen/external-with-declarations form) port))))
\ No newline at end of file
(let ((report
(lambda (name time scale)
(parameterize* (list
- (cons param:flonum-unparser-cutoff '(ABSOLUTE 2)))
+ (cons param:flonum-printer-cutoff '(ABSOLUTE 2)))
(lambda ()
(newline)
(write name)
(lambda ()
(define (try n settings . expecteds)
(let ((got
- (parameterize ((param:flonum-unparser-cutoff settings))
+ (parameterize ((param:flonum-printer-cutoff settings))
(number->string (exact->inexact n)))))
(assert-member got expecteds)))
unspecific)))
(read port))))
(assert-false value)
- (assert-equal (port-property port 'parser-file-attributes #f)
+ (assert-equal (port-property port 'reader-file-attributes #f)
expected-properties))))
'expression `(read ,contents)))))
test-cases))
(define (write-expr-property tag p port)
(write-tag tag port)
(write-char #\space port)
- (parameterize* (list (cons param:unparse-abbreviate-quotations? #t))
+ (parameterize* (list (cons param:printer-abbreviate-quotations? #t))
(lambda ()
(write (cdr p) port))))
projects / mit-scheme.git / commitdiff