File [eris]<PrologCore>QP1.5>Sources>META!1

(FILECREATED " 8-Feb-86 15:53:06" {DSK}<LISPFILES2>IMPROVEDDCOMS>META.;1 14115  

      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 (LET ((A (untag.immed T0)) (B (untag.immed T1))) (if (EQ A B) then NIL elseif (LITATOM 
A) then (if (AND (LITATOM B) (ALPHORDER A B)) then (GO compare.less) else (GO compare.greater)) elseif
 (LITATOM B) then (GO compare.less) elseif (NOT (NUMBERP A)) then (if (NUMBERP B) then (GO 
compare.greater)) (if (STRINGP A) then (if (STRINGP B) then (LET ((C (ALPHORDER A B))) (if (NULL C) 
then (GO compare.greater)) (if (EQ C (QUOTE LESSP)) then (GO compare.less))) else (GO compare.greater)
) elseif (STRINGP B) then (GO compare.less) elseif (\BASELESSP A B) then (GO compare.less) else (GO 
compare.greater)) elseif (NOT (NUMBERP B)) then (GO compare.less) elseif (LESSP A B) then (GO 
compare.less) elseif (LESSP B A) then (GO compare.greater) else (if (FIXP A) then (if (FLOATP B) then 
(GO compare.less)) else (if (FIXP B) then (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 (LET ((A (untag.immed T0)) (B (untag.immed T1))) (if (EQ A B) then NIL elseif (LITATOM 
A) then (if (AND (LITATOM B) (ALPHORDER A B)) then (GO compare.less) else (GO compare.greater)) elseif
 (LITATOM B) then (GO compare.less) elseif (NOT (NUMBERP A)) then (if (NUMBERP B) then (GO 
compare.greater)) (if (STRINGP A) then (if (STRINGP B) then (LET ((C (ALPHORDER A B))) (if (NULL C) 
then (GO compare.greater)) (if (EQ C (QUOTE LESSP)) then (GO compare.less))) else (GO compare.greater)
) elseif (STRINGP B) then (GO compare.less) elseif (\BASELESSP A B) then (GO compare.less) else (GO 
compare.greater)) elseif (NOT (NUMBERP B)) then (GO compare.less) elseif (LESSP A B) then (GO 
compare.less) elseif (LESSP B A) then (GO compare.greater) else (if (FIXP A) then (if (FLOATP B) then 
(GO compare.less)) else (if (FIXP B) then (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 COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2175 13755 (R.arg 2185 . 2873) (R.compare 2875 . 6806) (R.functor 6808 . 7487) (R.is.a 
7489 . 7968) (W.arg 7970 . 8658) (W.compare 8660 . 12591) (W.functor 12593 . 13272) (W.is.a 13274 . 
13753)))))
STOP