(FILECREATED " 2-Feb-86 18:45:16" {DSK}<LISPFILES2>META.LSP;2 17082
changes to: (VARS METACOMS))
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT METACOMS)
(RPAQQ METACOMS ((MACROS functor.ref functor.ref.symbol functor.void.args rest.of.arg super.tag.of)
(FNS R.arg R.compare R.functor R.is.a W.arg W.compare W.functor W.is.a)
(PROP (LO HI Ptr Tag)
QP.list.funct)))
(DECLARE: EVAL@COMPILE
(PUTPROPS functor.ref MACRO (OPENLAMBDA NIL (put.32 T1 (get.Aval 2))
(select.16 T1 (ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C)
(fast.fail))
(struct.tag.8 (fast.fail))
(list.tag.8 (fast.fail))
(symbol.tag.8 (functor.ref.symbol))
(PROGN (put.Aval 4 (tag.immed 0))
(unify.four.and.continue.reading)))))
(PUTPROPS functor.ref.symbol MACRO (OPENLAMBDA NIL (put.32 T0 (get.Aval 3))
(select.4 T0 (ref.tag.8 (put.24 C (untag.ref T0))
(put.32 T0 (get.cell C 0))
(reselect.when.bound T0 C)
(fast.fail))
(if (NEQ (super.tag.of T0)
(CONSTANT (IPLUS immed.tag.16
(\HILOC 0))))
then
(fast.fail)
elseif
(PROGN (put.16 I (\GET.LO.16 T0))
(zero I))
then
(put.32 T0 (tag.ref R))
(unify.and.continue 0)
elseif
(AND (EQ (get.16 I)
2)
(EQ (super.tag.of T1)
symbol.tag.16)
(EQ (untag.immed T1)
(QUOTE %.)))
then
(check.heap)
(put.32 T0 (tag.list H))
(functor.void.args)
elseif
(IGREATERP (get.16 I)
255)
then
(fast.fail)
else
(check.heap)
(put.32 T0 (tag.struct H))
(\PUT.HI.16 T1 (LOGOR (get.16 I)
symbol.tag.16))
(put.cell H 0 (get.32 T1))
(increment.cell.pointer H)
(functor.void.args)))))
(PUTPROPS functor.void.args MACRO (OPENLAMBDA NIL (bind.safely R T0)
(put.24 S (get.24 H))
(until (zero I)
(put.cell H 0 (tag.ref H))
(increment.cell.pointer H)
(decrement.counter I))
(continue.writing 0)))
(PUTPROPS rest.of.arg MACRO (OPENLAMBDA NIL (if (IGREATERP (get.16 I)
(get.16 N))
then
(fast.fail)
else
(put.32 T0 (get.cell C (get.16 I)))
(put.32 T1 (get.Aval 3))
(unify.and.continue 0))))
(PUTPROPS super.tag.of MACRO (X (APPLY (FUNCTION (LAMBDA (X)
(if (NOT (MEMB X (QUOTE (T0 T1))))
then
(SHOULDNT (QUOTE super.tag.of)))
(BQUOTE (\GET.HI.16 (\, X)))))
X)))
)
(DEFINEQ
(R.arg
(LAMBDA NIL
(put.32 T0 (get.Aval 1))
(select.4 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(fast.fail))
(if (NEQ (super.tag.of T0)
(CONSTANT (IPLUS immed.tag.16 (\HILOC 0))))
then (fast.fail)
elseif (PROGN (put.16 I (\GET.LO.16 T0))
(zero I))
then (fast.fail)
else (put.32 T1 (get.Aval 2))
(select.4 T1 (ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C)
(fast.fail))
(struct.tag.8 (put.24 C (untag.struct T1))
(put.16 N (arity.of.cell (get.24 C)))
(rest.of.arg))
(list.tag.8 (put.24 C (untag.list T1))
(decrement.cell.pointer C)
(put.16 N 2)
(rest.of.arg))
(PROGN (fast.fail)))))))
(R.compare
(LAMBDA NIL
(PROG NIL (* scratch S)
(put.24 S (get.24 H))
(put.word H 2 0)
(put.32 T0 (get.Aval 1))
(put.32 T1 (get.Aval 2))
(GO compare.one)
compare.const
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.const)
(GO compare.greater))
(struct.tag.8 (GO compare.less))
(list.tag.8 (GO compare.less))
(PROGN (GO compare.consts)))
compare.consts
(if (NOT (same.cell T0 T1))
then (put.24 R (untag.immed T0))
(put.24 C (untag.immed T1))
(if (NOT (EQP (get.24 R)
(get.24 C)))
then (if (ALPHORDER (get.24 R)
(get.24 C))
then (GO compare.less)
else (GO compare.greater))))
compare.next
(put.16 I (get.word H 2))
(if (zero I)
then (put.nb T0 0)
(GO compare.done))
(put.24 R (get.addr H 0))
(put.24 C (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 C 1))
(put.word H 2 (get.16 I)))
(put.32 T0 (get.cell R 0))
(put.32 T1 (get.cell C 0))
(GO compare.one)
compare.one
(SELECTC (tag.of T0)
(ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R compare.one)
(GO compare.ref))
(struct.tag.8 (GO compare.struct))
(list.tag.8 (GO compare.list))
(PROGN (GO compare.const)))
compare.struct
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.struct)
(GO compare.greater))
(struct.tag.8 (put.24 R (untag.struct T0))
(put.24 C (untag.struct T1))
(put.32 T0 (get.cell R 0))
(put.32 T1 (get.cell C 0))
(if (NOT (same.cell T0 T1))
then (GO compare.diff.structs))
(put.16 I (SUB1 (arity.of T0)))
(put.32 T0 (get.cell R 1))
(put.32 T1 (get.cell C 1))
(if (NOT (zero I))
then (increment.cell.pointer H 3)
(check.heap)
(put.addr H 0 (add.cell R 2))
(put.addr H 1 (add.cell C 2))
(put.word H 2 (get.16 I)))
(GO compare.one))
(list.tag.8 (put.24 R (untag.struct T0))
(put.32 T0 (get.cell R 0))
(put.32 T1 (QP.list.funct))
(GO compare.diff.structs))
(PROGN (GO compare.greater)))
compare.diff.structs
(if (ILESSP (arity.of T0)
(arity.of T1))
then (GO compare.less))
(if (ILESSP (arity.of T1)
(arity.of T0))
then (GO compare.greater))
(if (ALPHORDER (atom.of T0)
(atom.of T1))
then (GO compare.less)
else (GO compare.greater))
compare.list
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.list)
(GO compare.greater))
(struct.tag.8 (put.24 C (untag.struct T1))
(put.32 T1 (get.cell C 0))
(put.32 T0 (QP.list.funct))
(GO compare.diff.structs))
(list.tag.8 (put.24 R (untag.list T0))
(put.24 C (untag.list T1))
(put.32 T0 (get.cell R 0))
(put.32 T1 (get.cell C 0))
(increment.cell.pointer H 3)
(check.heap)
(put.addr H 0 (add.cell R 1))
(put.addr H 1 (add.cell C 1))
(put.word H 2 1)
(GO compare.one))
(PROGN (GO compare.greater)))
compare.ref
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.ref)
(if (before R C)
then (GO compare.less))
(if (before C R)
then (GO compare.greater))
(GO compare.next))
(PROGN (GO compare.less)))
compare.less
(put.nb T0 -1)
(GO compare.done)
compare.greater
(put.nb T0 1)
(GO compare.done)
compare.done
(put.24 H (get.24 S))
(RETURN (continue 0)))))
(R.functor
(LAMBDA NIL (* defined S)
(* scratch R C A4)
(put.32 T0 (get.Aval 1))
(select.4 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(functor.ref))
(struct.tag.8 (put.24 S (untag.struct T0))
(put.24 R (atom.of.cell (get.24 S)))
(put.Aval 1 (tag.symbol R))
(put.Aval 4 (tag.immed (arity.of.cell (get.24 S))))
(increment.cell.pointer S)
(unify.four.and.continue.reading))
(list.tag.8 (put.24 R (QUOTE %.))
(put.Aval 1 (tag.symbol R))
(put.Aval 4 (tag.immed 2))
(put.24 S (untag.list T0))
(unify.four.and.continue.reading))
(PROGN (put.Aval 1 (get.32 T0))
(put.Aval 4 (tag.immed 0))
(unify.four.and.continue.reading)))))
(R.is.a
(LAMBDA NIL
(put.32 T0 (get.Aval 1))
(select.16 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(put.16 I 1))
(struct.tag.8 (put.16 I 2))
(list.tag.8 (put.16 I 4))
(symbol.tag.8 (put.16 I 128))
(float.tag.8 (put.16 I 32))
(boxed.tag.8 (put.16 I 16))
(immed.tag.8 (put.16 I 8))
(other.tag.8 (put.16 I 64))
(PROGN (SHOULDNT (QUOTE is.a))))
(if (EQ (LOGAND (get.16 N)
(get.16 I))
0)
then (fast.fail)
else (continue 0))))
(W.arg
(LAMBDA NIL
(put.32 T0 (get.Aval 1))
(select.4 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(fast.fail))
(if (NEQ (super.tag.of T0)
(CONSTANT (IPLUS immed.tag.16 (\HILOC 0))))
then (fast.fail)
elseif (PROGN (put.16 I (\GET.LO.16 T0))
(zero I))
then (fast.fail)
else (put.32 T1 (get.Aval 2))
(select.4 T1 (ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C)
(fast.fail))
(struct.tag.8 (put.24 C (untag.struct T1))
(put.16 N (arity.of.cell (get.24 C)))
(rest.of.arg))
(list.tag.8 (put.24 C (untag.list T1))
(decrement.cell.pointer C)
(put.16 N 2)
(rest.of.arg))
(PROGN (fast.fail)))))))
(W.compare
(LAMBDA NIL
(PROG NIL (* scratch S)
(put.24 S (get.24 H))
(put.word H 2 0)
(put.32 T0 (get.Aval 1))
(put.32 T1 (get.Aval 2))
(GO compare.one)
compare.const
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.const)
(GO compare.greater))
(struct.tag.8 (GO compare.less))
(list.tag.8 (GO compare.less))
(PROGN (GO compare.consts)))
compare.consts
(if (NOT (same.cell T0 T1))
then (put.24 R (untag.immed T0))
(put.24 C (untag.immed T1))
(if (NOT (EQP (get.24 R)
(get.24 C)))
then (if (ALPHORDER (get.24 R)
(get.24 C))
then (GO compare.less)
else (GO compare.greater))))
compare.next
(put.16 I (get.word H 2))
(if (zero I)
then (put.nb T0 0)
(GO compare.done))
(put.24 R (get.addr H 0))
(put.24 C (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 C 1))
(put.word H 2 (get.16 I)))
(put.32 T0 (get.cell R 0))
(put.32 T1 (get.cell C 0))
(GO compare.one)
compare.one
(SELECTC (tag.of T0)
(ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R compare.one)
(GO compare.ref))
(struct.tag.8 (GO compare.struct))
(list.tag.8 (GO compare.list))
(PROGN (GO compare.const)))
compare.struct
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.struct)
(GO compare.greater))
(struct.tag.8 (put.24 R (untag.struct T0))
(put.24 C (untag.struct T1))
(put.32 T0 (get.cell R 0))
(put.32 T1 (get.cell C 0))
(if (NOT (same.cell T0 T1))
then (GO compare.diff.structs))
(put.16 I (SUB1 (arity.of T0)))
(put.32 T0 (get.cell R 1))
(put.32 T1 (get.cell C 1))
(if (NOT (zero I))
then (increment.cell.pointer H 3)
(check.heap)
(put.addr H 0 (add.cell R 2))
(put.addr H 1 (add.cell C 2))
(put.word H 2 (get.16 I)))
(GO compare.one))
(list.tag.8 (put.24 R (untag.struct T0))
(put.32 T0 (get.cell R 0))
(put.32 T1 (QP.list.funct))
(GO compare.diff.structs))
(PROGN (GO compare.greater)))
compare.diff.structs
(if (ILESSP (arity.of T0)
(arity.of T1))
then (GO compare.less))
(if (ILESSP (arity.of T1)
(arity.of T0))
then (GO compare.greater))
(if (ALPHORDER (atom.of T0)
(atom.of T1))
then (GO compare.less)
else (GO compare.greater))
compare.list
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.list)
(GO compare.greater))
(struct.tag.8 (put.24 C (untag.struct T1))
(put.32 T1 (get.cell C 0))
(put.32 T0 (QP.list.funct))
(GO compare.diff.structs))
(list.tag.8 (put.24 R (untag.list T0))
(put.24 C (untag.list T1))
(put.32 T0 (get.cell R 0))
(put.32 T1 (get.cell C 0))
(increment.cell.pointer H 3)
(check.heap)
(put.addr H 0 (add.cell R 1))
(put.addr H 1 (add.cell C 1))
(put.word H 2 1)
(GO compare.one))
(PROGN (GO compare.greater)))
compare.ref
(SELECTC (tag.of T1)
(ref.tag.8 (put.24 C (untag.ref T1))
(put.32 T1 (get.cell C 0))
(reselect.when.bound T1 C compare.ref)
(if (before R C)
then (GO compare.less))
(if (before C R)
then (GO compare.greater))
(GO compare.next))
(PROGN (GO compare.less)))
compare.less
(put.nb T0 -1)
(GO compare.done)
compare.greater
(put.nb T0 1)
(GO compare.done)
compare.done
(put.24 H (get.24 S))
(RETURN (continue 0)))))
(W.functor
(LAMBDA NIL (* defined S)
(* scratch R C A4)
(put.32 T0 (get.Aval 1))
(select.4 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(functor.ref))
(struct.tag.8 (put.24 S (untag.struct T0))
(put.24 R (atom.of.cell (get.24 S)))
(put.Aval 1 (tag.symbol R))
(put.Aval 4 (tag.immed (arity.of.cell (get.24 S))))
(increment.cell.pointer S)
(unify.four.and.continue.reading))
(list.tag.8 (put.24 R (QUOTE %.))
(put.Aval 1 (tag.symbol R))
(put.Aval 4 (tag.immed 2))
(put.24 S (untag.list T0))
(unify.four.and.continue.reading))
(PROGN (put.Aval 1 (get.32 T0))
(put.Aval 4 (tag.immed 0))
(unify.four.and.continue.reading)))))
(W.is.a
(LAMBDA NIL
(put.32 T0 (get.Aval 1))
(select.16 T0 (ref.tag.8 (put.24 R (untag.ref T0))
(put.32 T0 (get.cell R 0))
(reselect.when.bound T0 R)
(put.16 I 1))
(struct.tag.8 (put.16 I 2))
(list.tag.8 (put.16 I 4))
(symbol.tag.8 (put.16 I 128))
(float.tag.8 (put.16 I 32))
(boxed.tag.8 (put.16 I 16))
(immed.tag.8 (put.16 I 8))
(other.tag.8 (put.16 I 64))
(PROGN (SHOULDNT (QUOTE is.a))))
(if (EQ (LOGAND (get.16 N)
(get.16 I))
0)
then (fast.fail)
else (continue 0))))
)
(PUTPROPS QP.list.funct LO (LAMBDA NIL (\LOLOC (QUOTE %.))))
(PUTPROPS QP.list.funct HI (LAMBDA NIL (IPLUS symbol.tag.16 2)))
(PUTPROPS QP.list.funct Ptr (LAMBDA NIL (\VAG2 2 (\LOLOC (QUOTE %.)))))
(PUTPROPS QP.list.funct Tag (LAMBDA NIL symbol.tag.8))
(PUTPROPS META.LSP COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2874 16718 (R.arg 2884 . 3786) (R.compare 3788 . 8238) (R.functor 8240 . 9174) (R.is.a
9176 . 9799) (W.arg 9801 . 10703) (W.compare 10705 . 15155) (W.functor 15157 . 16091) (W.is.a 16093 .
16716)))))
STOP