Changed PA to print primitive documentation rather than signal an

error when given a primitive procedure.

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 8802b64586771997f051320fe9c213d23500a88c..7e1952e0fb7bf9296c4693ca0116d3810933571d 100644 (file)
--- 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)))))
 \f
 (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 8802b64586771997f051320fe9c213d23500a88c..7e1952e0fb7bf9296c4693ca0116d3810933571d 100644 (file)
--- 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)))))
 \f
 (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))