From 865c0a90089ffe3f8cd5c5ed63dcc6f04147bd07 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 9 May 2018 23:08:35 -0700 Subject: [PATCH] Big refactor: rename parser/unparser to reader/printer. Updated all references and left a couple of renames in place for documented functionality. --- doc/ref-manual/io.texi | 30 +- doc/ref-manual/numbers.texi | 30 +- src/6001/nodefs.scm | 6 +- src/compiler/base/debug.scm | 8 +- src/compiler/base/object.scm | 2 +- src/compiler/base/proced.scm | 3 - src/compiler/base/toplev.scm | 4 +- src/compiler/machines/C/compiler.pkg | 6 +- src/compiler/machines/i386/compiler.pkg | 6 +- src/compiler/machines/i386/dassm1.scm | 4 +- src/compiler/machines/svm/compiler.pkg | 6 +- src/compiler/machines/svm/disassembler.scm | 4 +- src/compiler/machines/x86-64/compiler.pkg | 6 +- src/compiler/machines/x86-64/dassm1.scm | 4 +- src/edwin/artdebug.scm | 11 +- src/edwin/debug.scm | 4 +- src/edwin/edwin.pkg | 2 - src/edwin/evlcom.scm | 6 +- src/edwin/intmod.scm | 2 +- src/edwin/prompt.scm | 2 +- src/edwin/schmod.scm | 4 +- src/etc/find-folded.scm | 2 +- src/etc/ucd-converter.scm | 2 +- src/ffi/cdecls.scm | 2 +- src/imail/imail-util.scm | 2 +- src/runtime/boot.scm | 2 +- src/runtime/debug.scm | 8 +- src/runtime/dragon4.scm | 34 +- src/runtime/ed-ffi.scm | 4 +- src/runtime/error.scm | 4 +- src/runtime/global.scm | 2 +- src/runtime/input-port.scm | 2 +- src/runtime/make.scm | 4 +- src/runtime/output-port.scm | 4 +- src/runtime/pathname.scm | 2 +- src/runtime/pp.scm | 62 +- src/runtime/printer.scm | 871 ++++++++++++++++++++ src/runtime/{parser.scm => reader.scm} | 200 ++--- src/runtime/rep.scm | 6 +- src/runtime/runtime.pkg | 85 +- src/runtime/stack-sample.scm | 8 +- src/runtime/swank.scm | 10 +- src/runtime/unpars.scm | 905 --------------------- src/runtime/world-report.scm | 2 +- src/sf/cgen.scm | 2 +- src/sos/microbench.scm | 2 +- tests/runtime/test-dragon4.scm | 2 +- tests/runtime/test-file-attributes.scm | 2 +- tests/unit-testing.scm | 2 +- 49 files changed, 1165 insertions(+), 1218 deletions(-) create mode 100644 src/runtime/printer.scm rename src/runtime/{parser.scm => reader.scm} (86%) delete mode 100644 src/runtime/unpars.scm diff --git a/doc/ref-manual/io.texi b/doc/ref-manual/io.texi index a6b4ff678..5a0c359a4 100644 --- a/doc/ref-manual/io.texi +++ b/doc/ref-manual/io.texi @@ -595,7 +595,7 @@ signalled. 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 @@ -848,7 +848,7 @@ environments. The global parameters may be dynamically bound by 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 @@ -858,7 +858,7 @@ the parameter is bound to any other value. 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. @@ -866,7 +866,7 @@ 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 @@ -1087,14 +1087,14 @@ performs discretionary output flushing and returns an unspecified value. 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 @@ -1104,11 +1104,11 @@ limit; the default is @code{#f}. @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 ...)" @@ -1116,7 +1116,7 @@ limit; the default is @code{#f}. @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 @@ -1126,11 +1126,11 @@ is @code{#f}. @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)" @@ -1138,7 +1138,7 @@ is @code{#f}. @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 @@ -1148,11 +1148,11 @@ is @code{#f}. @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...\"" @@ -1160,7 +1160,7 @@ is @code{#f}. @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 diff --git a/doc/ref-manual/numbers.texi b/doc/ref-manual/numbers.texi index a61ca83f7..9c4b56765 100644 --- a/doc/ref-manual/numbers.texi +++ b/doc/ref-manual/numbers.texi @@ -950,10 +950,10 @@ the result, and consequently can be tolerated by many applications. @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 @@ -1006,59 +1006,59 @@ symbol @code{normal} may be used, which is equivalent to the list @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." diff --git a/src/6001/nodefs.scm b/src/6001/nodefs.scm index 27920542b..77b5db5bb 100644 --- a/src/6001/nodefs.scm +++ b/src/6001/nodefs.scm @@ -79,8 +79,8 @@ USA. (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)))))))) diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm index 5331e6cc9..655477b71 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -105,15 +105,15 @@ USA. (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*) diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm index 8712258c2..1ff8c1828 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -149,6 +149,6 @@ USA. (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)))) diff --git a/src/compiler/base/proced.scm b/src/compiler/base/proced.scm index 2c38e0383..98f117444 100644 --- a/src/compiler/base/proced.scm +++ b/src/compiler/base/proced.scm @@ -119,9 +119,6 @@ USA. (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)) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index 203c7bb9a..fb9608984 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -1062,8 +1062,8 @@ USA. (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 () diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg index dffae1e75..832581e17 100644 --- a/src/compiler/machines/C/compiler.pkg +++ b/src/compiler/machines/C/compiler.pkg @@ -273,8 +273,6 @@ USA. (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) @@ -294,9 +292,7 @@ USA. 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") diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 3745cb265..429924bd5 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -258,8 +258,6 @@ USA. (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)) @@ -277,9 +275,7 @@ USA. 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") diff --git a/src/compiler/machines/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index c414a3fb2..8132c217d 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -117,7 +117,7 @@ USA. (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) @@ -146,7 +146,7 @@ USA. (loop (instruction-stream))))))) (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))) diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index eec79f61b..5986ef3d4 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -261,8 +261,6 @@ USA. (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)) @@ -280,9 +278,7 @@ USA. 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") diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index 71311302f..fd299c717 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -110,7 +110,7 @@ USA. (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 () @@ -219,7 +219,7 @@ USA. #t))))) (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 diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg index de99afe58..e9879bf3a 100644 --- a/src/compiler/machines/x86-64/compiler.pkg +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -261,8 +261,6 @@ USA. (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)) @@ -280,9 +278,7 @@ USA. 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") diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index 84f045f6c..6401673b0 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -117,7 +117,7 @@ USA. (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) @@ -146,7 +146,7 @@ USA. (loop (instruction-stream))))))) (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))) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index 56d947357..df8024479 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -974,9 +974,10 @@ Prefix argument means do not kill the debugger buffer." (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) @@ -1014,7 +1015,7 @@ Prefix argument means do not kill the debugger buffer." 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)) @@ -1044,7 +1045,7 @@ Prefix argument means do not kill the debugger buffer." 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)) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index fc8d1e7de..84d7a0b32 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -1290,7 +1290,7 @@ it has been renamed, it will not be deleted automatically.") (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (parameterize* (list (cons param:unparse-primitives-by-name? + (parameterize* (list (cons param:print-primitives-by-name? #t)) (lambda () (write @@ -1382,7 +1382,7 @@ it has been renamed, it will not be deleted automatically.") (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))))) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index ac19b4421..a572031cc 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -113,8 +113,6 @@ USA. (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) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index 7634633ca..969b2ca9b 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -234,7 +234,7 @@ The values are printed in the typein window." (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))))) @@ -535,9 +535,9 @@ Set by Scheme evaluation code to update the mode line." (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))))) diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm index bff038162..7adec4590 100644 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@ -731,7 +731,7 @@ If this is an error, the debugger examines the error condition." (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))) diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index 946cf374c..85a59e7a1 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -979,7 +979,7 @@ it is added to the front of the command history." (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)))) diff --git a/src/edwin/schmod.scm b/src/edwin/schmod.scm index 3d6e28d27..748872755 100644 --- a/src/edwin/schmod.scm +++ b/src/edwin/schmod.scm @@ -266,7 +266,7 @@ The following commands evaluate Scheme expressions: (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? @@ -360,7 +360,7 @@ Otherwise, it is shown in the echo area." (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: " diff --git a/src/etc/find-folded.scm b/src/etc/find-folded.scm index 5d15f0bb1..1c0c82c5e 100644 --- a/src/etc/find-folded.scm +++ b/src/etc/find-folded.scm @@ -31,7 +31,7 @@ (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)))))) diff --git a/src/etc/ucd-converter.scm b/src/etc/ucd-converter.scm index 09e583264..ded56e479 100644 --- a/src/etc/ucd-converter.scm +++ b/src/etc/ucd-converter.scm @@ -559,7 +559,7 @@ USA. (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) diff --git a/src/ffi/cdecls.scm b/src/ffi/cdecls.scm index 23e3f6ec4..c8373b5e3 100644 --- a/src/ffi/cdecls.scm +++ b/src/ffi/cdecls.scm @@ -91,7 +91,7 @@ USA. (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)) diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm index 6ffce1036..4a80089e3 100644 --- a/src/imail/imail-util.scm +++ b/src/imail/imail-util.scm @@ -249,7 +249,7 @@ USA. (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)))))) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 73a960fd8..0b0d10c0a 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -321,7 +321,7 @@ USA. (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)) diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index e4778af98..928568f48 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -474,7 +474,7 @@ USA. (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) @@ -956,11 +956,11 @@ using the read-eval-print environment instead.") (string-titlecase (if reason (string-append reason "; " message) message))) (define (debugger-pp expression indentation port) - (parameterize* (list (cons param: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)))) diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm index 37dca0f02..8667bb51a 100644 --- a/src/runtime/dragon4.scm +++ b/src/runtime/dragon4.scm @@ -44,13 +44,13 @@ not much different to numbers within a few orders of magnitude of 1. (declare (usual-integrations)) -(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) @@ -71,7 +71,7 @@ not much different to numbers within a few orders of magnitude of 1. (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) @@ -84,8 +84,8 @@ not much different to numbers within a few orders of magnitude of 1. (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) @@ -102,7 +102,7 @@ not much different to numbers within a few orders of magnitude of 1. (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))) @@ -121,10 +121,10 @@ not much different to numbers within a few orders of magnitude of 1. (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) @@ -144,24 +144,24 @@ not much different to numbers within a few orders of magnitude of 1. "e" exponent))))) -(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) @@ -188,9 +188,9 @@ not much different to numbers within a few orders of magnitude of 1. (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) diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index df65756d5..7d869630a 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -119,7 +119,6 @@ USA. ("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)) @@ -128,6 +127,7 @@ USA. ("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)) @@ -136,6 +136,7 @@ USA. ("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)) @@ -178,7 +179,6 @@ USA. ("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)) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index b5faa6148..34eaa756f 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -1295,8 +1295,8 @@ USA. (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) diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 4dda86f43..27e88e9ea 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -279,7 +279,7 @@ USA. ((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))) diff --git a/src/runtime/input-port.scm b/src/runtime/input-port.scm index 23ae90266..97d332cbf 100644 --- a/src/runtime/input-port.scm +++ b/src/runtime/input-port.scm @@ -181,7 +181,7 @@ USA. (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)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index f298d2c45..777fa4300 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -522,10 +522,10 @@ USA. ;; 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) diff --git a/src/runtime/output-port.scm b/src/runtime/output-port.scm index babe04778..64dc162f7 100644 --- a/src/runtime/output-port.scm +++ b/src/runtime/output-port.scm @@ -53,7 +53,7 @@ USA. ((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))) @@ -133,7 +133,7 @@ USA. (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) diff --git a/src/runtime/pathname.scm b/src/runtime/pathname.scm index 5c5195ec0..317234281 100644 --- a/src/runtime/pathname.scm +++ b/src/runtime/pathname.scm @@ -726,4 +726,4 @@ these rules: (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 diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 5bed211dd..51428a18d 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -308,11 +308,11 @@ USA. (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?) @@ -733,7 +733,7 @@ USA. (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) @@ -743,7 +743,7 @@ USA. (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 @@ -757,16 +757,16 @@ USA. ((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 @@ -784,24 +784,22 @@ USA. (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)))))) (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))) @@ -819,7 +817,7 @@ USA. "." (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))) @@ -844,14 +842,14 @@ USA. (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) @@ -889,7 +887,7 @@ USA. (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 @@ -903,7 +901,7 @@ USA. (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) @@ -913,7 +911,7 @@ USA. 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 @@ -922,14 +920,14 @@ USA. ((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)))) ;;; 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))) @@ -937,7 +935,7 @@ USA. (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))) @@ -979,7 +977,7 @@ USA. "." (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))) @@ -996,14 +994,14 @@ USA. half-pointer/queue list-depth))))))))))))))) (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))) diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm new file mode 100644 index 000000000..19d39cdf8 --- /dev/null +++ b/src/runtime/printer.scm @@ -0,0 +1,871 @@ +#| -*-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)) + +(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) + +(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*)) + +(define-record-type + (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)) + +;;;; 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))) + +(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))))) + +;;;; 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)))) + +;;;; 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)))) + +(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)))) + +(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)))))) + +(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)) + +(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)))) + +(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)))) + +;;;; 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*))))) + +;;;; 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*)))))))) + +(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 diff --git a/src/runtime/parser.scm b/src/runtime/reader.scm similarity index 86% rename from src/runtime/parser.scm rename to src/runtime/reader.scm index 2ef23a928..5c7fd7f16 100644 --- a/src/runtime/parser.scm +++ b/src/runtime/reader.scm @@ -24,8 +24,8 @@ USA. |# -;;;; Scheme Parser -;;; package: (runtime parser) +;;;; Scheme Reader +;;; package: (runtime reader) (declare (usual-integrations)) @@ -36,45 +36,45 @@ USA. (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*)) -(define (parse-object port) +(define (read-top-level port) (let ((read-operation (textual-port-operation port 'read))) (if read-operation (read-operation port) @@ -85,7 +85,7 @@ USA. (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 @@ -100,23 +100,23 @@ USA. (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))) @@ -128,7 +128,7 @@ USA. (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) @@ -339,14 +339,14 @@ USA. (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) (define (start-attributes-comment db) (and (db-enable-attributes? db) @@ -361,8 +361,8 @@ USA. (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)) @@ -424,14 +424,14 @@ USA. (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) @@ -453,14 +453,14 @@ USA. (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 () @@ -507,7 +507,7 @@ USA. (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))) @@ -530,7 +530,7 @@ USA. (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)) @@ -548,7 +548,7 @@ USA. (default-method (lambda (objects lose) (if (pair? (cdr objects)) - (parse-unhash (cadr objects)) + (read-unhash (cadr objects)) (lose)))) (method (and (pair? objects) @@ -570,9 +570,9 @@ USA. (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 @@ -580,7 +580,7 @@ USA. (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 @@ -590,7 +590,7 @@ USA. ;; 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) @@ -616,13 +616,13 @@ USA. (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))) -(define (parse-delimited-string db delimiter allow-newline-escape?) +(define (read-delimited-string db delimiter allow-newline-escape?) (let ((builder (string-builder))) (define (loop) @@ -630,17 +630,17 @@ USA. (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) @@ -654,7 +654,7 @@ USA. ((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) @@ -668,7 +668,7 @@ USA. (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) @@ -679,13 +679,13 @@ USA. (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)) @@ -699,7 +699,7 @@ USA. (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))) @@ -707,7 +707,7 @@ USA. (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))) @@ -715,7 +715,7 @@ USA. (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 @@ -736,7 +736,7 @@ USA. (%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)) @@ -758,7 +758,7 @@ USA. (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) @@ -771,10 +771,10 @@ USA. ((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))))) @@ -848,7 +848,7 @@ USA. (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) @@ -873,16 +873,16 @@ USA. (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)) @@ -891,15 +891,15 @@ USA. (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)) (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)) @@ -918,13 +918,13 @@ USA. (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))))))) @@ -964,24 +964,24 @@ USA. (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))))))) -(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 @@ -992,7 +992,7 @@ USA. (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 @@ -1006,27 +1006,27 @@ USA. 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) @@ -1038,70 +1038,70 @@ USA. (cdr objects)))) (write-string "]" port))) -(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 diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 9a8301591..ac769e27b 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -546,9 +546,9 @@ USA. (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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 3d9759527..fec7653c7 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3259,6 +3259,10 @@ USA. (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+) @@ -3334,10 +3338,10 @@ USA. 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 @@ -3350,7 +3354,7 @@ USA. non-positive? number->string odd? - param:flonum-unparser-cutoff + param:flonum-printer-cutoff quotient remainder square) @@ -3397,30 +3401,31 @@ USA. 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") @@ -3794,7 +3799,7 @@ USA. (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!))) @@ -4823,8 +4828,8 @@ USA. 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?* @@ -4839,34 +4844,32 @@ USA. *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 ))) diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index e14898c1d..41a7fab79 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -397,10 +397,10 @@ (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 () diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index be1d11289..155c02a00 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -772,7 +772,7 @@ swank:xref (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 @@ -848,7 +848,7 @@ swank:xref (define (all-completions prefix environment) (let ((prefix - (if (get-param:parser-fold-case?) + (if (get-param:reader-fold-case?) (string-downcase prefix) prefix)) (completions '())) @@ -1131,9 +1131,9 @@ swank:xref (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)))))) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm deleted file mode 100644 index e6ab9fc2c..000000000 --- a/src/runtime/unpars.scm +++ /dev/null @@ -1,905 +0,0 @@ -#| -*-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)) - -(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) - -(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*)) - -(define-record-type - (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)) - -;;;; 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)) - -(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))))) - -;;;; 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)))) - -;;;; 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)))) - -(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)))) - -(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)))))) - -(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)) - -(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)))) - -(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)))) - -;;;; 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*))))) - -;;;; 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*)))))))) - -(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 diff --git a/src/runtime/world-report.scm b/src/runtime/world-report.scm index 52b2519b0..5aab41762 100644 --- a/src/runtime/world-report.scm +++ b/src/runtime/world-report.scm @@ -57,7 +57,7 @@ USA. (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)))) diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index 6825765c1..6606d43f5 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -248,6 +248,6 @@ USA. (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 diff --git a/src/sos/microbench.scm b/src/sos/microbench.scm index 18c01e772..8feff4188 100644 --- a/src/sos/microbench.scm +++ b/src/sos/microbench.scm @@ -263,7 +263,7 @@ USA. (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) diff --git a/tests/runtime/test-dragon4.scm b/tests/runtime/test-dragon4.scm index 376ce295a..f1cbb0cb1 100644 --- a/tests/runtime/test-dragon4.scm +++ b/tests/runtime/test-dragon4.scm @@ -32,7 +32,7 @@ USA. (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))) diff --git a/tests/runtime/test-file-attributes.scm b/tests/runtime/test-file-attributes.scm index f83ca7337..924621bd1 100644 --- a/tests/runtime/test-file-attributes.scm +++ b/tests/runtime/test-file-attributes.scm @@ -132,7 +132,7 @@ This file is part of MIT/GNU Scheme. 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)) diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index 28f914bfb..6e28ef727 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -284,7 +284,7 @@ USA. (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)))) -- 2.25.1