(FILECREATED " 8-Feb-86 15:20:24" {DSK}<LISPFILES2>IMPROVEDDCOMS>ASSERT.;1 9074
changes to: (VARS ASSERTCOMS) (RECORDS INDEX.BLOCK INDEX.HEADER INDEX.LINK))
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT ASSERTCOMS)
(RPAQQ ASSERTCOMS ((VARS (QP.INDEXP NIL)) (ADDVARS (GLOBALVARS QP.INDEXP)) (RECORDS INDEX.BLOCK
INDEX.HEADER INDEX.LINK) (CONSTANTS QX.C QX.L QX.S) (FNS QP.ADD.TO.CHAIN QP.ADD1.INDEX
QP.ASSERT.INDEXED QP.CLAUSES) (MACROS put.pair store.branch)))
(RPAQQ QP.INDEXP NIL)
(ADDTOVAR GLOBALVARS QP.INDEXP)
[DECLARE: EVAL@COMPILE
(DATATYPE INDEX.BLOCK ((NEXT FIXP) (MASK BITS 16) (COUNT BITS 16) (FIRST POINTER) (LAST POINTER) (
LIST POINTER) (TABLE POINTER)))
(DATATYPE INDEX.HEADER ((CELL FIXP) (LINK POINTER) (JUMP FIXP) (LAST POINTER)))
(DATATYPE INDEX.LINK ((LINK POINTER) (JUMP FIXP)))
]
(/DECLAREDATATYPE (QUOTE INDEX.BLOCK) (QUOTE (FIXP (BITS 16) (BITS 16) POINTER POINTER POINTER POINTER
)) (QUOTE ((INDEX.BLOCK 0 FIXP) (INDEX.BLOCK 2 (BITS . 15)) (INDEX.BLOCK 3 (BITS . 15)) (INDEX.BLOCK 4
POINTER) (INDEX.BLOCK 6 POINTER) (INDEX.BLOCK 8 POINTER) (INDEX.BLOCK 10 POINTER))) (QUOTE 12))
(/DECLAREDATATYPE (QUOTE INDEX.HEADER) (QUOTE (FIXP POINTER FIXP POINTER)) (QUOTE ((INDEX.HEADER 0
FIXP) (INDEX.HEADER 2 POINTER) (INDEX.HEADER 4 FIXP) (INDEX.HEADER 6 POINTER))) (QUOTE 8))
(/DECLAREDATATYPE (QUOTE INDEX.LINK) (QUOTE (POINTER FIXP)) (QUOTE ((INDEX.LINK 0 POINTER) (INDEX.LINK
2 FIXP))) (QUOTE 4))
(DECLARE: EVAL@COMPILE
(RPAQQ QX.C 32768)
(RPAQQ QX.L 8)
(RPAQQ QX.S 2048)
(CONSTANTS QX.C QX.L QX.S)
)
(DEFINEQ
(QP.ADD.TO.CHAIN
(LAMBDA (CHAIN CLAUSE KEY D) (PROG (LINK HEAD) (SETQ LINK (CREATE INDEX.LINK)) (\ADDREF LINK) (
store.branch LINK 0 (QUOTE trust.me.else) QP.FAILURE.CLAUSE) (store.branch LINK 2 (QUOTE jump.to) (
\ADDBASE (\ADDBASE CLAUSE 3) KEY)) (if (TYPENAMEP CHAIN (QUOTE INDEX.HEADER)) then (SETQ CHAIN (
\ADDBASE CHAIN (MINUS D))) (store.branch (fetch (INDEX.HEADER LAST) of CHAIN) 0 (QUOTE retry.me.else)
LINK) else (SETQ HEAD (CREATE INDEX.HEADER)) (\PUTBASE HEAD 0 (\GETBASE CLAUSE 3)) (\PUTBASE HEAD 1 (
\GETBASE CLAUSE 4)) (store.branch HEAD 2 (QUOTE try.me.else) LINK) (store.branch HEAD 4 (QUOTE jump.to
) (\ADDBASE CHAIN KEY)) (\ADDREF HEAD) (SETQ CHAIN HEAD)) (replace (INDEX.HEADER LAST) of CHAIN with
LINK)) (\ADDBASE CHAIN D)))
(QP.ADD1.INDEX
(LAMBDA (BLOCK) (PROG (MASK COUNT TABLE NEW BITS CHAIN K LINK NEXT) (SETQ MASK (fetch (INDEX.BLOCK
MASK) of BLOCK)) (SETQ COUNT (fetch (INDEX.BLOCK COUNT) of BLOCK)) (replace (INDEX.BLOCK COUNT) of
BLOCK with (ADD1 COUNT)) (if (ILEQ COUNT MASK) then (RETURN NIL)) (SETQ COUNT (LLSH COUNT 1)) (SETQ
MASK (SUB1 COUNT)) (replace (INDEX.BLOCK MASK) of BLOCK with MASK) (SETQ TABLE (fetch (INDEX.BLOCK
TABLE) of BLOCK)) (SETQ NEW (\ALLOCBLOCK COUNT)) (replace (INDEX.BLOCK TABLE) of BLOCK with NEW) (
until (EQ COUNT 0) (SETQ COUNT (IDIFFERENCE COUNT 2)) (SETQ BITS (\GETBASE TABLE COUNT)) (if (IGEQ
BITS QX.C) then (SETQ CHAIN (\GETBASEPTR TABLE COUNT)) (\DELREF CHAIN) (until (NULL CHAIN) (SETQ NEXT
(fetch (INDEX.LINK LINK) of CHAIN)) (SETQ K (LLSH (LOGAND (\GETBASE (\GETBASEPTR CHAIN 2) 1) MASK) 1))
(SETQ BITS (\GETBASE NEW K)) (if (IGEQ BITS QX.C) then (SETQ LINK (\GETBASEPTR NEW K)) (replace (
INDEX.LINK LINK) of CHAIN with (fetch (INDEX.LINK LINK) of LINK)) (replace (INDEX.LINK LINK) of LINK
with CHAIN) elseif (IGEQ BITS QX.S) then (SETQ LINK (CREATE INDEX.LINK LINK ← CHAIN)) (\PUTBASEPTR
LINK 2 (\GETBASEPTR NEW K)) (put.pair NEW K QX.C LINK) (\ADDREF LINK) (replace (INDEX.LINK LINK) of
CHAIN with NIL) else (put.pair NEW K QX.S (\GETBASEPTR CHAIN 2))) (SETQ CHAIN NEXT)) elseif (IGEQ BITS
QX.S) then (SETQ LINK (\GETBASEPTR TABLE COUNT)) (SETQ K (LLSH (LOGAND (\GETBASE LINK 1) MASK) 1)) (
put.pair NEW K QX.S LINK) else NIL)) (RETURN T))))
(QP.ASSERT.INDEXED
(LAMBDA (PROC CLAUSE FRONT) (PROG (KEY TABLE BLOCK LAST BITS LINK CHAIN K) (QP.SET.PREDICATE.STATE
PROC 1) (SELECTC (\GETBASE CLAUSE 2) ((QP.LEFT.OP.CODE (QUOTE get.Ai.constant)) (SETQ KEY T)) ((
QP.LEFT.OP.CODE (QUOTE get.Ai.structure)) (SETQ KEY T)) ((QP.LEFT.OP.CODE (QUOTE get.Ai.list)) (SETQ
KEY (QUOTE CONS))) (PROGN (SETQ KEY NIL))) (if (EQ (PROC.CLAUSES PROC) QP.UNDEFINED.CLAUSE) then (
store.branch CLAUSE 0 (QUOTE just.me.else) QP.FAILURE.CLAUSE) (if KEY then (SETQ TABLE (\ALLOCBLOCK 1)
) (if (EQ KEY (QUOTE CONS)) then (SETQ BLOCK (CREATE INDEX.BLOCK MASK ← 0 COUNT ← 0 FIRST ← CLAUSE
LAST ← CLAUSE TABLE ← TABLE)) (\PUTBASEPTR BLOCK QX.L (\ADDBASE CLAUSE 3)) elseif KEY then (put.pair
TABLE 0 QX.S (\ADDBASE CLAUSE 3)) (SETQ BLOCK (CREATE INDEX.BLOCK MASK ← 0 COUNT ← 1 FIRST ← CLAUSE
LAST ← CLAUSE TABLE ← TABLE)) (\PUTBASEPTR BLOCK QX.L QP.FAILURE.CLAUSE)) (\ADDREF BLOCK) (
store.branch BLOCK 0 (QUOTE just.index.else) QP.FAILURE.CLAUSE) (SETQ CLAUSE BLOCK)) (SETF (
PROC.CLAUSES PROC) CLAUSE) (SETF (PROC.LASTCLAUSE PROC) CLAUSE) elseif FRONT then (SHOULDNT
"c←asserta is not implemented yet") else (store.branch CLAUSE 0 (QUOTE trust.me.else)
QP.FAILURE.CLAUSE) (SETQ LAST (PROC.LASTCLAUSE PROC)) (if (NOT (TYPENAMEP LAST (QUOTE INDEX.BLOCK)))
then (if KEY then (SETQ TABLE (\ALLOCBLOCK 1)) (if (EQ KEY (QUOTE CONS)) then (SETQ BLOCK (CREATE
INDEX.BLOCK MASK ← 0 COUNT ← 0 FIRST ← CLAUSE LAST ← CLAUSE TABLE ← TABLE)) (\PUTBASEPTR BLOCK QX.L (
\ADDBASE CLAUSE 3)) elseif KEY then (put.pair TABLE 0 QX.S (\ADDBASE CLAUSE 3)) (SETQ BLOCK (CREATE
INDEX.BLOCK MASK ← 0 COUNT ← 1 FIRST ← CLAUSE LAST ← CLAUSE TABLE ← TABLE)) (\PUTBASEPTR BLOCK QX.L
QP.FAILURE.CLAUSE)) (\ADDREF BLOCK) (store.branch BLOCK 0 (QUOTE trust.index.else) QP.FAILURE.CLAUSE)
(SETQ CLAUSE BLOCK)) (SETF (PROC.LASTCLAUSE PROC) CLAUSE) else (SETQ BLOCK LAST) (SETQ LAST (fetch (
INDEX.BLOCK LAST) of BLOCK)) (if (NULL KEY) then (if (EQ (\GETBASEBYTE BLOCK 0) (CONSTANT (QP.OP.CODE
(QUOTE just.index.else)))) then (store.branch BLOCK 0 (QUOTE try.index.else) CLAUSE) else (
store.branch BLOCK 0 (QUOTE retry.index.else) CLAUSE)) (SETF (PROC.LASTCLAUSE PROC) CLAUSE) elseif (EQ
KEY (QUOTE CONS)) then (replace (INDEX.BLOCK LAST) of BLOCK with CLAUSE) (SETQ CHAIN (fetch (
INDEX.BLOCK LIST) of BLOCK)) (if (EQ CHAIN QP.FAILURE.CLAUSE) then (\PUTBASEPTR BLOCK QX.L (\ADDBASE
CLAUSE 3)) else (\PUTBASEPTR BLOCK QX.L (QP.ADD.TO.CHAIN CHAIN CLAUSE 0 2))) else (replace (
INDEX.BLOCK LAST) of BLOCK with CLAUSE) (SETQ TABLE (fetch (INDEX.BLOCK TABLE) of BLOCK)) (SETQ K (
LLSH (LOGAND (\GETBASE CLAUSE 4) (fetch (INDEX.BLOCK MASK) of BLOCK)) 1)) (SETQ BITS (\GETBASE TABLE K
)) (if (IGEQ BITS QX.C) then (SETQ CHAIN (\GETBASEPTR TABLE K)) (until (NULL CHAIN) (SETQ LINK (
\GETBASEPTR CHAIN 2)) (if (AND (EQ (\GETBASE CLAUSE 3) (\GETBASE LINK 0)) (EQ (\GETBASE CLAUSE 4) (
\GETBASE LINK 1))) then (\PUTBASEPTR CHAIN 2 (QP.ADD.TO.CHAIN LINK CLAUSE 2 0)) (RETURN (SETQ BITS -1)
)) (SETQ CHAIN (fetch (INDEX.LINK LINK) of CHAIN))) elseif (IGEQ BITS QX.S) then (SETQ LINK (
\GETBASEPTR TABLE K)) (if (AND (EQ (\GETBASE CLAUSE 3) (\GETBASE LINK 0)) (EQ (\GETBASE CLAUSE 4) (
\GETBASE LINK 1))) then (put.pair TABLE K QX.S (QP.ADD.TO.CHAIN LINK CLAUSE 2 0)) (SETQ BITS -1))) (if
(IGEQ BITS 0) then (if (QP.ADD1.INDEX BLOCK) then (SETQ TABLE (fetch (INDEX.BLOCK TABLE) of BLOCK)) (
SETQ K (LLSH (LOGAND (\GETBASE CLAUSE 4) (fetch (INDEX.BLOCK MASK) of BLOCK)) 1)) (SETQ BITS (\GETBASE
TABLE K))) (if (ILESSP BITS QX.S) then (put.pair TABLE K QX.S (\ADDBASE CLAUSE 3)) elseif (ILESSP
BITS QX.C) then (SETQ LINK (CREATE INDEX.LINK LINK ← NIL)) (\PUTBASEPTR LINK 2 (\ADDBASE CLAUSE 3)) (
SETQ LINK (CREATE INDEX.LINK LINK ← LINK)) (\PUTBASEPTR LINK 2 (\GETBASEPTR TABLE K)) (\ADDREF LINK) (
put.pair TABLE K QX.C LINK) else (SETQ CHAIN (\GETBASEPTR TABLE K)) (SETQ LINK (CREATE INDEX.LINK LINK
← (fetch (INDEX.LINK LINK) of CHAIN))) (\PUTBASEPTR LINK 2 (\ADDBASE CLAUSE 3)) (replace (INDEX.LINK
LINK) of CHAIN with LINK))))) (if (EQ (\GETBASEBYTE LAST 0) (CONSTANT (QP.OP.CODE (QUOTE just.me.else)
))) then (store.branch LAST 0 (QUOTE try.me.else) CLAUSE) else (store.branch LAST 0 (QUOTE
retry.me.else) CLAUSE))))))
(QP.CLAUSES
(LAMBDA (PROC CLAUSE CHAIN) (if (NOT (TYPENAMEP PROC (QUOTE QP.PROCEDURE.RECORD))) then (SETQ PROC (
QP.LOCAL.PREDICATE PROC (OR CLAUSE 0) (OR CHAIN (QUOTE si))))) (SETQ CHAIN NIL) (SETQ CLAUSE (
PROC.CLAUSES PROC)) (until (ATOM CLAUSE) (if (TYPENAMEP CLAUSE (QUOTE INDEX.BLOCK)) then (SETQ CLAUSE
(fetch (INDEX.BLOCK FIRST) of CLAUSE)) else (SETQ CHAIN (CONS CLAUSE CHAIN)) (SETQ CLAUSE (\GETBASEPTR
CLAUSE 0)) (if (EQ CLAUSE QP.FAILURE.CLAUSE) then (SETQ CLAUSE NIL)))) (DREVERSE CHAIN)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS put.pair MACRO (OPENLAMBDA (Base Offset Tag Ptr) (\PUTBASE Base Offset (IPLUS (\HILOC Ptr)
Tag)) (\PUTBASE Base (ADD1 Offset) (\LOLOC Ptr))))
(PUTPROPS store.branch MACRO (X (APPLY (FUNCTION (LAMBDA (Base Offset Tag Ptr) (BQUOTE (put.pair (\,
Base) (\, Offset) (CONSTANT (QP.LEFT.OP.CODE (\, Tag))) (\, Ptr))))) X)))
)
(PUTPROPS ASSERT COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1643 8630 (QP.ADD.TO.CHAIN 1653 . 2404) (QP.ADD1.INDEX 2406 . 3888) (QP.ASSERT.INDEXED
3890 . 8118) (QP.CLAUSES 8120 . 8628)))))
STOP