(FILECREATED "13-Feb-85 15:35:11" {DSK}<LISPFILES2>LISP.;1 10858
changes to: (FNS QP.prologify)
(VARS LISPCOMS)
previous date: " 7-Feb-86 22:05:31" {DSK}<LISPFILES2>LISP.;1)
(* Copyright (c) 1986, 1985 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT LISPCOMS)
(RPAQQ LISPCOMS ((FNS QL QP.TERM.PRINT QP.lispify QP.lispify.cell QP.prologify R.call.lisp
R.send.direct.Ai R.send.direct.AiM R.send.variable.Ai R.send.variable.AiM
R.start.calling)
(CONSTANTS QP.AV)
(RECORDS PROLOG.TERM)
(P (DEFPRINT (QUOTE PROLOG.TERM)
(QUOTE QP.TERM.PRINT)))
(MACROS QP.lispify send.to.lisp)))
(DEFINEQ
(QL
(LAMBDA (N)
(SELECTQ N
(1 (QP.lispify.cell (ReadPrologTag A1)
(ReadPrologPtr A1)
T))
(2 (QP.lispify.cell (ReadPrologTag A2)
(ReadPrologPtr A2)
T))
(3 (QP.lispify.cell (ReadPrologTag A3)
(ReadPrologPtr A3)
T))
(4 (QP.lispify.cell (ReadPrologTag A4)
(ReadPrologPtr A4)
T))
(QP.lispify (add.cell QP.membot N)
T))))
(QP.TERM.PRINT
(LAMBDA (TERM STREAM)
(DECLARE (SPECVARS FN))
(if (STKPOS (QUOTE \MAPCHARS1))
then (\MAPCHARS1 (QUOTE %|%[)
NIL FN)
(\MAPCHARS1 (fetch PROLOG.FUNCTOR of TERM)
NIL FN)
(for ARG in (fetch PROLOG.ARGS of TERM)
do (\MAPCHARS1 (QUOTE % )
NIL FN)
(\MAPCHARS1 ARG NIL FN))
(\MAPCHARS1 (QUOTE %])
NIL FN)
else (PRIN1 (QUOTE %|%[))
(PRIN1 (fetch PROLOG.FUNCTOR of TERM))
(for ARG in (fetch PROLOG.ARGS of TERM)
do (PRIN1 (QUOTE % ))
(PRIN1 ARG))
(PRIN1 (QUOTE %])))
T))
(QP.lispify.cell
(LAMBDA (Tag Ptr Debug)
(PROG (A P)
L (SELECTC Tag
(ref.tag.8 (if (AND Debug (OR (\BASELESSP Ptr QP.membot)
(\BASELESSP QP.memtop Ptr)))
then (RETURN (CONS (QUOTE %.)
(CONS (QUOTE SHOULDNT)
(LOC Ptr)))))
(SETQ Tag (\GETBASEBYTE Ptr 0))
(SETQ P (\GETBASEPTR Ptr 0))
(if (OR (NEQ Tag ref.tag.8)
(NEQ P Ptr))
then (SETQ Ptr P)
(GO L))
(if (NOT Debug)
then (QP.OVERFLOW 21)
elseif (EQ Debug (QUOTE S))
then (RETURN Ptr)
else (RETURN (CONS (QUOTE %.)
(CONS (if (\BASELESSP Ptr
QP.init.E)
then (QUOTE Global)
else (QUOTE Local))
(LOC Ptr))))))
(list.tag.8 (SETQ P (\ADDBASE Ptr 2))
(RETURN (CONS (QP.lispify Ptr Debug)
(QP.lispify P Debug))))
(struct.tag.8 (SETQ A NIL)
(SETQ Tag (atom.of.cell Ptr))
(SETQ P (\ADDBASE Ptr (LLSH (arity.of.cell Ptr)
1)))
(until (EQ P Ptr)
(SETQ A (CONS (QP.lispify P Debug)
A))
(SETQ P (\ADDBASE P -2)))
(RETURN (CREATE PROLOG.TERM
PROLOG.FUNCTOR ← Tag
PROLOG.ARGS ← A)))
(RETURN Ptr)))))
(QP.prologify
(LAMBDA (Ptr C)
(PROG NIL
L (if (LITATOM Ptr)
then (\PUTBASEPTR C 0 Ptr)
(\PUTBASE C 0 symbol.tag.16)
elseif (SMALLP Ptr)
then (\PUTBASEPTR C 0 Ptr)
(\PUTBASEBYTE C 0 immed.tag.8)
elseif (LISTP Ptr)
then (\PUTBASEPTR C 0 (get.24 H))
(\PUTBASEBYTE C 0 list.tag.8)
(SETQ C (get.24 H))
(increment.cell.pointer H 2)
(check.heap)
(QP.prologify (CAR Ptr)
C)
(SETQ Ptr (CDR Ptr))
(SETQ C (\ADDBASE C 2))
(GO L)
elseif (TYPENAMEP Ptr (QUOTE PROLOG.TERM))
then (LET* ((A (fetch PROLOG.FUNCTOR of Ptr))
(L (fetch PROLOG.ARGS of Ptr))
(N (LENGTH L)))
(if (EQ N 0)
then (QP.prologify A C)
elseif (AND (EQ A (QUOTE %.))
(EQ N 2))
then (\PUTBASEPTR C 0 (get.24 H))
(\PUTBASEBYTE C 0 list.tag.8)
(SETQ C (get.24 H))
(increment.cell.pointer H 2)
(check.heap)
(QP.prologify (CAR L)
C)
(SETQ Ptr (CADR L))
(SETQ C (\ADDBASE C 2))
(GO L)
else (if (IGREATERP N 255)
then (SHOULDNT (QUOTE PROLOG.TERM)))
(if (NOT (LITATOM A))
then (SHOULDNT (QUOTE PROLOG.TERM)))
(\PUTBASEPTR C 0 (get.24 H))
(\PUTBASEBYTE C 0 struct.tag.8)
(SETQ C (get.24 H))
(\PUTBASEPTR C 0 A)
(\PUTBASE C 0 (IPLUS N symbol.tag.16))
(increment.cell.pointer H (IPLUS N 1))
(check.heap)
(until (NULL L)
(SETQ C (\ADDBASE C 2))
(QP.prologify (CAR L)
C)
(SETQ L (CDR L)))))
else (\PUTBASEPTR C 0 (QP.ADD.REF Ptr))
(\PUTBASEBYTE C 0 (if (FIXP Ptr)
then boxed.tag.8
elseif (FLOATP Ptr)
then float.tag.8
else other.tag.8))))))
(R.call.lisp
(LAMBDA NIL
(SETQ MV.RETURNER0 (SELECTC (get.16 I)
(0 (APPLY* (get.24 C)))
(1 (APPLY* (get.24 C)
MV.RETURNER0))
(2 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1))
(3 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2))
(4 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3))
(5 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4))
(6 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5))
(7 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6))
(8 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7))
(9 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8))
(10 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8 MV.RETURNER9))
(11 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8 MV.RETURNER9 MV.RETURNER10))
(12 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8 MV.RETURNER9 MV.RETURNER10
MV.RETURNER11))
(13 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8 MV.RETURNER9 MV.RETURNER10
MV.RETURNER11 MV.RETURNER12))
(14 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8 MV.RETURNER9 MV.RETURNER10
MV.RETURNER11 MV.RETURNER12 MV.RETURNER13))
(15 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8 MV.RETURNER9 MV.RETURNER10
MV.RETURNER11 MV.RETURNER12 MV.RETURNER13
MV.RETURNER14))
(16 (APPLY* (get.24 C)
MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3
MV.RETURNER4 MV.RETURNER5 MV.RETURNER6 MV.RETURNER7
MV.RETURNER8 MV.RETURNER9 MV.RETURNER10
MV.RETURNER11 MV.RETURNER12 MV.RETURNER13
MV.RETURNER14 MV.RETURNER15))
(SHOULDNT "Too many arguments in Lisp call")))
(LET ((R QP.AV)
(C (get.24 H))
(N (get.16 N)))
(put.24 S C)
(increment.cell.pointer H N)
(until (EQ N 0)
(QP.prologify (GETTOPVAL (CAR R))
C)
(SETQ R (CDR R))
(SETQ C (\ADDBASE C 2))
(SETQ N (IDIFFERENCE N 1))))
(read.continue 0)))
(R.send.direct.Ai
(LAMBDA NIL
(send.to.lisp (get.Aval N)
(QUOTE S))))
(R.send.direct.AiM
(LAMBDA NIL
(send.to.lisp (get.Amem N)
(QUOTE S))))
(R.send.variable.Ai
(LAMBDA NIL
(send.to.lisp (get.Aval N)
NIL)))
(R.send.variable.AiM
(LAMBDA NIL
(send.to.lisp (get.Amem N)
NIL)))
(R.start.calling
(LAMBDA NIL (* defined I C R)
(put.16 I (LOGAND (get.code P 0)
255))
(put.24 C (\VAG2 0 (get.code P 1)))
(put.24 R QP.AV)
(read.continue 2)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ QP.AV (MV.RETURNER0 MV.RETURNER1 MV.RETURNER2 MV.RETURNER3 MV.RETURNER4 MV.RETURNER5
MV.RETURNER6 MV.RETURNER7 MV.RETURNER8 MV.RETURNER9 MV.RETURNER10
MV.RETURNER11 MV.RETURNER12 MV.RETURNER13 MV.RETURNER14 MV.RETURNER15))
(CONSTANTS QP.AV)
)
[DECLARE: EVAL@COMPILE
(DATATYPE PROLOG.TERM ((PROLOG.FUNCTOR POINTER)
(PROLOG.ARGS POINTER)))
]
(/DECLAREDATATYPE (QUOTE PROLOG.TERM)
(QUOTE (POINTER POINTER))
(QUOTE ((PROLOG.TERM 0 POINTER)
(PROLOG.TERM 2 POINTER)))
(QUOTE 4))
(DEFPRINT (QUOTE PROLOG.TERM)
(QUOTE QP.TERM.PRINT))
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.lispify MACRO (OPENLAMBDA (Ptr Debug)
(QP.lispify.cell (\GETBASEBYTE Ptr 0)
(\GETBASEPTR Ptr 0)
Debug)))
(PUTPROPS send.to.lisp MACRO
(X (APPLY (FUNCTION (LAMBDA (VALUE Debug)
(BQUOTE (PROGN (put.32 T0 (\, VALUE))
(LET ((L (get.24 R))
(Tag (ReadPrologTag T0))
(Ptr (ReadPrologPtr T0)))
(SETTOPVAL (CAR L)
(if (IGEQ Tag immed.tag.8)
then Ptr else
(QP.lispify.cell
Tag Ptr (\, Debug))))
(put.24 R (CDR L)))
(read.continue 0)))))
X)))
)
(PUTPROPS LISP COPYRIGHT ("Quintus Computer Systems, Inc" 1986 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (666 9535 (QL 676 . 1177) (QP.TERM.PRINT 1179 . 1924) (QP.lispify.cell 1927 . 3492) (
QP.prologify 3494 . 5702) (R.call.lisp 5704 . 8947) (R.send.direct.Ai 8949 . 9036) (R.send.direct.AiM
9038 . 9126) (R.send.variable.Ai 9128 . 9207) (R.send.variable.AiM 9209 . 9289) (R.start.calling 9291
. 9533)))))
STOP