(FILECREATED " 8-Feb-86 15:09:35" {DSK}<LISPFILES2>IMPROVEDDCOMS>PROCS.;1
 8226   

      changes to:  (VARS PROCSCOMS) (RECORDS QP.PROCEDURE.RECORD))


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

(PRETTYCOMPRINT PROCSCOMS)

(RPAQQ PROCSCOMS
 ((CONSTANTS QP.EMPTY.PROC.ADDRESS) (RECORDS QP.PROCEDURE.RECORD) (MACROS PROC.ARITY
 PROC.CLAUSES PROC.HIFLAG PROC.LASTCLAUSE PROC.LOFLAG PROC.MODULE PROC.NAME QP.GET.PREDICATE.STATE 
QP.SET.PREDICATE.STATE) (PROP SETFDEF PROC.CLAUSES PROC.HIFLAG PROC.LASTCLAUSE PROC.LOFLAG) (FNS 
QP.ABOLISH QP.ATOM.PREDICATE QP.COPY.PROCEDURE.RECORD QP.EMPTY.CLAUSES QP.FIRST.PREDICATE 
QP.FIRST.SYMBOL QP.FREE.PROCEDURE.RECORD QP.FUNCTOR.PREDICATE QP.INIT.PROCEDURES QP.LOCAL.PREDICATE 
QP.MAKE.PROCEDURE.RECORD QP.NEXT.SYMBOL QP.P.CHECK.PREDICATE QP.P.PROCEDURE QP.PREDICATE QP.PREDINFO 
QP.PROC.PRINT QP.SASSOC QP.UNDEF) (P (DEFPRINT (QUOTE QP.PROCEDURE.RECORD) (QUOTE QP.PROC.PRINT))) (
ADDVARS (GLOBALVARS QP.ATOM.PREDICATE) (GLOBALVARS QP.FUNCTOR.PREDICATE) (GLOBALVARS 
QP.FIRST.PREDICATE))))
(DECLARE: EVAL@COMPILE 

(RPAQQ QP.EMPTY.PROC.ADDRESS
 0)

(CONSTANTS QP.EMPTY.PROC.ADDRESS)
)
[DECLARE: EVAL@COMPILE 

(DATATYPE QP.PROCEDURE.RECORD
 ((LINK POINTER) (FUNCTOR FIXP) (MODULE FIXP) (ARITY FIXP) (FIRST FIXP)
 (LAST FIXP) (FLAGS FIXP)))
]
(/DECLAREDATATYPE (QUOTE QP.PROCEDURE.RECORD) (QUOTE (POINTER FIXP FIXP FIXP FIXP FIXP FIXP)) (QUOTE (
(QP.PROCEDURE.RECORD 0 POINTER) (QP.PROCEDURE.RECORD 2 FIXP) (QP.PROCEDURE.RECORD 4 FIXP) (
QP.PROCEDURE.RECORD 6 FIXP) (QP.PROCEDURE.RECORD 8 FIXP) (QP.PROCEDURE.RECORD 10 FIXP) (
QP.PROCEDURE.RECORD 12 FIXP))) (QUOTE 14))
(DECLARE: EVAL@COMPILE 
(PUTPROPS PROC.ARITY MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (\GETBASE (\, PROC) 7)))) X)))
(PUTPROPS PROC.CLAUSES MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (\GETBASEPTR (\, PROC) 8)))) X
)))
(PUTPROPS PROC.HIFLAG MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (\GETBASE (\, PROC) 12)))) X)))
(PUTPROPS PROC.LASTCLAUSE MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (\GETBASEPTR (\, PROC) 10))
)) X)))
(PUTPROPS PROC.LOFLAG MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (\GETBASE (\, PROC) 13)))) X)))
(PUTPROPS PROC.MODULE MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (\GETBASEPTR (\, PROC) 4)))) X)
))
(PUTPROPS PROC.NAME MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (\VAG2 0 (\GETBASE (\, PROC) 3)))
)) X)))
(PUTPROPS QP.GET.PREDICATE.STATE MACRO (X (APPLY (FUNCTION (LAMBDA (PROC) (BQUOTE (LOGAND (PROC.LOFLAG
 (\, PROC)) 3)))) X)))
