From: Chris Hanson Date: Sun, 7 Jan 2018 19:45:40 +0000 (-0500) Subject: Implement real define-pp-describer. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~404 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7894e2ef77a2e5759e1accb2f90b4740a7ab62f5;p=mit-scheme.git Implement real define-pp-describer. --- diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index bfcc3cebb..354e47b6b 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -41,56 +41,52 @@ USA. (define param:pp-save-vertical-space?) (define param:pp-uninterned-symbols-by-name?) -(define (initialize-package!) - ;; 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-unsettable-parameter #f)) - (set! output-port (make-unsettable-parameter #f)) - (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION)) - (set-generic-procedure-default-generator! pp-description - (lambda (generic tags) - generic tags - pp-description/default)) - (set! forced-indentation (special-printer kernel/forced-indentation)) - (set! pressured-indentation (special-printer kernel/pressured-indentation)) - (set! print-procedure (special-printer kernel/print-procedure)) - (set! print-let-expression (special-printer kernel/print-let-expression)) - (set! print-case-expression (special-printer kernel/print-case-expression)) - (set! code-dispatch-list - (make-unsettable-parameter - `((COND . ,forced-indentation) - (CASE . ,print-case-expression) - (IF . ,forced-indentation) - (OR . ,forced-indentation) - (AND . ,forced-indentation) - (LET . ,print-let-expression) - (LET* . ,print-let-expression) - (LETREC . ,print-let-expression) - (FLUID-LET . ,print-let-expression) - (DEFINE . ,print-procedure) - (DEFINE-INTEGRABLE . ,print-procedure) - (LAMBDA . ,print-procedure) - (NAMED-LAMBDA . ,print-procedure)))) - (set! dispatch-list (make-unsettable-parameter (code-dispatch-list))) - (set! dispatch-default (make-unsettable-parameter print-combination)) - (set! cocked-object (generate-uninterned-symbol)) - unspecific) +(add-boot-init! + (lambda () + ;; 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-unsettable-parameter #f)) + (set! output-port (make-unsettable-parameter #f)) + (set! forced-indentation (special-printer kernel/forced-indentation)) + (set! pressured-indentation (special-printer kernel/pressured-indentation)) + (set! print-procedure (special-printer kernel/print-procedure)) + (set! print-let-expression (special-printer kernel/print-let-expression)) + (set! print-case-expression (special-printer kernel/print-case-expression)) + (set! code-dispatch-list + (make-unsettable-parameter + `((COND . ,forced-indentation) + (CASE . ,print-case-expression) + (IF . ,forced-indentation) + (OR . ,forced-indentation) + (AND . ,forced-indentation) + (LET . ,print-let-expression) + (LET* . ,print-let-expression) + (LETREC . ,print-let-expression) + (FLUID-LET . ,print-let-expression) + (DEFINE . ,print-procedure) + (DEFINE-INTEGRABLE . ,print-procedure) + (LAMBDA . ,print-procedure) + (NAMED-LAMBDA . ,print-procedure)))) + (set! dispatch-list (make-unsettable-parameter (code-dispatch-list))) + (set! dispatch-default (make-unsettable-parameter print-combination)) + (set! cocked-object (generate-uninterned-symbol)) + unspecific)) (define *pp-arity-dispatched-procedure-style* #!default) (define *pp-auto-highlighter* #!default) @@ -177,26 +173,42 @@ USA. (pretty-print object)))))) (define pp-description) - -(define (pp-description/default object) - (cond ((named-structure? object) - (named-structure/description object)) - ((%record? object) ; unnamed record - (let loop ((i (- (%record-length object) 1)) (d '())) - (if (< i 0) - d - (loop (- i 1) - (cons (list i (%record-ref object i)) d))))) - ((and (entity? object) - (record? (entity-extra object))) - ((record-entity-describer (entity-extra object)) object)) - ((weak-pair? object) - `((WEAK-CAR ,(weak-car object)) - (WEAK-CDR ,(weak-cdr object)))) - ((cell? object) - `((CONTENTS ,(cell-contents object)))) - (else - #f))) +(add-boot-init! + (lambda () + (set! pp-description + (standard-predicate-dispatcher 'pp-description 1)) + + (define-predicate-dispatch-default-handler pp-description + (lambda (object) + (cond ((named-structure? object) + (named-structure/description object)) + ((%record? object) ; unnamed record + (let loop ((i (- (%record-length object) 1)) (d '())) + (if (< i 0) + d + (loop (- i 1) + (cons (list i (%record-ref object i)) d))))) + ((and (entity? object) + (record? (entity-extra object))) + ((record-entity-describer (entity-extra object)) object)) + (else #f)))) + + (set! define-pp-describer + (named-lambda (define-pp-describer predicate describer) + (define-predicate-dispatch-handler pp-description + (list predicate) + describer))) + + (run-deferred-boot-actions 'pp-describers) + + (define-pp-describer weak-pair? + (lambda (wp) + `((WEAK-CAR ,(weak-car wp)) + (WEAK-CDR ,(weak-cdr wp))))) + + (define-pp-describer cell? + (lambda (cell) + `((CONTENTS ,(cell-contents cell))))))) (define (unsyntax-entity object) (define (unsyntax-entry procedure) diff --git a/src/sos/printer.scm b/src/sos/printer.scm index c68a68194..ce7f326ac 100644 --- a/src/sos/printer.scm +++ b/src/sos/printer.scm @@ -101,18 +101,9 @@ USA. (thunk)) (write-char #\] port)) -(define-predicate-dispatch-handler unparse-record - (list any-object? instance?) +(define-unparser-method instance? (general-unparser-method write-instance)) -(add-generic-procedure-generator pp-description - (lambda (generic tags) - generic - (and (let ((class (dispatch-tag-contents (car tags)))) - (and (class? class) - (subclass? class ))) - instance-description))) - (define (instance-description instance) (map (lambda (slot) (let ((name (slot-name slot))) @@ -120,4 +111,7 @@ USA. (if (slot-initialized? instance name) (list (slot-value instance name)) '())))) - (class-slots (instance-class instance)))) \ No newline at end of file + (class-slots (instance-class instance)))) + +(define-pp-describer instance? + instance-description) \ No newline at end of file