From d48e7501afe328fb78f0319fcef605abce6dad3d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 3 May 2008 05:25:46 +0000 Subject: [PATCH] use the builtin write and display handlers instead of the previous ones svn: r9620 --- collects/swindle/extra.ss | 100 +++++++++++++++++++------------------- 1 file changed, 49 insertions(+), 51 deletions(-) diff --git a/collects/swindle/extra.ss b/collects/swindle/extra.ss index 1289c1d94e..1794cfa794 100644 --- a/collects/swindle/extra.ss +++ b/collects/swindle/extra.ss @@ -433,8 +433,10 @@ (define* *print-level* (make-parameter 6)) (define* *print-length* (make-parameter 20)) -(define orig-write-handler (port-write-handler (current-error-port))) -(define orig-display-handler (port-display-handler (current-error-port))) +;; grab the builtin write/display handlers +(define-values (mz:write mz:display) + (let ([p (open-output-bytes)]) + (values (port-write-handler p) (port-display-handler p)))) ;;>> (print-object obj esc? port) ;;> Prints `obj' on `port' using the above parameters -- the effect of @@ -450,73 +452,69 @@ (defgeneric* print-object (object esc? port)) (defmethod (print-object o esc? port) - (orig-display-handler "#" port) - (orig-display-handler (class-name (class-of o)) port)) + (mz:display "#" port) + (mz:display (class-name (class-of o)) port)) (defmethod (print-object [o ] esc? port) - ((if esc? orig-write-handler orig-display-handler) o port)) + ((if esc? mz:write mz:display) o port)) (define printer:too-deep "#?#") (define printer:too-long "...") (defmethod (print-object [o ] esc? port) (cond - [(null? o) (orig-display-handler "()" port)] + [(null? o) (mz:display "()" port)] [(and (pair? (cdr o)) (null? (cddr o)) (memq (car o) '(quote quasiquote unquote unquote-splicing syntax quasisyntax unsyntax unsyntax-splicing))) - (orig-display-handler (case (car o) - [(quote) "'"] - [(quasiquote) "`"] - [(unquote) ","] - [(unquote-splicing) ",@"] - [(syntax) "#'"] - [(quasisyntax) "#`"] - [(unsyntax) "#,"] - [(unsyntax-splicing) "#,@"]) - port) + (mz:display (case (car o) + [(quote) "'"] + [(quasiquote) "`"] + [(unquote) ","] + [(unquote-splicing) ",@"] + [(syntax) "#'"] + [(quasisyntax) "#`"] + [(unsyntax) "#,"] + [(unsyntax-splicing) "#,@"]) + port) (print-object (cadr o) esc? port)] - [(eq? (*print-level*) 0) - (orig-display-handler printer:too-deep port)] + [(eq? (*print-level*) 0) (mz:display printer:too-deep port)] [else - (orig-display-handler "(" port) + (mz:display "(" port) (if (eq? (*print-length*) 0) - (orig-display-handler printer:too-long port) + (mz:display printer:too-long port) (parameterize ([*print-level* (sub1 (or (*print-level*) 0))]) (print-object (car o) esc? port) (do ([o (cdr o) (if (pair? o) (cdr o) '())] [n (sub1 (or (*print-length*) 0)) (sub1 n)]) [(or (null? o) (and (zero? n) - (begin (orig-display-handler " " port) - (orig-display-handler printer:too-long port) + (begin (mz:display " " port) + (mz:display printer:too-long port) #t)))] (if (pair? o) - (begin (orig-display-handler " " port) - (print-object (car o) esc? port)) - (begin (orig-display-handler " . " port) - (print-object o esc? port)))))) - (orig-display-handler ")" port)])) + (begin (mz:display " " port) (print-object (car o) esc? port)) + (begin (mz:display " . " port) (print-object o esc? port)))))) + (mz:display ")" port)])) (defmethod (print-object [o ] esc? port) - (cond [(eq? (*print-level*) 0) - (orig-display-handler printer:too-deep port)] - [(zero? (vector-length o)) (orig-display-handler "#()" port)] - [else (orig-display-handler "#(" port) + (cond [(eq? (*print-level*) 0) (mz:display printer:too-deep port)] + [(zero? (vector-length o)) (mz:display "#()" port)] + [else (mz:display "#(" port) (if (eq? (*print-length*) 0) - (orig-display-handler printer:too-long port) + (mz:display printer:too-long port) (parameterize ([*print-level* (sub1 (or (*print-level*) 0))]) (print-object (vector-ref o 0) esc? port) (let ([len (if (*print-length*) (min (vector-length o) (*print-length*)) (vector-length o))]) (do ([i 1 (add1 i)]) [(>= i len)] - (orig-display-handler " " port) + (mz:display " " port) (print-object (vector-ref o i) esc? port)) (when (< len (vector-length o)) - (orig-display-handler " " port) - (orig-display-handler printer:too-long port))))) - (orig-display-handler ")" port)])) + (mz:display " " port) + (mz:display printer:too-long port))))) + (mz:display ")" port)])) ;;>> (name-sans-<> name) ;;> Given a string or symbol for name, return a string where the outermost @@ -535,11 +533,11 @@ [cc (class-of c)] [(name x) (name-sans-<> (slot-ref x 'name))]) (if (and (assq 'name (class-slots c)) (assq 'name (class-slots cc))) - (begin (orig-display-handler "#<" port) - (orig-display-handler (name c) port) - (orig-display-handler ":" port) - (orig-display-handler (name o) port) - (orig-display-handler ">" port)) + (begin (mz:display "#<" port) + (mz:display (name c) port) + (mz:display ":" port) + (mz:display (name o) port) + (mz:display ">" port)) (call-next-method)))) ;;>> (print-object-with-slots obj esc? port) @@ -549,26 +547,26 @@ ;;> `print-object'. (define* (print-object-with-slots o esc? port) (if (eq? (*print-level*) 0) - (orig-display-handler printer:too-deep port) + (mz:display printer:too-deep port) (let ([class (class-of o)]) - (orig-display-handler "#<" port) - (orig-display-handler (name-sans-<> (class-name class)) port) - (orig-display-handler ":" port) + (mz:display "#<" port) + (mz:display (name-sans-<> (class-name class)) port) + (mz:display ":" port) (parameterize ([*print-level* (sub1 (or (*print-level*) 0))]) (do ([s (class-slots class) (cdr s)] [n (or (*print-length*) -1) (sub1 n)]) [(or (null? s) (and (zero? n) - (begin (orig-display-handler " " port) - (orig-display-handler printer:too-long port))))] + (begin (mz:display " " port) + (mz:display printer:too-long port))))] (let ([val (slot-ref o (caar s))]) (if (eq? ??? val) (set! n (add1 n)) - (begin (orig-display-handler " " port) - (orig-display-handler (caar s) port) - (orig-display-handler "=" port) + (begin (mz:display " " port) + (mz:display (caar s) port) + (mz:display "=" port) (print-object val esc? port)))))) - (orig-display-handler ">" port)))) + (mz:display ">" port)))) ;; Add a hook to make so it will initialize a printer if given (defmethod :after (initialize [c ] initargs)