(PUTPROPS QP.SET.PREDICATE.STATE MACRO (X (APPLY (FUNCTION (LAMBDA (PROC NEWVALUE) (BQUOTE (LET ((
RECORD (\, PROC))) (SETF (PROC.LOFLAG RECORD) (LOGOR (LOGAND (PROC.LOFLAG RECORD) 65532) (\, NEWVALUE)
)))))) X)))
)

(PUTPROPS PROC.CLAUSES SETFDEF
 (\PUTBASEPTR DATUM 8 NEWVALUE))

(PUTPROPS PROC.HIFLAG SETFDEF
 (\PUTBASE DATUM 12 NEWVALUE))

(PUTPROPS PROC.LASTCLAUSE SETFDEF
 (\PUTBASEPTR DATUM 10 NEWVALUE))

(PUTPROPS PROC.LOFLAG SETFDEF
 (\PUTBASE DATUM 13 NEWVALUE))
(DEFINEQ

(QP.ABOLISH

(LAMBDA (NAME ARITY MODULE) (LET ((PROC (QP.LOCAL.PREDICATE NAME ARITY MODULE))) (SETF (PROC.LOFLAG 
PROC) 0) (SETF (PROC.CLAUSES PROC) QP.UNDEFINED.CLAUSE) (SETF (PROC.LASTCLAUSE PROC) 
QP.UNDEFINED.CLAUSE))))

(QP.ATOM.PREDICATE

(LAMBDA (NAME) (OR (GETHASH NAME QP.ATOM.PREDICATE) QP.EMPTY.PROC.ADDRESS)))

(QP.COPY.PROCEDURE.RECORD

(LAMBDA (PROC) (LET ((RECORD (NCREATE (QUOTE QP.PROCEDURE.RECORD) PROC))) (\ADDREF RECORD) RECORD)))

(QP.EMPTY.CLAUSES

(LAMBDA (PROC) (EQ (PROC.CLAUSES PROC) QP.UNDEFINED.CLAUSE)))

(QP.FIRST.PREDICATE

(LAMBDA NIL QP.FIRST.PREDICATE))

(QP.FIRST.SYMBOL

(LAMBDA NIL (\VAG2 0 (SUB1 \AtomFrLst))))

(QP.FREE.PROCEDURE.RECORD

(LAMBDA (PROC) (if (TYPENAMEP PROC (QUOTE QP.PROCEDURE.RECORD)) then (\DELREF PROC) else (SHOULDNT (
QUOTE QP.FREE.PROCEDURE.RECORD)))))

(QP.FUNCTOR.PREDICATE

(LAMBDA (NAME ARITY) (QP.SASSOC NAME ARITY (GETHASH (LOGXOR (\LOLOC NAME) ARITY) QP.FUNCTOR.PREDICATE)
)))

(QP.INIT.PROCEDURES

(LAMBDA NIL (SETQ QP.FIRST.PREDICATE QP.EMPTY.PROC.ADDRESS) (SETQ QP.ATOM.PREDICATE (HASHARRAY 500 1.5
)) (SETQ QP.FUNCTOR.PREDICATE (HASHARRAY 4000 1.5))))

(QP.LOCAL.PREDICATE

(LAMBDA (NAME ARITY MODULE) (PROG (HASH RECORD PROC NEXT) (OR ARITY (SETQQ ARITY 0)) (OR MODULE (SETQQ
 MODULE si)) (SETQ HASH (LOGXOR (\LOLOC NAME) ARITY)) (SETQ RECORD (QP.SASSOC NAME ARITY (GETHASH HASH
 QP.FUNCTOR.PREDICATE))) (SETQ PROC RECORD) L (if (AND (NEQ PROC QP.EMPTY.PROC.ADDRESS) (EQ (PROC.NAME
 PROC) NAME) (EQ (PROC.ARITY PROC) ARITY)) then (if (EQ (PROC.MODULE PROC) MODULE) then (RETURN PROC))
 (SETQ PROC (fetch (QP.PROCEDURE.RECORD LINK) of PROC)) (GO L)) (SETQ PROC (QP.MAKE.PROCEDURE.RECORD 
NAME ARITY MODULE)) (if (NEQ RECORD QP.EMPTY.PROC.ADDRESS) then (replace (QP.PROCEDURE.RECORD LINK) of
 PROC with (fetch (QP.PROCEDURE.RECORD LINK) of RECORD)) (replace (QP.PROCEDURE.RECORD LINK) of RECORD
 with PROC) (RETURN PROC)) (PUTHASH HASH (CONS (CONS PROC (CONS NAME ARITY)) (GETHASH HASH 
QP.FUNCTOR.PREDICATE)) QP.FUNCTOR.PREDICATE) (SETQ RECORD (GETHASH NAME QP.ATOM.PREDICATE)) (if (NOT (
NULL RECORD)) then (SETQ ARITY (PROC.ARITY RECORD)) (SETQ NEXT (fetch (QP.PROCEDURE.RECORD LINK) of 
RECORD)) (while (AND (NEQ NEXT QP.EMPTY.PROC.ADDRESS) (EQ (PROC.NAME NEXT) NAME) (EQ (PROC.ARITY NEXT)
 ARITY)) (SETQ RECORD NEXT) (SETQ NEXT (fetch (QP.PROCEDURE.RECORD LINK) of NEXT))) (replace (
QP.PROCEDURE.RECORD LINK) of PROC with NEXT) (replace (QP.PROCEDURE.RECORD LINK) of RECORD with PROC) 
(RETURN PROC)) (replace (QP.PROCEDURE.RECORD LINK) of PROC with QP.FIRST.PREDICATE) (SETQ 
QP.FIRST.PREDICATE PROC) (PUTHASH NAME PROC QP.ATOM.PREDICATE) (RETURN PROC))))

(QP.MAKE.PROCEDURE.RECORD

(LAMBDA (NAME ARITY MODULE) (LET ((RECORD (NCREATE (QUOTE QP.PROCEDURE.RECORD)))) (\PUTBASEPTR RECORD 
0 NIL) (\PUTBASEPTR RECORD 2 NAME) (\PUTBASE RECORD 2 (IPLUS ARITY symbol.tag.16)) (\PUTBASEPTR RECORD
 4 MODULE) (\PUTBASE RECORD 4 symbol.tag.16) (\PUTBASE RECORD 6 0) (\PUTBASE RECORD 7 ARITY) (SETF (
PROC.CLAUSES RECORD) QP.UNDEFINED.CLAUSE) (SETF (PROC.LASTCLAUSE RECORD) QP.UNDEFINED.CLAUSE) (SETF (
PROC.HIFLAG RECORD) 0) (SETF (PROC.LOFLAG RECORD) 0) RECORD)))

(QP.NEXT.SYMBOL

(LAMBDA (SYMBOL) (COND ((NULL SYMBOL) 0) (T (\VAG2 0 (SUB1 (\LOLOC SYMBOL)))))))

(QP.P.CHECK.PREDICATE

(LAMBDA (NAME ARITY MODULE) (PROG (PROC) (SETQ PROC (QP.SASSOC NAME ARITY (GETHASH (LOGXOR (\LOLOC 
NAME) ARITY) QP.FUNCTOR.PREDICATE))) L (if (OR (EQ PROC QP.EMPTY.PROC.ADDRESS) (NEQ (PROC.NAME PROC) 
NAME) (NEQ (PROC.ARITY PROC) ARITY)) then (RETURN QP.EMPTY.PROC.ADDRESS)) (if (EQ (PROC.MODULE PROC) 
MODULE) then (RETURN PROC)) (SETQ PROC (fetch (QP.PROCEDURE.RECORD LINK) of PROC)) (GO L))))

(QP.P.PROCEDURE

(LAMBDA (PROC) (LIST (PROC.NAME PROC) (PROC.ARITY PROC) (PROC.MODULE PROC))))

(QP.PREDICATE

(LAMBDA (NAME ARITY MODULE) (if (LITATOM NAME) then (QP.LOCAL.PREDICATE NAME ARITY MODULE) else NAME))
)

(QP.PREDINFO

(LAMBDA (PROC) (if (TYPENAMEP PROC (QUOTE QP.PROCEDURE.RECORD)) then (VALUES (PROC.NAME PROC) (
PROC.ARITY PROC) (PROC.MODULE PROC) (PROC.LOFLAG PROC)) else (VALUES 0 0 0 0))))

(QP.PROC.PRINT

(LAMBDA (PROC STREAM) (DECLARE (SPECVARS FN)) (if (STKPOS (QUOTE \MAPCHARS1)) then (\MAPCHARS1 (
PROC.MODULE PROC) NIL FN) (\MAPCHARS1 (QUOTE :) NIL FN) (\MAPCHARS1 (PROC.NAME PROC) NIL FN) (
\MAPCHARS1 (QUOTE /) NIL FN) (\MAPCHARS1 (PROC.ARITY PROC) NIL FN) else (PRIN1 (PROC.MODULE PROC) 
STREAM) (PRIN1 (QUOTE :) STREAM) (PRIN1 (PROC.NAME PROC) STREAM) (PRIN1 (QUOTE /) STREAM) (PRIN1 (
PROC.ARITY PROC) STREAM)) T))

(QP.SASSOC

(LAMBDA (NAME ARITY ALIST) (FOR X IN ALIST WHEN (AND (EQ (CADR X) NAME) (EQ (CDDR X) ARITY)) DO (
RETURN (CAR X)) FINALLY (RETURN QP.EMPTY.PROC.ADDRESS))))

(QP.UNDEF

(LAMBDA NIL (PROG (PROC) (SETQ PROC QP.FIRST.PREDICATE) (until (NULL PROC) (if (QP.EMPTY.CLAUSES PROC)
 then (PRIN3 "No clauses for: ") (PRINT PROC))))))
)
(DEFPRINT (QUOTE QP.PROCEDURE.RECORD) (QUOTE QP.PROC.PRINT))

