From d30b7dcb95141505b82e09de4359a1783d43e0a9 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Fri, 13 Jan 1995 21:48:54 +0000 Subject: [PATCH] If an arity-dispatched-procedure has a named compiled procedure as the default then this procedure's name is used in printing the #[..] object. --- v7/src/runtime/unpars.scm | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index d57ebc0c0..5afc10771 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unpars.scm,v 14.38 1995/01/12 17:24:07 adams Exp $ +$Id: unpars.scm,v 14.39 1995/01/13 21:48:54 adams Exp $ Copyright (c) 1988-1994 Massachusetts Institute of Technology @@ -684,10 +684,18 @@ MIT in each case. |# (*unparse-hex ((ucode-primitive primitive-object-datum 1) future))))) (define (unparse/entity entity) - (*unparse-with-brackets (cond ((continuation? entity) 'CONTINUATION) - ((apply-hook? entity) 'APPLY-HOOK) - ((arity-dispatched-procedure? entity) - 'ARITY-DISPATCHED-PROCEDURE) - (else 'ENTITY)) - entity - false)) \ No newline at end of file + (define (plain name) (*unparse-with-brackets name entity false)) + (cond ((continuation? entity) (plain 'CONTINUATION)) + ((apply-hook? entity) (plain 'APPLY-HOOK)) + ((arity-dispatched-procedure? entity) + (define (print-with-name name) + (*unparse-with-brackets 'ARITY-DISPATCHED-PROCEDURE + entity + (lambda () (*unparse-string name)))) + (let ((proc (entity-procedure entity))) + (cond ((and (compiled-code-address? proc) + (compiled-procedure? proc) + (compiled-procedure/name proc)) + => print-with-name) + (else (plain 'ARITY-DISPATCHED-PROCEDURE))))) + (else (plain 'ENTITY)))) -- 2.25.1