(FILECREATED " 2-Feb-86 18:51:36" {DSK}<LISPFILES2>PROCS.LSP;2 10403
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.LSP COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3467 10108 (QP.ABOLISH 3477 . 3762) (QP.ATOM.PREDICATE 3764 . 3880) (
QP.COPY.PROCEDURE.RECORD 3882 . 4054) (QP.EMPTY.CLAUSES 4056 . 4152) (QP.FIRST.PREDICATE 4154 . 4212)
(QP.FIRST.SYMBOL 4214 . 4290) (QP.FREE.PROCEDURE.RECORD 4292 . 4498) (QP.FUNCTOR.PREDICATE 4500 . 4671
) (QP.INIT.PROCEDURES 4673 . 4886) (QP.LOCAL.PREDICATE 4888 . 6975) (QP.MAKE.PROCEDURE.RECORD 6977 .
7660) (QP.NEXT.SYMBOL 7662 . 7801) (QP.P.CHECK.PREDICATE 7803 . 8393) (QP.P.PROCEDURE 8395 . 8512) (
QP.PREDICATE 8514 . 8668) (QP.PREDINFO 8670 . 8922) (QP.PROC.PRINT 8924 . 9607) (QP.SASSOC 9609 . 9871
) (QP.UNDEF 9873 . 10106)))))
STOP