(FILECREATED " 2-Feb-86 17:06:39" {DSK}<LISPFILES2>ASSERT.LSP;2 13074
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.LSP COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1833 12509 (QP.ADD.TO.CHAIN 1843 . 2876) (QP.ADD1.INDEX 2878 . 5093) (QP.ASSERT.INDEXED
5095 . 11808) (QP.CLAUSES 11810 . 12507)))))
STOP