From 1ed342f89e22bd27c429e263a259e262330777e6 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Mon, 20 Mar 1995 20:14:10 +0000 Subject: [PATCH] Changed PA to print primitive documentation rather than signal an error when given a primitive procedure. --- v7/src/runtime/global.scm | 20 ++++++++++++++++---- v8/src/runtime/global.scm | 20 ++++++++++++++++---- 2 files changed, 32 insertions(+), 8 deletions(-) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 8802b6458..7e1952e0f 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.46 1993/10/21 11:49:45 cph Exp $ +$Id: global.scm,v 14.47 1995/03/20 20:14:10 adams Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -149,9 +149,21 @@ MIT in each case. |# (with-output-to-truncated-string max (lambda () (write object))))) (define (pa procedure) - (if (not (procedure? procedure)) - (error "Must be a procedure" procedure)) - (pp (unsyntax-lambda-list (procedure-lambda procedure)))) + (cond ((not (procedure? procedure)) + (error "Must be a procedure" procedure)) + ((procedure-lambda procedure) + => (lambda (scode) + (pp (unsyntax-lambda-list scode)))) + ((and (primitive-procedure? procedure) + (primitive-procedure-documentation procedure)) + => (lambda (documentation) + (newline) + (display documentation))) + (else + (newline) + (display "No documentation or debugging info for ") + (display procedure) + (display ".")))) (define (pwd) (working-directory-pathname)) diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index 8802b6458..7e1952e0f 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.46 1993/10/21 11:49:45 cph Exp $ +$Id: global.scm,v 14.47 1995/03/20 20:14:10 adams Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -149,9 +149,21 @@ MIT in each case. |# (with-output-to-truncated-string max (lambda () (write object))))) (define (pa procedure) - (if (not (procedure? procedure)) - (error "Must be a procedure" procedure)) - (pp (unsyntax-lambda-list (procedure-lambda procedure)))) + (cond ((not (procedure? procedure)) + (error "Must be a procedure" procedure)) + ((procedure-lambda procedure) + => (lambda (scode) + (pp (unsyntax-lambda-list scode)))) + ((and (primitive-procedure? procedure) + (primitive-procedure-documentation procedure)) + => (lambda (documentation) + (newline) + (display documentation))) + (else + (newline) + (display "No documentation or debugging info for ") + (display procedure) + (display ".")))) (define (pwd) (working-directory-pathname)) -- 2.25.1