(ADDTOVAR GLOBALVARS
 QP.ATOM.PREDICATE)

(ADDTOVAR GLOBALVARS
 QP.FUNCTOR.PREDICATE)

(ADDTOVAR GLOBALVARS
 QP.FIRST.PREDICATE)
(PUTPROPS PROCS COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (3035 7938 (QP.ABOLISH 3045 . 3271) (QP.ATOM.PREDICATE 3273 . 3372) (
QP.COPY.PROCEDURE.RECORD 3374 . 3504) (QP.EMPTY.CLAUSES 3506 . 3589) (QP.FIRST.PREDICATE 3591 . 3647) 
(QP.FIRST.SYMBOL 3649 . 3711) (QP.FREE.PROCEDURE.RECORD 3713 . 3879) (QP.FUNCTOR.PREDICATE 3881 . 4013
) (QP.INIT.PROCEDURES 4015 . 4195) (QP.LOCAL.PREDICATE 4197 . 5708) (QP.MAKE.PROCEDURE.RECORD 5710 . 
6211) (QP.NEXT.SYMBOL 6213 . 6313) (QP.P.CHECK.PREDICATE 6315 . 6737) (QP.P.PROCEDURE 6739 . 6836) (
QP.PREDICATE 6838 . 6960) (QP.PREDINFO 6962 . 7155) (QP.PROC.PRINT 7157 . 7595) (QP.SASSOC 7597 . 7767
) (QP.UNDEF 7769 . 7936)))))
STOP