From ff99bd4452b27ee9bedcbdc2405ec7163ed32f4a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 28 Feb 2016 00:24:44 -0800 Subject: [PATCH] Fix parameterization in pp.scm. --- src/6001/make.scm | 4 +- src/compiler/base/debug.scm | 2 +- src/compiler/machines/C/compiler.pkg | 2 - src/compiler/machines/alpha/compiler.pkg | 2 - src/compiler/machines/bobcat/compiler.pkg | 2 - src/compiler/machines/i386/compiler.pkg | 2 - src/compiler/machines/mips/compiler.pkg | 2 - src/compiler/machines/spectrum/compiler.pkg | 2 - src/compiler/machines/svm/compiler.pkg | 2 - src/compiler/machines/vax/compiler.pkg | 2 - src/compiler/machines/x86-64/compiler.pkg | 2 - src/edwin/artdebug.scm | 3 +- src/edwin/debug.scm | 10 +- src/pcsample/pcsdisp.scm | 2 +- src/runtime/pp.scm | 161 ++++++++++++++------ src/runtime/runtime.pkg | 10 ++ src/runtime/stack-sample.scm | 4 +- src/sf/cgen.scm | 4 +- 18 files changed, 140 insertions(+), 78 deletions(-) diff --git a/src/6001/make.scm b/src/6001/make.scm index 8cd6fe0b2..9ee440bc3 100644 --- a/src/6001/make.scm +++ b/src/6001/make.scm @@ -39,8 +39,8 @@ USA. ;;; Customize the runtime system: (set! repl:allow-restart-notifications? #f) (set! repl:write-result-hash-numbers? #f) -(*pp-default-as-code?* #t) -(*pp-named-lambda->define?* 'LAMBDA) +(param:pp-default-as-code? #t) +(param:pp-named-lambda->define? 'LAMBDA) (set! x-graphics:auto-raise? #t) (set! (access write-result:undefined-value-is-special? (->environment '(RUNTIME USER-INTERFACE))) diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm index dbe10b2e1..c4e490133 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -111,7 +111,7 @@ USA. (define (pp-instructions thunk) (fluid-let ((*show-instruction* pretty-print)) - (parameterize* (list (cons *pp-primitives-by-name* #f) + (parameterize* (list (cons param:pp-primitives-by-name? #f) (cons param:unparser-radix 16) (cons param:unparse-uninterned-symbols-by-name? #t)) thunk))) diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg index 92c3906cb..459baff99 100644 --- a/src/compiler/machines/C/compiler.pkg +++ b/src/compiler/machines/C/compiler.pkg @@ -305,8 +305,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/alpha/compiler.pkg b/src/compiler/machines/alpha/compiler.pkg index 50314a077..11313de50 100644 --- a/src/compiler/machines/alpha/compiler.pkg +++ b/src/compiler/machines/alpha/compiler.pkg @@ -262,8 +262,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/bobcat/compiler.pkg b/src/compiler/machines/bobcat/compiler.pkg index 5effd1c62..624d7b887 100644 --- a/src/compiler/machines/bobcat/compiler.pkg +++ b/src/compiler/machines/bobcat/compiler.pkg @@ -268,8 +268,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 503ba51a6..6e14f0414 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -291,8 +291,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/mips/compiler.pkg b/src/compiler/machines/mips/compiler.pkg index ee0e0c62c..e1064d6a4 100644 --- a/src/compiler/machines/mips/compiler.pkg +++ b/src/compiler/machines/mips/compiler.pkg @@ -268,8 +268,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/spectrum/compiler.pkg b/src/compiler/machines/spectrum/compiler.pkg index 7cc516c96..1cd820bcc 100644 --- a/src/compiler/machines/spectrum/compiler.pkg +++ b/src/compiler/machines/spectrum/compiler.pkg @@ -272,8 +272,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index e04381a85..a8535c1d7 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -299,8 +299,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/vax/compiler.pkg b/src/compiler/machines/vax/compiler.pkg index d59147146..6ca510f37 100644 --- a/src/compiler/machines/vax/compiler.pkg +++ b/src/compiler/machines/vax/compiler.pkg @@ -263,8 +263,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg index 24c1849f3..9455f7f37 100644 --- a/src/compiler/machines/x86-64/compiler.pkg +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -291,8 +291,6 @@ USA. show-fg-node show-rtl write-rtl-instructions) - (import (runtime pretty-printer) - *pp-primitives-by-name*) (import (runtime unparser) param:unparse-uninterned-symbols-by-name?)) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index 32d7552e7..be38f9f58 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -681,7 +681,8 @@ Move to the last subproblem if the subproblem number is too high." (if (or argument (invalid-subexpression? sub)) (pp exp) - (parameterize* (list (cons *pp-no-highlights?* #f)) + (parameterize* (list (cons param:pp-no-highlights? + #f)) do-hairy))) ((debugging-info/noise? exp) (message ((debugging-info/noise exp) #t))) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index a309884e1..e03527d0a 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -46,10 +46,10 @@ USA. (highlight-region (make-region start end) (default-face))) (define (debugger-pp-highlight-subexpression expression subexpression - indentation port) + indentation port) (let ((start-mark #f) - (end-mark #f)) - (parameterize* (list (cons *pp-no-highlights?* #f)) + (end-mark #f)) + (parameterize* (list (cons param:pp-no-highlights? #f)) (lambda () (debugger-pp (unsyntax-with-substitutions @@ -70,7 +70,7 @@ USA. indentation port))) (if (and start-mark end-mark) - (highlight-region-excluding-indentation + (highlight-region-excluding-indentation (make-region start-mark end-mark) (highlight-face))) (if start-mark (mark-temporary! start-mark)) @@ -1586,7 +1586,7 @@ once it has been renamed, it will not be deleted automatically.") (else (let ((separator " = ")) (write-string separator port) - (let ((indentation + (let ((indentation (+ (string-length name1) (string-length separator)))) (write-string (string-tail diff --git a/src/pcsample/pcsdisp.scm b/src/pcsample/pcsdisp.scm index 9d33c59f7..705f3f084 100644 --- a/src/pcsample/pcsdisp.scm +++ b/src/pcsample/pcsdisp.scm @@ -142,7 +142,7 @@ USA. (define (display-sample-list sample-list) ; not integrated so can play w/ it ;; for now: just pp as code, but maybe opt for wizzy graphics later - (parameterize* (list (cons *pp-default-as-code?* #t) + (parameterize* (list (cons param:pp-default-as-code? #t) (lambda () ; (pp sample-list)))) diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index e39f320f5..117601946 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -29,18 +29,37 @@ USA. (declare (usual-integrations)) +(define param:pp-arity-dispatched-procedure-style) +(define param:pp-auto-highlighter) +(define param:pp-avoid-circularity?) +(define param:pp-default-as-code?) +(define param:pp-forced-x-size) +(define param:pp-lists-as-tables?) +(define param:pp-named-lambda->define?) +(define param:pp-no-highlights?) +(define param:pp-primitives-by-name?) +(define param:pp-save-vertical-space?) +(define param:pp-uninterned-symbols-by-name?) + (define (initialize-package!) - (set! *pp-named-lambda->define?* (make-parameter #f)) - (set! *pp-primitives-by-name* (make-parameter #t)) - (set! *pp-uninterned-symbols-by-name* (make-parameter #t)) - (set! *pp-no-highlights?* (make-parameter #t)) - (set! *pp-save-vertical-space?* (make-parameter #f)) - (set! *pp-lists-as-tables?* (make-parameter #t)) - (set! *pp-forced-x-size* (make-parameter #f)) - (set! *pp-avoid-circularity?* (make-parameter #f)) - (set! *pp-default-as-code?* (make-parameter #t)) - (set! *pp-auto-highlighter* (make-parameter #f)) - (set! *pp-arity-dispatched-procedure-style* (make-parameter 'FULL)) + ;; Controls the appearance of procedures in the CASE statement used + ;; to describe an arity dispatched procedure: + ;; FULL: full bodies of procedures + ;; NAMED: just name if the procedure is a named lambda, like FULL if unnamed + ;; SHORT: procedures appear in #[...] unparser syntax + (set! param:pp-arity-dispatched-procedure-style + (make-settable-parameter 'FULL)) + (set! param:pp-auto-highlighter (make-settable-parameter #f)) + (set! param:pp-avoid-circularity? (make-settable-parameter #f)) + (set! param:pp-default-as-code? (make-settable-parameter #t)) + (set! param:pp-forced-x-size (make-settable-parameter #f)) + (set! param:pp-lists-as-tables? (make-settable-parameter #t)) + (set! param:pp-named-lambda->define? (make-settable-parameter #f)) + (set! param:pp-no-highlights? (make-settable-parameter #t)) + (set! param:pp-primitives-by-name? (make-settable-parameter #t)) + (set! param:pp-save-vertical-space? (make-settable-parameter #f)) + (set! param:pp-uninterned-symbols-by-name? (make-settable-parameter #t)) + (set! x-size (make-parameter #f)) (set! output-port (make-parameter #f)) (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION)) @@ -72,18 +91,74 @@ USA. (set! dispatch-default (make-parameter print-combination)) (set! cocked-object (generate-uninterned-symbol)) unspecific) - -(define *pp-named-lambda->define?*) -(define *pp-primitives-by-name*) -(define *pp-uninterned-symbols-by-name*) -(define *pp-no-highlights?*) -(define *pp-save-vertical-space?*) -(define *pp-lists-as-tables?*) -(define *pp-forced-x-size*) -(define *pp-avoid-circularity?*) -(define *pp-default-as-code?*) -(define *pp-auto-highlighter*) - + +(define *pp-arity-dispatched-procedure-style* #!default) +(define *pp-auto-highlighter* #!default) +(define *pp-avoid-circularity?* #!default) +(define *pp-default-as-code?* #!default) +(define *pp-forced-x-size* #!default) +(define *pp-lists-as-tables?* #!default) +(define *pp-named-lambda->define?* #!default) +(define *pp-no-highlights?* #!default) +(define *pp-primitives-by-name* #!default) +(define *pp-save-vertical-space?* #!default) +(define *pp-uninterned-symbols-by-name* #!default) + +(define (get-param:pp-arity-dispatched-procedure-style) + (if (default-object? *pp-arity-dispatched-procedure-style*) + (param:pp-arity-dispatched-procedure-style) + *pp-arity-dispatched-procedure-style*)) + +(define (get-param:pp-named-lambda->define?) + (if (default-object? *pp-named-lambda->define?*) + (param:pp-named-lambda->define?) + *pp-named-lambda->define?*)) + +(define (get-param:pp-primitives-by-name?) + (if (default-object? *pp-primitives-by-name*) + (param:pp-primitives-by-name?) + *pp-primitives-by-name*)) + +(define (get-param:pp-uninterned-symbols-by-name?) + (if (default-object? *pp-uninterned-symbols-by-name*) + (param:pp-uninterned-symbols-by-name?) + *pp-uninterned-symbols-by-name*)) + +(define (get-param:pp-no-highlights?) + (if (default-object? *pp-no-highlights?*) + (param:pp-no-highlights?) + *pp-no-highlights?*)) + +(define (get-param:pp-save-vertical-space?) + (if (default-object? *pp-save-vertical-space?*) + (param:pp-save-vertical-space?) + *pp-save-vertical-space?*)) + +(define (get-param:pp-lists-as-tables?) + (if (default-object? *pp-lists-as-tables?*) + (param:pp-lists-as-tables?) + *pp-lists-as-tables?*)) + +(define (get-param:pp-forced-x-size) + (if (default-object? *pp-forced-x-size*) + (param:pp-forced-x-size) + *pp-forced-x-size*)) + +(define (get-param:pp-avoid-circularity?) + (if (default-object? *pp-avoid-circularity?*) + (param:pp-avoid-circularity?) + *pp-avoid-circularity?*)) + +(define (get-param:pp-default-as-code?) + (if (default-object? *pp-default-as-code?*) + (param:pp-default-as-code?) + *pp-default-as-code?*)) + +(define (get-param:pp-auto-highlighter) + (if (default-object? *pp-auto-highlighter*) + (param:pp-auto-highlighter) + *pp-auto-highlighter*)) + (define (pp object #!optional port . rest) (let ((port (if (default-object? port) (current-output-port) port))) (let ((pretty-print @@ -120,16 +195,9 @@ USA. (else #f))) -;;; Controls the appearance of procedures in the CASE statement used -;;; to describe an arity dispatched procedure: -;;; FULL: full bodies of procedures -;;; NAMED: just name if the procedure is a named lambda, like FULL if unnamed -;;; SHORT: procedures appear in #[...] unparser syntax -(define *pp-arity-dispatched-procedure-style*) - (define (unsyntax-entity object) (define (unsyntax-entry procedure) - (case (*pp-arity-dispatched-procedure-style*) + (case (get-param:pp-arity-dispatched-procedure-style) ((FULL) (unsyntax-entity procedure)) ((NAMED) (let ((text (unsyntax-entity procedure))) @@ -166,7 +234,7 @@ USA. (define (pretty-print object #!optional port as-code? indentation) (let ((as-code? (if (default-object? as-code?) - (let ((default (*pp-default-as-code?*))) + (let ((default (get-param:pp-default-as-code?))) (if (boolean? default) default (not (scode-constant? object)))) @@ -178,9 +246,9 @@ USA. (if (and as-code? (pair? sexp) (eq? (car sexp) 'NAMED-LAMBDA) - (*pp-named-lambda->define?*)) + (get-param:pp-named-lambda->define?)) (if (and (eq? 'LAMBDA - (*pp-named-lambda->define?*)) + (get-param:pp-named-lambda->define?)) (pair? (cdr sexp)) (pair? (cadr sexp))) `(LAMBDA ,(cdadr sexp) ,@(cddr sexp)) @@ -231,17 +299,18 @@ USA. (define (pp-top-level expression port as-code? indentation list-depth) (parameterize* (list (cons x-size - (- (or (*pp-forced-x-size*) - (output-port/x-size port)) 1)) + (- (or (get-param:pp-forced-x-size) + (output-port/x-size port)) + 1)) (cons output-port port) (cons param:unparse-uninterned-symbols-by-name? - (*pp-uninterned-symbols-by-name*)) + (get-param:pp-uninterned-symbols-by-name?)) (cons param:unparse-abbreviate-quotations? (or as-code? (param:unparse-abbreviate-quotations?)))) (lambda () (let* ((numerical-walk - (if (*pp-avoid-circularity?*) + (if (get-param:pp-avoid-circularity?) numerical-walk-avoid-circularities numerical-walk)) (node (numerical-walk expression list-depth))) @@ -276,7 +345,7 @@ USA. (define (print-non-code-node node column depth) (parameterize* (list (cons dispatch-list '()) (cons dispatch-default - (if (*pp-lists-as-tables?*) + (if (get-param:pp-lists-as-tables?) print-data-table print-data-column))) (lambda () @@ -332,7 +401,7 @@ USA. (*unparse-string node)))) (define (print-list-node node column depth) - (if (and (*pp-save-vertical-space?*) + (if (and (get-param:pp-save-vertical-space?) (fits-within? node column depth)) (print-guaranteed-list-node node) (let* ((subnodes (node-subnodes node)) @@ -662,7 +731,7 @@ USA. (walk-custom unparser object list-depth) (walk-pair object list-depth)))))) ((symbol? object) - (if (or (*pp-uninterned-symbols-by-name*) + (if (or (get-param:pp-uninterned-symbols-by-name?) (interned-symbol? object)) object (walk-custom unparse-object object list-depth))) @@ -686,7 +755,7 @@ USA. (walk-pair (vector->list object) list-depth)))))) ((primitive-procedure? object) - (if (*pp-primitives-by-name*) + (if (get-param:pp-primitives-by-name?) (primitive-procedure-name object) (walk-custom unparse-object object list-depth))) (else @@ -699,7 +768,7 @@ USA. ;; otherwise we would get infinite recursion when the `unwrapped' ;; object REST is re-auto-highlighted by the test below. - (cond ((let ((highlighter (*pp-auto-highlighter*))) + (cond ((let ((highlighter (get-param:pp-auto-highlighter))) (and highlighter (not (pretty-printer-highlight? object)) (highlighter object))) @@ -753,7 +822,7 @@ USA. list-depth))))))))))))) (define-integrable (no-highlights? object) - (or (*pp-no-highlights?*) + (or (get-param:pp-no-highlights?) (not (partially-highlighted? object)))) (define (partially-highlighted? object) @@ -828,7 +897,7 @@ USA. (walk-pair-terminating object half-pointer/queue list-depth)))))) ((symbol? object) - (if (or (*pp-uninterned-symbols-by-name*) + (if (or (get-param:pp-uninterned-symbols-by-name?) (interned-symbol? object)) object (walk-custom unparse-object object list-depth))) @@ -851,7 +920,7 @@ USA. (vector->list object) half-pointer/queue list-depth)))))) ((primitive-procedure? object) - (if (*pp-primitives-by-name*) + (if (get-param:pp-primitives-by-name?) (primitive-procedure-name object) (walk-custom unparse-object object list-depth))) (else diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 5a2c28574..d729778b6 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3260,6 +3260,16 @@ USA. *pp-save-vertical-space?* *pp-uninterned-symbols-by-name* make-pretty-printer-highlight + param:pp-named-lambda->define? + param:pp-primitives-by-name? + param:pp-uninterned-symbols-by-name? + param:pp-no-highlights? + param:pp-save-vertical-space? + param:pp-lists-as-tables? + param:pp-forced-x-size + param:pp-avoid-circularity? + param:pp-default-as-code? + param:pp-auto-highlighter pp pp-description pretty-print) diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index b8a0e25da..daa4f28c9 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -401,7 +401,7 @@ (cons param:unparser-list-depth-limit 3) (cons param:unparser-string-length-limit 40) (cons param:unparse-primitives-by-name? #t) - (cons *pp-save-vertical-space?* #t) - (cons *pp-default-as-code?* #t)) + (cons param:pp-save-vertical-space? #t) + (cons param:pp-default-as-code? #t)) (lambda () (pp expression output-port)))) \ No newline at end of file diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index f145c8837..635a349fc 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -243,8 +243,8 @@ USA. ;;; Debugging utility (define (pp-expression form #!optional port) - (parameterize* (list (cons *pp-primitives-by-name* #f) - (cons *pp-uninterned-symbols-by-name* #f) + (parameterize* (list (cons param:pp-primitives-by-name? #f) + (cons param:pp-uninterned-symbols-by-name? #f) (cons param:unparse-abbreviate-quotations? #t)) (lambda () (pp (cgen/external-with-declarations form) port)))) \ No newline at end of file -- 2.25.1