(FILECREATED "10-Feb-86 19:25:48" {DSK}<LISPFILES2>SKEL.;1 12741
changes to: (VARS SKELCOMS)
previous date: " 7-Feb-86 00:18:40" {DSK}<LISPFILES2>SKEL.;1)
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT SKELCOMS)
(RPAQQ SKELCOMS ((MACROS QP.functor add.half get.half interpret.me len.term put.half put.term)
(FNS QP.CLAUSE QP.FREE.CLAUSE QP.HI.CODE R.fail.on.retry R.ignore.me R.ignore.me.but.keep.me
R.interpret.me R.load.cur.clause R.retry.at R.store.skeleton R.trap W.fail.on.retry
W.ignore.me W.ignore.me.but.keep.me W.interpret.me W.load.cur.clause W.retry.at W.trap)))
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.functor MACRO (X (APPLY (FUNCTION (LAMBDA (C)
(if (NEQ C (QUOTE C))
then
(SHOULDNT QP.functor))
(BQUOTE (get.cell (\, C)
1))))
X)))
(PUTPROPS add.half MACRO (X (APPLY (FUNCTION (LAMBDA (Base Offset)
(if (OR (NEQ Base (QUOTE C))
(NEQ Offset (QUOTE N)))
then
(SHOULDNT (QUOTE add.half)))
(BQUOTE (\ADDBASE (get.24 (\, Base))
(get.16 (\, Offset))))))
X)))
(PUTPROPS get.half MACRO (X (APPLY (FUNCTION (LAMBDA (Base Offset)
(if (OR (NEQ Base (QUOTE S))
(NOT (SMALLP Offset)))
then
(SHOULDNT (QUOTE get.half)))
(BQUOTE (\GETBASE (get.24 (\, Base))
(\, Offset)))))
X)))
(PUTPROPS interpret.me MACRO (OPENLAMBDA NIL (put.16 I (IDIFFERENCE (get.code P 6)
4))
(check.heap)
(put.Aval 2 (tag.struct H))
(put.24 S (add.code P 7))
(until (zero I)
(put.16 N (get.half S 0))
(if (ILESSP (get.16 N)
symbol.tag.16)
then
(\PUTBASEPTR (get.24 H)
0
(\ADDBASE (get.24 HB)
(get.half S 1)))
(\PUTBASEBYTE (get.24 H)
0
(LRSH (get.16 N)
8))
else
(put.half H 0 (get.16 N))
(put.half H 1 (get.half S 1)))
(increment.cell.pointer H)
(increment.cell.pointer S)
(decrement.counter I))
(put.24 CurClause (add.code P -1))
(put.32 T0 (get.Aval 1))
(put.32 T1 (get.Aval 2))
(unify.and.continue 3)))
(PUTPROPS len.term MACRO (OPENLAMBDA NIL (PROG NIL (put.16 N 32763)
(check.heap)
(put.24 S (get.24 H))
(put.word H 2 0)
(put.32 T0 (get.Aval 1))
L
(select.4 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
NIL)
(struct.tag.8
(put.24 R (untag.struct T0))
(put.32 T0 (get.cell R 0))
(put.16 I (arity.of T0))
(if (ILEQ (get.16 N)
(get.16 I))
then
(put.24 H (get.24 S))
(QP.OVERFLOW 20))
(put.16 N (IDIFFERENCE
(IDIFFERENCE (get.16 N)
(get.16 I))
1))
(put.16 I (SUB1 (get.16 I)))
(if (NOT (zero I))
then
(increment.cell.pointer H 3)
(put.addr H 0 (add.cell R 2))
(put.word H 2 (get.16 I)))
(put.32 T0 (get.cell R 1))
(reselect))
(list.tag.8 (put.24 R (untag.list T0))
(if (ILEQ (get.16 N)
1)
then
(put.24 H (get.24 S))
(QP.OVERFLOW 20))
(put.16 N (IDIFFERENCE
(get.16 N)
2))
(increment.cell.pointer H 3)
(put.addr H 0 (add.cell R 1))
(put.word H 2 1)
(put.32 T0 (get.cell R 0))
(reselect))
(PROGN))
(put.16 I (get.word H 2))
(if (zero I)
then
(put.16 N (IDIFFERENCE 32767 (get.16 N)))
(RETURN))
(put.24 R (get.addr H 0))
(decrement.counter I)
(if (zero I)
then
(decrement.cell.pointer H 3)
else
(put.addr H 0 (add.cell R 1))
(put.word H 2 (get.16 I)))
(put.32 T0 (get.cell R 0))
(GO L))))
(PUTPROPS put.half MACRO (X (APPLY (FUNCTION (LAMBDA (Base Offset Val)
(if (NOT (AND (MEMB Base
(QUOTE (H S C)))
(SMALLP Offset)))
then
(SHOULDNT (QUOTE put.half)))
(BQUOTE (\PUTBASE (get.24 (\, Base))
(\, Offset)
(\, Val)))))
X)))
(PUTPROPS put.term MACRO
(OPENLAMBDA
NIL
(PROG NIL (put.half C 0 (CONSTANT (QP.HI.CODE (QUOTE interpret.me))))
(put.half C 1 (CONSTANT (QP.HI.CODE (QUOTE fail.on.retry))))
(put.half C 6 0)
(put.half C 7 (get.16 N))
(put.24 S (add.cell C 1))
(put.24 C (add.cell C 4))
(put.16 N 0)
(put.32 T0 (get.Aval 1))
L
(select.4 T0 (ref.tag.8
(if (EQ (\GET.HI.16 T0)
ref.tag.16)
then
(put.cell S 0 (get.32 T0))
else
(put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(if (is.unbound T0 R)
then
(put.24 B0 (\VAG2 0 (IPLUS (LLSH (IDIFFERENCE (\GET.HI.16
S)
(\GET.HI.16
C))
16)
(IDIFFERENCE (\GET.LO.16 S)
(\GET.LO.16 C)))))
(put.32 T0 (tag.ref B0))
(put.cell S 0 (get.32 T0))
(bind.trail R T0)
else
(reselect))))
(struct.tag.8 (put.24 R (untag.struct T0))
(put.32 T0 (get.cell R 0))
(put.16 I (SUB1 (arity.of T0)))
(put.half S 0 struct.tag.16)
(put.half S 1 (get.16 N))
(put.24 S (add.half C N))
(put.cell S 0 (get.32 T0))
(if (NOT (zero I))
then
(increment.cell.pointer H 3)
(put.addr H 0 (add.cell R 2))
(put.addr H 1 (add.cell S 2))
(put.word H 2 (get.16 I)))
(put.32 T0 (get.cell R 1))
(increment.cell.pointer S)
(put.16 N (IPLUS (get.16 N)
(LLSH (get.16 I)
1)
4))
(reselect))
(list.tag.8 (put.half S 0 list.tag.16)
(put.half S 1 (get.16 N))
(put.24 S (add.half C N))
(put.16 N (IPLUS (get.16 N)
4))
(put.24 R (untag.list T0))
(put.32 T0 (get.cell R 0))
(increment.cell.pointer H 3)
(put.addr H 0 (add.cell R 1))
(put.addr H 1 (add.cell S 1))
(put.word H 2 1)
(reselect))
(PROGN (if (IGEQ (super.tag.of T0)
other.tag.16)
then
(\ADDREF (untag.immed T0)))
(put.cell S 0 (get.32 T0))))
(put.16 I (get.word H 2))
(if (zero I)
then
(RETURN))
(put.24 R (get.addr H 0))
(put.24 S (get.addr H 1))
(decrement.counter I)
(if (zero I)
then
(decrement.cell.pointer H 3)
else
(put.addr H 0 (add.cell R 1))
(put.addr H 1 (add.cell S 1))
(put.word H 2 (get.16 I)))
(put.32 T0 (get.cell R 0))
(GO L))))
)
(DEFINEQ
(QP.CLAUSE
(LAMBDA (CLAUSE)
(PROG (N I B TAG)
L (SETQ N (\GETBASE CLAUSE 0))
(SETQ I (if (EQ (LRSH N 8)
2)
then (ELT QP.opcode (IPLUS 256 (LOGAND N 255)))
else (ELT QP.opcode (LRSH N 8))))
(SETQ N (\GETBASE CLAUSE 1))
(SETQ B (if (EQ (LRSH N 8)
2)
then (ELT QP.opcode (IPLUS 256 (LOGAND N 255)))
else (ELT QP.opcode (LRSH N 8))))
(SETQ N (\GETBASE CLAUSE 7))
(PRINTOUT T "Clause @ " CLAUSE " [" I "; " B " " (\GETBASEPTR CLAUSE 2)
"; prev "
(\GETBASEPTR CLAUSE 4)
"; size " N "]" T)
(while (IGREATERP N 4)
(SETQ N (SUB1 N))
(SETQ TAG (\GETBASEBYTE CLAUSE (TIMES N 4)))
(PRINTOUT T N ": (" TAG ") " (\GETBASEBYTE CLAUSE (ADD1 (TIMES N 4)))
","
(\GETBASE CLAUSE (ADD1 (TIMES N 2)))
" "
(if (EQ TAG symbol.tag.8)
then (\VAG2 0 (\GETBASE CLAUSE (ADD1 (TIMES N 2))))
elseif (IGEQ TAG immed.tag.8)
then (\GETBASEPTR CLAUSE (TIMES N 2))
else "+")
T))
(if (EQ B (QUOTE R.retry.at))
then (SETQ CLAUSE (\GETBASEPTR CLAUSE 2))
(GO L)))))
(QP.FREE.CLAUSE
(LAMBDA (CLAUSE)
(PROG (I)
(if (NEQ (\GETBASE CLAUSE 6)
0)
then (RETURN (SHOULDNT "Clause freed twice")))
(\PUTBASE CLAUSE 6 55)
(SETQ I (LLSH (\GETBASE CLAUSE 7)
1))
(while (IGREATERP I 8)
(SETQ I (DIFFERENCE I 2))
(if (IGEQ (\GETBASE CLAUSE I)
other.tag.16)
then (\DELREF (\GETBASEPTR CLAUSE I))))
(\DELREF CLAUSE))))
(QP.HI.CODE
(LAMBDA (N)
(SETQ N (QP.OP.CODE N))
(if (LESSP N 256)
then (LLSH N 8)
else N)))
(R.fail.on.retry
(LAMBDA NIL
(put.24 B (get.addr B saved.B))
(put.24 HB (get.addr B saved.H))
(fast.fail)))
(R.ignore.me
(LAMBDA NIL
(continue.writing 0)))
(R.ignore.me.but.keep.me
(LAMBDA NIL
(continue.writing 0)))
(R.interpret.me
(LAMBDA NIL
(set.top.of.stack)
(put.cell R 0 (get.Aval 1))
(put.addr R 1 (get.24 B0))
(put.addr R 2 (get.24 E))
(put.addr R 3 (get.24 CP))
(put.addr R 4 (get.24 B))
(put.addr R 5 (get.24 P))
(put.addr R 6 (get.24 TR))
(put.addr R 7 (get.24 H))
(put.24 B (add.cell R 8))
(put.24 HB (get.24 H))
(check.stack B)
(interpret.me)))
(R.load.cur.clause
(LAMBDA NIL
(put.32 T1 (get.32 T0))
(put.32 T0 (tag.stack CurClause))
(continue 0)))
(R.retry.at
(LAMBDA NIL
(continue.writing.at (next.address.operand))))
(R.store.skeleton
(LAMBDA NIL
(put.24 CurClause 0)
(len.term)
(LET ((CurClause (\ALLOCBLOCK (get.16 N))))
(\ADDREF CurClause)
(put.24 C CurClause)
(put.term)
(put.24 CurClause CurClause))
(fast.fail)))
(R.trap
(LAMBDA NIL
(put.16 I (PROC.ARITY (get.24 C)))
(if (zero I)
then (put.Aval 1 (QP.functor C))
else (put.Amem 1 (get.Aval 1))
(put.Amem 2 (get.Aval 2))
(put.Amem 3 (get.Aval 3))
(put.Amem 4 (get.Aval 4))
(put.Aval 1 (tag.struct H))
(put.cell H 0 (QP.functor C))
(increment.cell.pointer H)
(put.24 S (loc.Amem 1))
(until (zero I)
(put.32 T0 (get.cell S 0))
(increment.cell.pointer S)
(select.4 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(if (before H R)
then (put.32 T0 (tag.ref H))
(bind.local R T0)))
(PROGN))
(put.cell H 0 (get.32 T0))
(increment.cell.pointer H)
(decrement.counter I)))
(put.Aval 2 (tag.other (get.24 C)))
(put.24 C (address.operand))
(do.execute)))
(W.fail.on.retry
(LAMBDA NIL
(fast.fail)))
(W.ignore.me
(LAMBDA NIL
(continue.reading 0)))
(W.ignore.me.but.keep.me
(LAMBDA NIL
(continue.reading 0)))
(W.interpret.me
(LAMBDA NIL
(put.Aval 1 (get.cell B -8))
(put.24 HB (get.24 H))
(put.addr B saved.BP (get.24 P))
(interpret.me)))
(W.load.cur.clause
(LAMBDA NIL
(put.32 T1 (get.32 T0))
(put.32 T0 (tag.stack CurClause))
(continue 0)))
(W.retry.at
(LAMBDA NIL
(continue.reading.at (next.address.operand))))
(W.trap
(LAMBDA NIL
(put.16 I (PROC.ARITY (get.24 C)))
(if (zero I)
then (put.Aval 1 (QP.functor C))
else (put.Amem 1 (get.Aval 1))
(put.Amem 2 (get.Aval 2))
(put.Amem 3 (get.Aval 3))
(put.Amem 4 (get.Aval 4))
(put.Aval 1 (tag.struct H))
(put.cell H 0 (QP.functor C))
(increment.cell.pointer H)
(put.24 S (loc.Amem 1))
(until (zero I)
(put.32 T0 (get.cell S 0))
(increment.cell.pointer S)
(select.4 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(if (before H R)
then (put.32 T0 (tag.ref H))
(bind.local R T0)))
(PROGN))
(put.cell H 0 (get.32 T0))
(increment.cell.pointer H)
(decrement.counter I)))
(put.Aval 2 (tag.other (get.24 C)))
(put.24 C (address.operand))
(do.execute)))
)
(PUTPROPS SKEL COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7076 12654 (QP.CLAUSE 7086 . 8474) (QP.FREE.CLAUSE 8476 . 8966) (QP.HI.CODE 8968 . 9108
) (R.fail.on.retry 9110 . 9235) (R.ignore.me 9237 . 9294) (R.ignore.me.but.keep.me 9296 . 9365) (
R.interpret.me 9367 . 9766) (R.load.cur.clause 9768 . 9889) (R.retry.at 9891 . 9971) (R.store.skeleton
9973 . 10236) (R.trap 10238 . 11173) (W.fail.on.retry 11175 . 11227) (W.ignore.me 11229 . 11286) (
W.ignore.me.but.keep.me 11288 . 11357) (W.interpret.me 11359 . 11510) (W.load.cur.clause 11512 . 11633
) (W.retry.at 11635 . 11715) (W.trap 11717 . 12652)))))
STOP