(FILECREATED " 2-Feb-86 16:59:12" {DSK}<LISPFILES2>APROPOS.LSP;2
 2977   

      changes to:  (VARS APROPOSCOMS))


(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)

(PRETTYCOMPRINT APROPOSCOMS)

(RPAQQ APROPOSCOMS
 ((FNS QP.APROPOS QP.BACKTRACE QP.PREDICATES QP.WHERE)))
(DEFINEQ

(QP.APROPOS

  (LAMBDA (NAME ARITY MODULE)
    (
PROG
 (FLG HI LO)
	    (if
 (
AND
 NAME (
NOT
 (
LISTP
 NAME)))
		then
 (
SETQ
 NAME (
MKSTRING
 NAME)))
	    (if
 (
AND
 MODULE (
NOT
 (
LISTP
 MODULE)))
		then
 (
SETQ
 MODULE (
MKSTRING
 MODULE)))
	    (if
 (
LISTP
 ARITY)
		then
 (
SETQ
 LO (
CAR
 ARITY))
		       (
SETQ
 HI (
CDR
 ARITY))
	      elseif
 (
SMALLP
 ARITY)
		then
 (
SETQ
 LO (
SETQ
 HI ARITY))
	      else
 (
SETQ
 LO 0)
		     (
SETQ
 HI 255))
	    (FOR
 X ← QP.FIRST.PREDICATE BY
 (
\GETBASEPTR
 X 0) UNTIL
 (
ZEROP
 X)
	       DO
 (
PROGN
 (
PRINT
 X)
			     (
SETQ
 FLG T))
	       WHEN
 (
AND
 (
GEQ
 (PROC.ARITY X)
				    LO)
			     (
LEQ
 (PROC.ARITY X)
				    HI)
			     (
OR
 (
NULL
 NAME)
				   (
AND
 (
LISTP
 NAME)
					  (
MEMB
 (PROC.NAME X)
						  NAME))
				   (
STRPOS
 NAME (PROC.NAME X)))
			     (
OR
 (
NULL
 MODULE)
				   (
AND
 (
LISTP
 MODULE)
					  (
MEMB
 (PROC.MODULE X)
						  MODULE))
				   (
STRPOS
 MODULE (PROC.MODULE X)))))
	    (
RETURN
 FLG))))

(QP.BACKTRACE

  (LAMBDA NIL
    (LET ((LIMIT (
\ADDBASE
 QP.init.E 20)))
         (
PRINT
 (QP.WHERE
 (get.24 P)))
         (
PRINT
 (QP.WHERE
 (get.24 CP)))
         (FOR
 E FROM
 (get.24 E) BY
 (
\GETBASE
 E 0) WHILE
 (
\BASELESSP
 LIMIT E)
	    DO
 (
PRINT
 (QP.WHERE
 (
\GETBASE
 E 2)))))))

(QP.PREDICATES

  (LAMBDA NIL
    (FOR
 X ← QP.FIRST.PREDICATE BY
 (
\GETBASEPTR
 X 0) UNTIL
 (
ZEROP
 X) COLLECT
 X)))

(QP.WHERE

  (LAMBDA (P)
    (
PROG
 (X C K Q M N)
	    (if
 (
NULL
 P)
		then
 (
SETQ
 P (get.24 P)))
	    (
SETQ
 X QP.FIRST.PREDICATE)
	    (
SETQ
 M NIL)
	    (until
 (
ZEROP
 X)
		     (
SETQ
 C (PROC.CLAUSES X))
		     (if
 (
AND
 (
NOT
 (
FIXP
 C))
				  (
NEQ
 (
\GETBASEBYTE
 C 0)
					 (
QP.OP.CODE
 (
QUOTE
 trap))))
			 then
 (
SETQ
 K 0)
				(do
 (
PROGN
 (
SETQ
 K (
ADD1
 K))
					       (if
 (
TYPENAMEP
 C (
QUOTE
 INDEX.BLOCK))
						   then
 (
SETQ
 C (fetch
 (INDEX.BLOCK FIRST)
								       of
 C)))
					       (if
 (
AND
 (
\BASELESSP
 C P)
							    (
\BASELESSP
 M C))
						   then
 (
SETQ
 M C)
							  (
SETQ
 Q X)
							  (
SETQ
 N K))
					       (
SETQ
 C (
\GETBASEPTR
 C 0)))
				   repeatuntil
 (
EQ
 C QP.FAILURE.CLAUSE)))
		     (
SETQ
 X (
\GETBASEPTR
 X 0)))
	    (
RETURN
 (
CONS
 N Q)))))
)
(PUTPROPS APROPOS.LSP COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (309 2883 (QP.APROPOS 319 . 1458) (QP.BACKTRACE 1460 . 1796) (QP.PREDICATES 1798 . 1936)
 (QP.WHERE 1938 . 2881)))))
STOP