From: Matt Birkholz Date: Mon, 3 Feb 2014 23:42:59 +0000 (-0700) Subject: Fluidize *pp-...*, i.e. *pp-default-as-code?*,... X-Git-Tag: mit-scheme-pucked-9.2.12~401^2~22 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dfa196d1c4be97760adffbe438c5c14cace578a1;p=mit-scheme.git Fluidize *pp-...*, i.e. *pp-default-as-code?*,... ... *pp-named-lambda->define?*, *pp-primitives-by-name*, *pp-uninterned-symbols-by-name*, *pp-no-highlights?*, *pp-save-vertical-space?*, *pp-lists-as-tables?*, *pp-forced-x-size*, *pp-avoid-circularity?*, *pp-auto-highlighter*, and *pp-arity-dispatched-procedure-style*. --- diff --git a/src/6001/make.scm b/src/6001/make.scm index e5119633f..607ea7487 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) -(set! *pp-default-as-code?* #t) -(set! *pp-named-lambda->define?* 'LAMBDA) +(set-fluid! *pp-default-as-code?* #t) +(set-fluid! *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 114b8c8fa..abe5003b8 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -110,9 +110,9 @@ USA. thunk))) (define (pp-instructions thunk) - (fluid-let ((*show-instruction* pretty-print) - (*pp-primitives-by-name* #f)) - (let-fluids *unparser-radix* 16 + (fluid-let ((*show-instruction* pretty-print)) + (let-fluids *pp-primitives-by-name* #f + *unparser-radix* 16 *unparse-uninterned-symbols-by-name?* #t thunk))) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index d2ccb48f9..be55ffc86 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -681,8 +681,8 @@ Move to the last subproblem if the subproblem number is too high." (if (or argument (invalid-subexpression? sub)) (pp exp) - (fluid-let ((*pp-no-highlights?* #f)) - (do-hairy)))) + (let-fluid *pp-no-highlights?* #f + do-hairy))) ((debugging-info/noise? exp) (message ((debugging-info/noise exp) #t))) (else diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index 1dc72cd9a..2f049e345 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -49,25 +49,26 @@ USA. indentation port) (let ((start-mark #f) (end-mark #f)) - (fluid-let ((*pp-no-highlights?* #f)) - (debugger-pp - (unsyntax-with-substitutions - expression - (list (cons subexpression - (make-pretty-printer-highlight - (unsyntax subexpression) - (lambda (port) - (set! start-mark - (mark-right-inserting-copy - (output-port->mark port))) - unspecific) - (lambda (port) - (set! end-mark - (mark-right-inserting-copy - (output-port->mark port))) - unspecific))))) - indentation - port)) + (let-fluid *pp-no-highlights?* #f + (lambda () + (debugger-pp + (unsyntax-with-substitutions + expression + (list (cons subexpression + (make-pretty-printer-highlight + (unsyntax subexpression) + (lambda (port) + (set! start-mark + (mark-right-inserting-copy + (output-port->mark port))) + unspecific) + (lambda (port) + (set! end-mark + (mark-right-inserting-copy + (output-port->mark port))) + unspecific))))) + indentation + port))) (if (and start-mark end-mark) (highlight-region-excluding-indentation (make-region start-mark end-mark) diff --git a/src/pcsample/pcsdisp.scm b/src/pcsample/pcsdisp.scm index 7af6810bb..fd3c3f99e 100644 --- a/src/pcsample/pcsdisp.scm +++ b/src/pcsample/pcsdisp.scm @@ -141,8 +141,9 @@ USA. (display-sample-list displayee)))))) (define (display-sample-list sample-list) ; not integrated so can play w/ it - (fluid-let ((*pp-default-as-code?* #T)) ; for now: just pp as code, but - (pp sample-list))) ; maybe opt for wizzy graphics later + (let-fluid *pp-default-as-code?* #T ; for now: just pp as code, but + (lambda () ; maybe opt for wizzy graphics later + (pp sample-list)))) (define (install-displayers) (set! pc-sample/builtin/display (generate:pc-sample/table/displayer diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 9b9e76147..63fbbd7db 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -30,6 +30,17 @@ USA. (declare (usual-integrations)) (define (initialize-package!) + (set! *pp-named-lambda->define?* (make-fluid #f)) + (set! *pp-primitives-by-name* (make-fluid #t)) + (set! *pp-uninterned-symbols-by-name* (make-fluid #t)) + (set! *pp-no-highlights?* (make-fluid #t)) + (set! *pp-save-vertical-space?* (make-fluid #f)) + (set! *pp-lists-as-tables?* (make-fluid #t)) + (set! *pp-forced-x-size* (make-fluid #f)) + (set! *pp-avoid-circularity?* (make-fluid #f)) + (set! *pp-default-as-code?* (make-fluid #t)) + (set! *pp-auto-highlighter* (make-fluid #f)) + (set! *pp-arity-dispatched-procedure-style* (make-fluid 'FULL)) (set! x-size (make-fluid #f)) (set! output-port (make-fluid #f)) (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION)) @@ -62,16 +73,16 @@ USA. (set! cocked-object (generate-uninterned-symbol)) unspecific) -(define *pp-named-lambda->define?* #f) -(define *pp-primitives-by-name* #t) -(define *pp-uninterned-symbols-by-name* #t) -(define *pp-no-highlights?* #t) -(define *pp-save-vertical-space?* #f) -(define *pp-lists-as-tables?* #t) -(define *pp-forced-x-size* #f) -(define *pp-avoid-circularity?* #f) -(define *pp-default-as-code?* #t) -(define *pp-auto-highlighter* #f) +(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 object #!optional port . rest) (let ((port (if (default-object? port) (current-output-port) port))) @@ -114,11 +125,11 @@ USA. ;;; 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* 'FULL) +(define *pp-arity-dispatched-procedure-style*) (define (unsyntax-entity object) (define (unsyntax-entry procedure) - (case *pp-arity-dispatched-procedure-style* + (case (fluid *pp-arity-dispatched-procedure-style*) ((FULL) (unsyntax-entity procedure)) ((NAMED) (let ((text (unsyntax-entity procedure))) @@ -155,7 +166,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 (fluid *pp-default-as-code?*))) (if (boolean? default) default (not (scode-constant? object)))) @@ -167,8 +178,9 @@ USA. (if (and as-code? (pair? sexp) (eq? (car sexp) 'NAMED-LAMBDA) - *pp-named-lambda->define?*) - (if (and (eq? 'LAMBDA *pp-named-lambda->define?*) + (fluid *pp-named-lambda->define?*)) + (if (and (eq? 'LAMBDA + (fluid *pp-named-lambda->define?*)) (pair? (cdr sexp)) (pair? (cadr sexp))) `(LAMBDA ,(cdadr sexp) ,@(cddr sexp)) @@ -218,16 +230,17 @@ USA. 0))) (define (pp-top-level expression port as-code? indentation list-depth) - (let-fluids x-size (- (or *pp-forced-x-size* (output-port/x-size port)) 1) + (let-fluids x-size (- (or (fluid *pp-forced-x-size*) + (output-port/x-size port)) 1) output-port port *unparse-uninterned-symbols-by-name?* - *pp-uninterned-symbols-by-name* + (fluid *pp-uninterned-symbols-by-name*) *unparse-abbreviate-quotations?* (or as-code? (fluid *unparse-abbreviate-quotations?*)) (lambda () (let* ((numerical-walk - (if *pp-avoid-circularity?* + (if (fluid *pp-avoid-circularity?*) numerical-walk-avoid-circularities numerical-walk)) (node (numerical-walk expression list-depth))) @@ -262,7 +275,7 @@ USA. (define (print-non-code-node node column depth) (let-fluids dispatch-list '() dispatch-default - (if *pp-lists-as-tables?* + (if (fluid *pp-lists-as-tables?*) print-data-table print-data-column) (lambda () @@ -319,7 +332,7 @@ USA. (*unparse-string node)))) (define (print-list-node node column depth) - (if (and *pp-save-vertical-space?* + (if (and (fluid *pp-save-vertical-space?*) (fits-within? node column depth)) (print-guaranteed-list-node node) (let* ((subnodes (node-subnodes node)) @@ -649,7 +662,7 @@ USA. (walk-custom unparser object list-depth) (walk-pair object list-depth)))))) ((symbol? object) - (if (or *pp-uninterned-symbols-by-name* + (if (or (fluid *pp-uninterned-symbols-by-name*) (interned-symbol? object)) object (walk-custom unparse-object object list-depth))) @@ -673,7 +686,7 @@ USA. (walk-pair (vector->list object) list-depth)))))) ((primitive-procedure? object) - (if *pp-primitives-by-name* + (if (fluid *pp-primitives-by-name*) (primitive-procedure-name object) (walk-custom unparse-object object list-depth))) (else @@ -686,9 +699,10 @@ USA. ;; otherwise we would get infinite recursion when the `unwrapped' ;; object REST is re-auto-highlighted by the test below. - (cond ((and *pp-auto-highlighter* - (not (pretty-printer-highlight? object)) - (*pp-auto-highlighter* object)) + (cond ((let ((highlighter (fluid *pp-auto-highlighter*))) + (and highlighter + (not (pretty-printer-highlight? object)) + (highlighter object))) => (lambda (highlighted) (numerical-walk-no-auto-highlight highlighted list-depth))) (else @@ -739,7 +753,7 @@ USA. list-depth))))))))))))) (define-integrable (no-highlights? object) - (or *pp-no-highlights?* + (or (fluid *pp-no-highlights?*) (not (partially-highlighted? object)))) (define (partially-highlighted? object) @@ -814,7 +828,7 @@ USA. (walk-pair-terminating object half-pointer/queue list-depth)))))) ((symbol? object) - (if (or *pp-uninterned-symbols-by-name* + (if (or (fluid *pp-uninterned-symbols-by-name*) (interned-symbol? object)) object (walk-custom unparse-object object list-depth))) @@ -837,7 +851,7 @@ USA. (vector->list object) half-pointer/queue list-depth)))))) ((primitive-procedure? object) - (if *pp-primitives-by-name* + (if (fluid *pp-primitives-by-name*) (primitive-procedure-name object) (walk-custom unparse-object object list-depth))) (else diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index d2d86f171..b2f434ed0 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -84,6 +84,7 @@ (define event-return-address 'UNINITIALIZED) (define (initialize-package!) + (set! stack-sampling-return-address (make-fluid #f)) (let ((blocked? (block-thread-events))) (signal-thread-event (current-thread) (lambda () @@ -160,10 +161,10 @@ (stack-frame/type stack-frame)) (eq? event-return-address (stack-frame/return-address stack-frame))))) -(define stack-sampling-return-address #f) +(define stack-sampling-return-address) (define (stack-sampling-stack-frame? stack-frame) - (let ((return-address stack-sampling-return-address)) + (let ((return-address (fluid stack-sampling-return-address))) (and (compiled-return-address? return-address) (eq? stack-frame-type/compiled-return-address (stack-frame/type stack-frame)) @@ -179,9 +180,9 @@ (let ((stack-frame (continuation/first-subproblem continuation))) (if (eq? stack-frame-type/compiled-return-address (stack-frame/type stack-frame)) - (fluid-let ((stack-sampling-return-address - (stack-frame/return-address stack-frame))) - (thunk)) + (let-fluid stack-sampling-return-address + (stack-frame/return-address stack-frame) + thunk) (thunk))))))) ;;;; Profile Data @@ -399,7 +400,7 @@ *unparser-list-depth-limit* 3 *unparser-string-length-limit* 40 *unparse-primitives-by-name?* #t + *pp-save-vertical-space?* #t + *pp-default-as-code?* #t (lambda () - (fluid-let ((*pp-save-vertical-space?* #t) - (*pp-default-as-code?* #t)) - (pp expression output-port))))) \ No newline at end of file + (pp expression output-port)))) \ No newline at end of file diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index 3483726ab..933151d4c 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -243,8 +243,8 @@ USA. ;;; Debugging utility (define (pp-expression form #!optional port) - (fluid-let ((*pp-primitives-by-name* #f) - (*pp-uninterned-symbols-by-name* #f)) - (let-fluid *unparse-abbreviate-quotations?* #t - (lambda () - (pp (cgen/external-with-declarations form) port))))) + (let-fluids *pp-primitives-by-name* #f + *pp-uninterned-symbols-by-name* #f + *unparse-abbreviate-quotations?* #t + (lambda () + (pp (cgen/external-with-declarations form) port)))) \ No newline at end of file