(FILECREATED " 2-Feb-86 18:42:19" {DSK}<LISPFILES2>LOAD.LSP;2 30200
changes to: (VARS LOADCOMS))
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT LOADCOMS)
(RPAQQ LOADCOMS ((ADDVARS (GLOBALVARS QP.LAST.CLAUSE.RECORD)
(GLOBALVARS QP.CLAUSE.OFFSET)
(GLOBALVARS QP.DUMMY.CLAUSE)
(GLOBALVARS QP.DEBUG.CLAUSE)
(GLOBALVARS QP.INTERPRET.CLAUSE)
(GLOBALVARS QP.UNDEFINED.CLAUSE)
(GLOBALVARS QP.FAILURE.CLAUSE))
(MACROS QP.REGISTER.OR.MEMORY.1 \LEFTBYTE \RIGHTBYTE)
(FNS ASSEMBLE.CLAUSE QP.ADD.CLAUSE QP.ALLOCATE.CLAUSE.RECORD QP.AREG.REGISTER
QP.ATTACH.CLAUSE.RECORD QP.INITIALIZE.PROLOG QP.LOOK QP.LOOK.ATOM QP.LOOK.BYTE
QP.LOOK.BYTE.ATOM QP.LOOK.BYTE.BYTE QP.LOOK.BYTE.CELL QP.LOOK.BYTE.FUNCTOR QP.LOOK.CELL
QP.LOOK.CLAUSE QP.LOOK.CONSTANT QP.LOOK.EXTEND QP.LOOK.EXTEND.CELL QP.LOOK.EXTEND.WORD
QP.LOOK.FUNCTOR QP.LOOK.INSTR QP.LOOK.NULL QP.LOOK.OFFSET QP.LOOK.ONE.CLAUSE
QP.LOOK.OPCODE QP.LOOK.PROCEDURE QP.LOOK.SIZE.OFFSET QP.LOOK.SIZE.PROCEDURE QP.OBJ.TAG
QP.RECONSULT QP.STORE.INCORE QP.STORE.INDEX QP.STORE.INSTR QP.STORE.INSTR.AREG
QP.STORE.INSTR.ATOM QP.STORE.INSTR.BYTE QP.STORE.INSTR.BYTE.ATOM
QP.STORE.INSTR.BYTE.BYTE QP.STORE.INSTR.BYTE.CELL QP.STORE.INSTR.BYTE.FUNCTOR
QP.STORE.INSTR.CELL QP.STORE.INSTR.EXTEND QP.STORE.INSTR.EXTEND.CELL
QP.STORE.INSTR.EXTEND.WORD QP.STORE.INSTR.FUNCTOR QP.STORE.INSTR.NULL
QP.STORE.INSTR.OFFSET QP.STORE.INSTR.PROCEDURE QP.STORE.INSTR.SIZE.OFFSET
QP.STORE.INSTR.SIZE.PROCEDURE QP.TRAP.CLAUSE QP.UNIT.CLAUSE)
(VARS (QP.LAST.CLAUSE.RECORD NIL))))
(ADDTOVAR GLOBALVARS QP.LAST.CLAUSE.RECORD)
(ADDTOVAR GLOBALVARS QP.CLAUSE.OFFSET)
(ADDTOVAR GLOBALVARS QP.DUMMY.CLAUSE)
(ADDTOVAR GLOBALVARS QP.DEBUG.CLAUSE)
(ADDTOVAR GLOBALVARS QP.INTERPRET.CLAUSE)
(ADDTOVAR GLOBALVARS QP.UNDEFINED.CLAUSE)
(ADDTOVAR GLOBALVARS QP.FAILURE.CLAUSE)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.REGISTER.OR.MEMORY.1 MACRO (**MACROARG** (LET ((AREG (CAR (NTH **MACROARG** 1)))
(OPCODE (CAR (NTH **MACROARG** 2))))
(BQUOTE (COND
((GREATERP (\, AREG)
4)
(SETQ (\, OPCODE)
(IPLUS 512 (\, OPCODE))))
(T (SETQ (\, AREG)
(QP.AREG.REGISTER
(\, AREG)))))))))
(PUTPROPS \LEFTBYTE MACRO (X (APPLY (FUNCTION (LAMBDA (BASE OFFSET)
(BQUOTE (\GETBASEBYTE (\, BASE)
(Twice (\, OFFSET)
0)))))
X)))
(PUTPROPS \RIGHTBYTE MACRO (X (APPLY (FUNCTION (LAMBDA (BASE OFFSET)
(BQUOTE (\GETBASEBYTE (\, BASE)
(Twice (\, OFFSET)
1)))))
X)))
)
(DEFINEQ
(ASSEMBLE.CLAUSE
(NLAMBDA THEARGS
(LET* ((PROCLIST (CAR THEARGS))
(PROC (QP.LOCAL.PREDICATE (CAR PROCLIST)
(CADR PROCLIST)
(CADDR PROCLIST)))
(LENGTH (CADR THEARGS))
(INSTRS (CDDR THEARGS))
(CLAUSEPTR (QP.CLAUSE.ALLOC (IPLUS 3 LENGTH))))
(SETQ QP.CLAUSE.OFFSET 2)
(PROG ((INSTRS INSTRS))
LP (COND
((NULL INSTRS)
(RETURN NIL))
(T (LET ((INSTR (CAR INSTRS)))
(SETQ INSTRS (CDR INSTRS))
(QP.STORE.INSTR CLAUSEPTR (CAR INSTR)
(CADR INSTR)
(CADDR INSTR)
(CADDDR INSTR)
(CAR (CDDDDR INSTR))))
(GO LP))))
(if QP.INDEXP
then (QP.ADD.CLAUSE CLAUSEPTR PROC)
else (QP.ASSERT.INDEXED PROC CLAUSEPTR NIL)))))
(QP.ADD.CLAUSE
(LAMBDA (CLAUSE PROCRECORD)
(COND
((EQ (QP.GET.PREDICATE.STATE PROCRECORD)
0)
(SETF (PROC.CLAUSES PROCRECORD)
CLAUSE)
(SETF (PROC.LOFLAG PROCRECORD)
1)
(QP.STORE.INDEX CLAUSE (QUOTE just.me.else)))
((EQ (\GETBASEBYTE (PROC.LASTCLAUSE PROCRECORD)
0)
(QP.OP.CODE (QUOTE just.me.else)))
(QP.STORE.INDEX (PROC.LASTCLAUSE PROCRECORD)
(QUOTE try.me.else)
CLAUSE)
(QP.STORE.INDEX CLAUSE (QUOTE trust.me.else)))
((EQ (\GETBASEBYTE (PROC.LASTCLAUSE PROCRECORD)
0)
(QP.OP.CODE (QUOTE trust.me.else)))
(QP.STORE.INDEX (PROC.LASTCLAUSE PROCRECORD)
(QUOTE retry.me.else)
CLAUSE)
(QP.STORE.INDEX CLAUSE (QUOTE trust.me.else))))
(SETF (PROC.LASTCLAUSE PROCRECORD)
CLAUSE)))
(QP.ALLOCATE.CLAUSE.RECORD
(LAMBDA (SIZE)
(SETQ QP.CLAUSE.OFFSET 2)
(SETQ QP.LAST.CLAUSE.RECORD (QP.CLAUSE.ALLOC (IPLUS SIZE 3)))))
(QP.AREG.REGISTER
(LAMBDA (AREG)
(ITIMES 2 (IDIFFERENCE AREG 1))))
(QP.ATTACH.CLAUSE.RECORD
(LAMBDA (PROC)
(if QP.INDEXP
then (QP.ADD.CLAUSE QP.LAST.CLAUSE.RECORD PROC)
else (QP.ASSERT.INDEXED PROC QP.LAST.CLAUSE.RECORD))))
(QP.INITIALIZE.PROLOG
(LAMBDA NIL
(QP.INIT.PROCEDURES)
(SETQ BYTE.BUFFER.LENGTH 0)
(SETQ BYTE.BUFFER (ALLOCSTRING 4096 0 BYTE.BUFFER))
(QP.INIT.IO)
(SETQ QP.SCRATCH.STRING (ALLOCSTRING 256))
(PROG ((X (\ALLOCBLOCK 5)))
(\PUTBASE X 0 (QP.OP.CODE (QUOTE ignore.me)))
(\PUTBASE X 1 (QP.OP.CODE (QUOTE fail.on.retry)))
(\PUTBASEPTR X 2 NIL)
(\PUTBASEPTR X 4 NIL)
(\PUTBASEPTR X 6 0)
(\PUTBASEPTR X 8 0)
(SETQ QP.DUMMY.CLAUSE X))
(QP.TRAP.CLAUSE QP.UNDEFINED.CLAUSE $interpreter←hook
2 interp)
(QP.TRAP.CLAUSE QP.INTERPRET.CLAUSE $interpreter←hook
2 interp)
(QP.TRAP.CLAUSE QP.DEBUG.CLAUSE $debug←trap
2 interp)
(QP.UNIT.CLAUSE apply apply 3 si)
(QP.UNIT.CLAUSE store.skeleton store←skeleton
1 si)
(SETQ QP.FAILURE.CLAUSE (QP.UNIT.CLAUSE fail fail 0 si))
(ASSEMBLE.CLAUSE (portray 1 user)
1
(fail))
T))
(QP.LOOK
(LAMBDA (PROC ARITY MODULE)
(PROG (CLAUSE)
(COND
((NOT (TYPENAMEP PROC (QUOTE QP.PROCEDURE.RECORD)))
(SETQ PROC (QP.LOCAL.PREDICATE PROC (OR ARITY 0)
(OR MODULE (QUOTE si))))))
(SETQ CLAUSE (PROC.CLAUSES PROC))
(COND
((EQ CLAUSE QP.EMPTY.PROC.ADDRESS)
(PRIN3 "No clauses for this procedure (0!!!)")
(RETURN))
((EQ CLAUSE QP.UNDEFINED.CLAUSE)
(PRIN3 "No clauses for this procedure")
(RETURN)))
L (COND
((TYPENAMEP CLAUSE (QUOTE INDEX.BLOCK))
(SETQ CLAUSE (\GETBASEPTR CLAUSE 4))))
(TERPRI)
(QP.LOOK.ONE.CLAUSE CLAUSE)
(SETQ CLAUSE (\GETBASEPTR CLAUSE 0))
(COND
((NEQ CLAUSE QP.FAILURE.CLAUSE)
(GO L))))))
(QP.LOOK.ATOM
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (\VAG2 0 (\GETBASE CLAUSE (ADD1 QP.CLAUSE.OFFSET)))))
(INCR QP.CLAUSE.OFFSET 2)))
(QP.LOOK.BYTE
(LAMBDA (CLAUSE INSTR TYPE)
(PRINT (LIST INSTR (LET ((BYTE (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET)))
(SELECTQ TYPE
((a1 byte)
BYTE)
(y1 (IDIFFERENCE BYTE QP.PERMANENT.OFFSET))
(SHOULDNT)))))
(INCR QP.CLAUSE.OFFSET)))
(QP.LOOK.BYTE.ATOM
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET)
(\VAG2 0 (\GETBASE CLAUSE (ADD1 QP.CLAUSE.OFFSET)))))
(INCR QP.CLAUSE.OFFSET 2)))
(QP.LOOK.BYTE.BYTE
(LAMBDA (CLAUSE INSTR REVERSAL TYPE2)
(LET ((SRC1 (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET))
(SRC2 (\RIGHTBYTE CLAUSE (ADD1 QP.CLAUSE.OFFSET)))
DEST1 DEST2)
(COND
((EQ REVERSAL (QUOTE REVERSED))
(SETQ DEST1 SRC2)
(SETQ DEST2 SRC1))
(T (SETQ DEST1 SRC1)
(SETQ DEST2 SRC2)))
(PRINT (LIST INSTR DEST1 (COND
((EQ TYPE2 (QUOTE PERMANENT))
(IDIFFERENCE DEST2 QP.PERMANENT.OFFSET))
(T DEST2))))
(INCR QP.CLAUSE.OFFSET 2))))
(QP.LOOK.BYTE.CELL
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET)
(\GETBASEPTR CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.LOOK.BYTE.FUNCTOR
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET)
(\VAG2 0 (\GETBASE CLAUSE (IPLUS 2 QP.CLAUSE.OFFSET)))
(\RIGHTBYTE CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.LOOK.CELL
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (\VAG2 (\RIGHTBYTE CLAUSE (ADD1 QP.CLAUSE.OFFSET))
(\GETBASE CLAUSE (IPLUS QP.CLAUSE.OFFSET 2)))))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.LOOK.CLAUSE
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (LIST (QUOTE CLAUSE)
(\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET)
(\GETBASE CLAUSE (ADD1 QP.CLAUSE.OFFSET)))))
(INCR QP.CLAUSE.OFFSET 2)))
(QP.LOOK.CONSTANT
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (\GETBASEPTR CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.LOOK.EXTEND
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR))
(INCR QP.CLAUSE.OFFSET)))
(QP.LOOK.EXTEND.CELL
(LAMBDA (CLAUSE INSTR)
(LET* ((CELL (\GETBASEPTR CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(PRINT (LIST INSTR CELL))
(INCR QP.CLAUSE.OFFSET 3))))
(QP.LOOK.EXTEND.WORD
(LAMBDA (CLAUSE INSTR)
(LET ((WORD (\GETBASE CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(PRINT (LIST INSTR (RSH (LLSH WORD 16)
16)))
(INCR QP.CLAUSE.OFFSET 2))))
(QP.LOOK.FUNCTOR
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR (\VAG2 0 (\GETBASE CLAUSE (IPLUS 2 QP.CLAUSE.OFFSET)))
(\RIGHTBYTE CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.LOOK.INSTR
(LAMBDA (CLAUSE)
(LET* ((OPCODE (\LEFTBYTE CLAUSE QP.CLAUSE.OFFSET))
(FIELDS (CADDR (GETHASH OPCODE QP.INSTRUCTION.HARRAY)))
(INSTR (CAR (GETHASH OPCODE QP.INSTRUCTION.HARRAY)))
(MAYBESTAR (CADR (GETHASH OPCODE QP.INSTRUCTION.HARRAY))))
(TAB 4)
(COND
((EQ MAYBESTAR (QUOTE *))
(LET* ((INSTR2 FIELDS)
(OPCODE2 (GETHASH INSTR2 QP.INSTRUCTION.HARRAY))
(FIELDS2 (CADDR (GETHASH OPCODE2 QP.INSTRUCTION.HARRAY))))
(QP.LOOK.OPCODE CLAUSE OPCODE FIELDS2 INSTR)))
(T (QP.LOOK.OPCODE CLAUSE OPCODE FIELDS INSTR))))))
(QP.LOOK.NULL
(LAMBDA (CLAUSE INSTR)
(PRINT (LIST INSTR))
(INCR QP.CLAUSE.OFFSET)))
(QP.LOOK.OFFSET
(LAMBDA (CLAUSE INSTR)
(LET* ((CLAUSE.HILOC (\HILOC CLAUSE))
(CLAUSE.LOLOC (\LOLOC CLAUSE))
(CLAUSE.BEGIN (IPLUS (LLSH CLAUSE.HILOC 16)
CLAUSE.LOLOC))
(INSTR.ADDR (IPLUS (ITIMES (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET)
65536)
(\GETBASE CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(OFFSET (IDIFFERENCE INSTR.ADDR CLAUSE.BEGIN)))
(PRINT (LIST INSTR (QUOTE +)
OFFSET))
(INCR QP.CLAUSE.OFFSET 2))))
(QP.LOOK.ONE.CLAUSE
(LAMBDA (CLAUSE)
(PROG NIL
(SETQ QP.CLAUSE.OFFSET 0)
LP (COND
((QP.LOOK.INSTR CLAUSE)
(GO LP))))))
(QP.LOOK.OPCODE
(LAMBDA (CLAUSE OPCODE FIELDS INSTR)
(COND
((EQ OPCODE 0)
NIL)
((EQ OPCODE QP.EXTENSION.OPCODE)
(LET* ((EXTENSION (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET))
(INSTR2 (CAR (GETHASH EXTENSION QP.EXTENSION.HARRAY)))
(FIELDS2 (CDR (GETHASH EXTENSION QP.EXTENSION.HARRAY))))
(COND
((EQUAL FIELDS2 (QUOTE (extend word)))
(QP.LOOK.EXTEND.WORD CLAUSE INSTR2))
((EQUAL FIELDS2 (QUOTE (extend cell)))
(QP.LOOK.EXTEND.CELL CLAUSE INSTR2))
(T (QP.LOOK.EXTEND CLAUSE INSTR2)))))
((EQUAL FIELDS NIL)
(QP.LOOK.NULL CLAUSE INSTR))
((MEMBER FIELDS (QUOTE ((byte)
(y1)
(a1))))
(QP.LOOK.BYTE CLAUSE INSTR (CAR FIELDS)))
((EQUAL FIELDS (QUOTE (cell)))
(QP.LOOK.CELL CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (functor)))
(QP.LOOK.FUNCTOR CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (atom)))
(QP.LOOK.ATOM CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (a1 cell)))
(QP.LOOK.BYTE.CELL CLAUSE INSTR))
((MEMBER FIELDS (QUOTE ((a1 y2)
(a2 y1)
(a2 a1)
(a1 a2))))
(QP.LOOK.BYTE.BYTE CLAUSE INSTR (SELECTQ (CAR FIELDS)
(a1 (QUOTE NORMAL))
(a2 (QUOTE REVERSED))
(SHOULDNT))
(SELECTQ (CADR FIELDS)
((y1 y2)
(QUOTE PERMANENT))
((a1 a2)
(QUOTE ARGUMENT))
(SHOULDNT))))
((EQUAL FIELDS (QUOTE (a1 functor)))
(QP.LOOK.BYTE.FUNCTOR CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (a1 atom)))
(QP.LOOK.BYTE.ATOM CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (size procedure)))
(QP.LOOK.SIZE.PROCEDURE CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (size offset)))
(QP.LOOK.SIZE.OFFSET CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (procedure)))
(QP.LOOK.PROCEDURE CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (offset)))
(QP.LOOK.OFFSET CLAUSE INSTR))
((EQUAL FIELDS (QUOTE (clause)))
(QP.LOOK.CLAUSE CLAUSE INSTR))
(T (PRINT (LIST OPCODE INSTR FIELDS))
(SHOULDNT)))))
(QP.LOOK.PROCEDURE
(LAMBDA (CLAUSE INSTR)
(PRINT (CONS INSTR (QP.P.PROCEDURE (\GETBASEPTR CLAUSE QP.CLAUSE.OFFSET))))
(INCR QP.CLAUSE.OFFSET 2)))
(QP.LOOK.SIZE.OFFSET
(LAMBDA (CLAUSE INSTR)
(LET* ((CLAUSE.HILOC (\HILOC CLAUSE))
(CLAUSE.LOLOC (\LOLOC CLAUSE))
(CLAUSE.BEGIN (IPLUS (LLSH CLAUSE.HILOC 16)
CLAUSE.LOLOC))
(INSTR.ADDR (IPLUS (ITIMES (\RIGHTBYTE CLAUSE QP.CLAUSE.OFFSET)
65536)
(\GETBASE CLAUSE (ADD1 QP.CLAUSE.OFFSET))))
(OFFSET (IDIFFERENCE INSTR.ADDR CLAUSE.BEGIN)))
(PRINT (LIST INSTR (IQUOTIENT (\GETBASE CLAUSE (IPLUS QP.CLAUSE.OFFSET 2))
2)
(QUOTE +)
OFFSET))
(INCR QP.CLAUSE.OFFSET 3))))
(QP.LOOK.SIZE.PROCEDURE
(LAMBDA (CLAUSE INSTR)
(PRINT (NCONC (LIST INSTR (IQUOTIENT (\GETBASE CLAUSE (IPLUS QP.CLAUSE.OFFSET 2))
2))
(QP.P.PROCEDURE (\GETBASEPTR CLAUSE QP.CLAUSE.OFFSET))))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.OBJ.TAG
(LAMBDA (OBJ)
(SELECTQ (TYPENAME OBJ)
(LITATOM symbol.tag.16)
(SMALLP immed.tag.16)
(FIXP boxed.tag.16)
(FLOATP float.tag.16)
(BIGNUM boxed.tag.16)
(SHOULDNT (QUOTE QP.OBJ.TAG)))))
(QP.RECONSULT
(LAMBDA (FILE)
(LET ((FORM NIL)
(TABLE (HASHARRAY 500 1.5))
(STREAM (OPENSTREAM FILE (QUOTE INPUT))))
(UNTIL (EQ (SETQ FORM (READ STREAM T))
(QUOTE STOP))
DO (PROGN (COND
((EQ (CAR FORM)
(QUOTE ASSEMBLE.CLAUSE))
(LET* ((PROC (CADR FORM))
(NAME (CAR PROC))
(ARITY (CADR PROC))
(MODULE (CADDR PROC))
(PROCREC (QP.LOCAL.PREDICATE NAME ARITY MODULE)))
(COND
((NOT (GETHASH PROCREC TABLE))
(PUTHASH PROCREC T TABLE)
(QP.ABOLISH NAME ARITY MODULE)))
(EVAL FORM)))
(T (EVAL FORM)))))
(PRINT (CLOSEF STREAM)))))
(QP.STORE.INCORE
(LAMBDA (INSTR ARG1 ARG2 ARG3 ARG4)
(QP.STORE.INSTR QP.LAST.CLAUSE.RECORD INSTR ARG1 ARG2 ARG3 ARG4)))
(QP.STORE.INDEX
(LAMBDA (CLAUSE INSTR NEXTCLAUSE)
(\PUTBASEPTR CLAUSE 0 (OR NEXTCLAUSE QP.FAILURE.CLAUSE))
(\PUTBASE CLAUSE 0 (IPLUS (\GETBASE CLAUSE 0)
(QP.LEFT.OP.CODE INSTR)))))
(QP.STORE.INSTR
(LAMBDA ARGLIST
(LET* ((CLAUSE (ARG ARGLIST 1))
(INSTR (ARG ARGLIST 2))
(OPCODE (GETHASH INSTR QP.INSTRUCTION.HARRAY))
(FIELDS (CADR (GETHASH OPCODE QP.INSTRUCTION.HARRAY))))
(COND
((EQUAL INSTR (QUOTE load.pvar.address))
(SHOULDNT (QUOTE load.pvar.address)))
((EQUAL OPCODE QP.EXTENSION.OPCODE)
(LET ((TYPE (CADDR (GETHASH (GETHASH INSTR QP.EXTENSION.HARRAY)
QP.EXTENSION.HARRAY))))
(COND
((EQ TYPE (QUOTE word))
(QP.STORE.INSTR.EXTEND.WORD CLAUSE INSTR (ARG ARGLIST 3)))
((EQ TYPE (QUOTE cell))
(QP.STORE.INSTR.EXTEND.CELL CLAUSE INSTR (ARG ARGLIST 3)))
(T (QP.STORE.INSTR.EXTEND CLAUSE INSTR)))))
(T (SELECTQ FIELDS
(NIL (QP.STORE.INSTR.NULL CLAUSE INSTR))
(a1.cell (QP.STORE.INSTR.BYTE.CELL CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)))
(a1.atom (QP.STORE.INSTR.BYTE.ATOM CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)))
(a1.functor (QP.STORE.INSTR.BYTE.FUNCTOR CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)
(ARG ARGLIST 5)))
(a1.y2 (QP.STORE.INSTR.BYTE.BYTE CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)
(QUOTE a1)
(QUOTE y2)))
(a2.y1 (QP.STORE.INSTR.BYTE.BYTE CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)
(QUOTE a2)
(QUOTE y1)))
(a2.a1 (QP.STORE.INSTR.BYTE.BYTE CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)
(QUOTE a2)
(QUOTE a1)))
(a1.a2 (QP.STORE.INSTR.BYTE.BYTE CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)
(QUOTE a1)
(QUOTE a2)))
(a1 (QP.STORE.INSTR.AREG CLAUSE INSTR (ARG ARGLIST 3)))
(y1 (QP.STORE.INSTR.BYTE CLAUSE INSTR (ARG ARGLIST 3)
(QUOTE y1)))
(byte (QP.STORE.INSTR.BYTE CLAUSE INSTR (ARG ARGLIST 3)
(QUOTE byte)))
(cell (QP.STORE.INSTR.CELL CLAUSE INSTR (ARG ARGLIST 3)))
(functor (QP.STORE.INSTR.FUNCTOR CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)))
(atom (QP.STORE.INSTR.ATOM CLAUSE INSTR (ARG ARGLIST 3)))
(size.procedure (QP.STORE.INSTR.SIZE.PROCEDURE CLAUSE INSTR
(ARG ARGLIST 3)
(ARG ARGLIST 4)
(ARG ARGLIST 5)
(ARG ARGLIST 6)))
(size.offset (QP.STORE.INSTR.SIZE.OFFSET CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)))
(offset (QP.STORE.INSTR.OFFSET CLAUSE INSTR (ARG ARGLIST 3)))
(procedure (QP.STORE.INSTR.PROCEDURE CLAUSE INSTR (ARG ARGLIST 3)
(ARG ARGLIST 4)
(ARG ARGLIST 5)))
(PROGN (PRINT (LIST OPCODE INSTR FIELDS))
(SHOULDNT))))))))
(QP.STORE.INSTR.AREG
(LAMBDA (CLAUSEPTR INSTR BYTE)
(LET ((OPCODE (QP.LEFT.OP.CODE INSTR)))
(QP.REGISTER.OR.MEMORY.1 BYTE OPCODE)
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS BYTE OPCODE))
(INCR QP.CLAUSE.OFFSET 1))))
(QP.STORE.INSTR.ATOM
(LAMBDA (CLAUSEPTR INSTR ATOM)
(LET ((PLACE (\ADDBASE CLAUSEPTR QP.CLAUSE.OFFSET)))
(\PUTBASE PLACE 0 (QP.LEFT.OP.CODE INSTR))
(\PUTBASE PLACE 1 (\LOLOC ATOM)))
(INCR QP.CLAUSE.OFFSET 2)))
(QP.STORE.INSTR.BYTE
(LAMBDA (CLAUSEPTR INSTR BYTE TYPE)
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS (SELECTQ TYPE
((a1 byte)
BYTE)
(y1 (IPLUS BYTE QP.PERMANENT.OFFSET))
(SHOULDNT))
(QP.LEFT.OP.CODE INSTR)))
(INCR QP.CLAUSE.OFFSET 1)))
(QP.STORE.INSTR.BYTE.ATOM
(LAMBDA (CLAUSEPTR INSTR BYTE ATOM)
(LET ((OPCODE (QP.LEFT.OP.CODE INSTR)))
(QP.REGISTER.OR.MEMORY.1 BYTE OPCODE)
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS BYTE OPCODE))
(\PUTBASE CLAUSEPTR (ADD1 QP.CLAUSE.OFFSET)
(\LOLOC ATOM))
(INCR QP.CLAUSE.OFFSET 2))))
(QP.STORE.INSTR.BYTE.BYTE
(LAMBDA (CLAUSEPTR INSTR BYTE1 BYTE2 FIELD1 FIELD2)
(LET ((OPCODE (QP.LEFT.OP.CODE INSTR))
(HAS.Y.REG (OR (MEMBER FIELD1 (QUOTE (y1 y2)))
(MEMBER FIELD2 (QUOTE (y1 y2))))))
(COND
((EQ FIELD1 (QUOTE a1))
(COND
((GREATERP BYTE1 4)
(INCR OPCODE 512))
(T (SETQ BYTE1 (QP.AREG.REGISTER BYTE1)))))
((EQ FIELD2 (QUOTE a1))
(COND
((GREATERP BYTE2 4)
(INCR OPCODE 512))
(T (SETQ BYTE2 (QP.AREG.REGISTER BYTE2))))))
(COND
((EQ FIELD1 (QUOTE a2))
(COND
((MEMBER FIELD2 (QUOTE (y1 y2)))
(COND
((GREATERP BYTE1 4)
(INCR OPCODE 512))
(T (SETQ BYTE1 (QP.AREG.REGISTER BYTE1)))))
(T (COND
((GREATERP BYTE1 4)
(INCR OPCODE 1024))
(T (SETQ BYTE1 (QP.AREG.REGISTER BYTE1)))))))
((EQ FIELD2 (QUOTE a2))
(COND
((MEMBER FIELD2 (QUOTE (y1 y2)))
(COND
((GREATERP BYTE2 4)
(INCR OPCODE 512))
(T (SETQ BYTE2 (QP.AREG.REGISTER BYTE2)))))
(T (COND
((GREATERP BYTE2 4)
(INCR OPCODE 1024))
(T (SETQ BYTE2 (QP.AREG.REGISTER BYTE2))))))))
(LET (DEST1 DEST2)
(COND
((MEMBER FIELD2 (QUOTE (y1 y2)))
(SETQ BYTE2 (IPLUS BYTE2 QP.PERMANENT.OFFSET))))
(COND
((EQ FIELD1 (QUOTE a2))
(SETQ DEST1 BYTE2)
(SETQ DEST2 BYTE1))
((EQ FIELD1 (QUOTE a1))
(SETQ DEST1 BYTE1)
(SETQ DEST2 BYTE2))
(T (SHOULDNT)))
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS DEST1 OPCODE))
(\PUTBASE CLAUSEPTR (ADD1 QP.CLAUSE.OFFSET)
DEST2)
(INCR QP.CLAUSE.OFFSET 2)))))
(QP.STORE.INSTR.BYTE.CELL
(LAMBDA (CLAUSEPTR INSTR BYTE CELL)
(LET ((OPCODE (QP.LEFT.OP.CODE INSTR)))
(QP.REGISTER.OR.MEMORY.1 BYTE OPCODE)
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS BYTE OPCODE))
(LET ((NEXT (ADD1 QP.CLAUSE.OFFSET)))
(QP.LOAD.GC.PROTECT CELL)
(\PUTBASE CLAUSEPTR NEXT (PLUS (QP.OBJ.TAG CELL)
(\HILOC CELL)))
(\PUTBASE CLAUSEPTR (ADD1 NEXT)
(\LOLOC CELL))
(INCR QP.CLAUSE.OFFSET 3)))))
(QP.STORE.INSTR.BYTE.FUNCTOR
(LAMBDA (CLAUSEPTR INSTR BYTE NAME ARITY)
(LET ((PLACE (\ADDBASE CLAUSEPTR QP.CLAUSE.OFFSET))
(OPCODE (QP.LEFT.OP.CODE INSTR)))
(QP.REGISTER.OR.MEMORY.1 BYTE OPCODE)
(\PUTBASE PLACE 0 (PLUS BYTE OPCODE))
(\PUTBASE PLACE 1 (PLUS symbol.tag.16 ARITY))
(\PUTBASE PLACE 2 (\LOLOC NAME)))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.STORE.INSTR.CELL
(LAMBDA (CLAUSEPTR INSTR CELL)
(QP.LOAD.GC.PROTECT CELL)
(LET ((PLACE (\ADDBASE CLAUSEPTR QP.CLAUSE.OFFSET)))
(\PUTBASE PLACE 0 (QP.LEFT.OP.CODE INSTR))
(\PUTBASE PLACE 1 (PLUS (QP.OBJ.TAG CELL)
(\HILOC CELL)))
(\PUTBASE PLACE 2 (\LOLOC CELL)))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.STORE.INSTR.EXTEND
(LAMBDA (CLAUSEPTR INSTR)
(LET ((SECONDARY (GETHASH INSTR QP.EXTENSION.HARRAY)))
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS (LLSH QP.EXTENSION.OPCODE 8)
SECONDARY))
(INCR QP.CLAUSE.OFFSET 1))))
(QP.STORE.INSTR.EXTEND.CELL
(LAMBDA (CLAUSEPTR INSTR CELL)
(LET ((SECONDARY (GETHASH INSTR QP.EXTENSION.HARRAY)))
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS (LLSH QP.EXTENSION.OPCODE 8)
SECONDARY))
(QP.LOAD.GC.PROTECT CELL)
(\PUTBASE CLAUSEPTR (ADD1 QP.CLAUSE.OFFSET)
(IPLUS (QP.OBJ.TAG CELL)
(\HILOC CELL)))
(\PUTBASE CLAUSEPTR (IPLUS QP.CLAUSE.OFFSET 2)
(\LOLOC CELL))
(INCR QP.CLAUSE.OFFSET 3))))
(QP.STORE.INSTR.EXTEND.WORD
(LAMBDA (CLAUSEPTR INSTR WORD)
(LET ((SECONDARY (GETHASH INSTR QP.EXTENSION.HARRAY)))
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS (LLSH QP.EXTENSION.OPCODE 8)
SECONDARY))
(\PUTBASE CLAUSEPTR (ADD1 QP.CLAUSE.OFFSET)
(\LOLOC WORD))
(INCR QP.CLAUSE.OFFSET 2))))
(QP.STORE.INSTR.FUNCTOR
(LAMBDA (CLAUSEPTR INSTR NAME ARITY)
(LET ((PLACE (\ADDBASE CLAUSEPTR QP.CLAUSE.OFFSET)))
(\PUTBASE PLACE 0 (QP.LEFT.OP.CODE INSTR))
(\PUTBASE PLACE 1 (IPLUS symbol.tag.16 ARITY))
(\PUTBASE PLACE 2 (\LOLOC NAME)))
(INCR QP.CLAUSE.OFFSET 3)))
(QP.STORE.INSTR.NULL
(LAMBDA (CLAUSEPTR INSTR)
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (QP.LEFT.OP.CODE INSTR))
(INCR QP.CLAUSE.OFFSET 1)))
(QP.STORE.INSTR.OFFSET
(LAMBDA (CLAUSEPTR INSTR OFFSET)
(LET* ((CLAUSE.HILOC (\HILOC CLAUSEPTR))
(CLAUSE.LOLOC (\LOLOC CLAUSEPTR))
(ADDRESS (IPLUS OFFSET (LLSH CLAUSE.HILOC 16)
CLAUSE.LOLOC))
(ADDRESS.HILOC (LRSH ADDRESS 16))
(ADDRESS.LOLOC (LOGAND ADDRESS 65535)))
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS (QP.LEFT.OP.CODE INSTR)
ADDRESS.HILOC))
(\PUTBASE CLAUSEPTR (ADD1 QP.CLAUSE.OFFSET)
ADDRESS.LOLOC)
(INCR QP.CLAUSE.OFFSET 2))))
(QP.STORE.INSTR.PROCEDURE
(LAMBDA (CLAUSEPTR INSTR NAME ARITY MODULE)
(LET ((PROC (QP.LOCAL.PREDICATE NAME ARITY MODULE))
(PLACE (\ADDBASE CLAUSEPTR QP.CLAUSE.OFFSET)))
(\PUTBASE PLACE 0 (PLUS (QP.LEFT.OP.CODE INSTR)
(\HILOC PROC)))
(\PUTBASE PLACE 1 (\LOLOC PROC)))
(INCR QP.CLAUSE.OFFSET 2)))
(QP.STORE.INSTR.SIZE.OFFSET
(LAMBDA (CLAUSEPTR INSTR SIZE OFFSET)
(LET* ((CLAUSE.HILOC (\HILOC CLAUSEPTR))
(CLAUSE.LOLOC (\LOLOC CLAUSEPTR))
(ADDRESS (IPLUS OFFSET (LLSH CLAUSE.HILOC 16)
CLAUSE.LOLOC))
(ADDRESS.HILOC (LRSH ADDRESS 16))
(ADDRESS.LOLOC (LOGAND ADDRESS 65535)))
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS (QP.LEFT.OP.CODE INSTR)
ADDRESS.HILOC))
(\PUTBASE CLAUSEPTR (ADD1 QP.CLAUSE.OFFSET)
ADDRESS.LOLOC)
(\PUTBASE CLAUSEPTR (IPLUS QP.CLAUSE.OFFSET 2)
(ITIMES 2 SIZE))
(INCR QP.CLAUSE.OFFSET 3))))
(QP.STORE.INSTR.SIZE.PROCEDURE
(LAMBDA (CLAUSEPTR INSTR SIZE NAME ARITY MODULE)
(LET ((PROC (QP.LOCAL.PREDICATE NAME ARITY MODULE)))
(\PUTBASE CLAUSEPTR QP.CLAUSE.OFFSET (IPLUS (QP.LEFT.OP.CODE INSTR)
(\HILOC PROC)))
(\PUTBASE CLAUSEPTR (ADD1 QP.CLAUSE.OFFSET)
(\LOLOC PROC))
(\PUTBASE CLAUSEPTR (IPLUS QP.CLAUSE.OFFSET 2)
(ITIMES 2 SIZE))
(INCR QP.CLAUSE.OFFSET 3))))
(QP.TRAP.CLAUSE
(NLAMBDA (CLAUSE NAME ARITY MODULE)
(SETQ CLAUSE (SETTOPVAL CLAUSE (\MAKENUMBER 2 0)))
(\PUTBASEPTR CLAUSE 0 (QP.LOCAL.PREDICATE NAME ARITY MODULE))
(\PUTBASEBYTE CLAUSE 0 (QP.OP.CODE (QUOTE trap)))))
(QP.UNIT.CLAUSE
(NLAMBDA (OPCODE NAME ARITY MODULE)
(SETQ NAME (QP.LOCAL.PREDICATE NAME ARITY MODULE))
(SETQ OPCODE (\MAKENUMBER (QP.LEFT.OP.CODE OPCODE)
0))
(\ADDREF OPCODE)
(SETF (PROC.CLAUSES NAME)
OPCODE)
(SETF (PROC.LASTCLAUSE NAME)
QP.FAILURE.CLAUSE)
(SETF (PROC.LOFLAG NAME)
1)
OPCODE))
)
(RPAQQ QP.LAST.CLAUSE.RECORD NIL)
(PRETTYCOMPRINT LOADCOMS)
(RPAQQ LOADCOMS ((ADDVARS (GLOBALVARS QP.LAST.CLAUSE.RECORD)
(GLOBALVARS QP.CLAUSE.OFFSET)
(GLOBALVARS QP.DUMMY.CLAUSE)
(GLOBALVARS QP.DEBUG.CLAUSE)
(GLOBALVARS QP.INTERPRET.CLAUSE)
(GLOBALVARS QP.UNDEFINED.CLAUSE)
(GLOBALVARS QP.FAILURE.CLAUSE))
(MACROS QP.REGISTER.OR.MEMORY.1 \LEFTBYTE \RIGHTBYTE)
(FNS ASSEMBLE.CLAUSE QP.ADD.CLAUSE QP.ALLOCATE.CLAUSE.RECORD QP.AREG.REGISTER
QP.ATTACH.CLAUSE.RECORD QP.INITIALIZE.PROLOG QP.LOOK QP.LOOK.ATOM QP.LOOK.BYTE
QP.LOOK.BYTE.ATOM QP.LOOK.BYTE.BYTE QP.LOOK.BYTE.CELL QP.LOOK.BYTE.FUNCTOR QP.LOOK.CELL
QP.LOOK.CLAUSE QP.LOOK.CONSTANT QP.LOOK.EXTEND QP.LOOK.EXTEND.CELL QP.LOOK.EXTEND.WORD
QP.LOOK.FUNCTOR QP.LOOK.INSTR QP.LOOK.NULL QP.LOOK.OFFSET QP.LOOK.ONE.CLAUSE
QP.LOOK.OPCODE QP.LOOK.PROCEDURE QP.LOOK.SIZE.OFFSET QP.LOOK.SIZE.PROCEDURE QP.OBJ.TAG
QP.RECONSULT QP.STORE.INCORE QP.STORE.INDEX QP.STORE.INSTR QP.STORE.INSTR.AREG
QP.STORE.INSTR.ATOM QP.STORE.INSTR.BYTE QP.STORE.INSTR.BYTE.ATOM
QP.STORE.INSTR.BYTE.BYTE QP.STORE.INSTR.BYTE.CELL QP.STORE.INSTR.BYTE.FUNCTOR
QP.STORE.INSTR.CELL QP.STORE.INSTR.EXTEND QP.STORE.INSTR.EXTEND.CELL
QP.STORE.INSTR.EXTEND.WORD QP.STORE.INSTR.FUNCTOR QP.STORE.INSTR.NULL
QP.STORE.INSTR.OFFSET QP.STORE.INSTR.PROCEDURE QP.STORE.INSTR.SIZE.OFFSET
QP.STORE.INSTR.SIZE.PROCEDURE QP.TRAP.CLAUSE QP.UNIT.CLAUSE)
(VARS (QP.LAST.CLAUSE.RECORD NIL))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA ASSEMBLE.CLAUSE)
(NLAML QP.UNIT.CLAUSE
QP.TRAP.CLAUSE)
(LAMA QP.STORE.INSTR))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA ASSEMBLE.CLAUSE)
(ADDTOVAR NLAML QP.UNIT.CLAUSE QP.TRAP.CLAUSE)
(ADDTOVAR LAMA QP.STORE.INSTR)
)
(PUTPROPS LOAD.LSP COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2764 28188 (ASSEMBLE.CLAUSE 2774 . 3678) (QP.ADD.CLAUSE 3680 . 4543) (
QP.ALLOCATE.CLAUSE.RECORD 4545 . 4706) (QP.AREG.REGISTER 4708 . 4792) (QP.ATTACH.CLAUSE.RECORD 4794 .
4987) (QP.INITIALIZE.PROLOG 4989 . 6045) (QP.LOOK 6047 . 6885) (QP.LOOK.ATOM 6887 . 7058) (
QP.LOOK.BYTE 7060 . 7366) (QP.LOOK.BYTE.ATOM 7368 . 7588) (QP.LOOK.BYTE.BYTE 7590 . 8169) (
QP.LOOK.BYTE.CELL 8171 . 8380) (QP.LOOK.BYTE.FUNCTOR 8382 . 8663) (QP.LOOK.CELL 8665 . 8893) (
QP.LOOK.CLAUSE 8895 . 9135) (QP.LOOK.CONSTANT 9137 . 9301) (QP.LOOK.EXTEND 9303 . 9410) (
QP.LOOK.EXTEND.CELL 9412 . 9616) (QP.LOOK.EXTEND.WORD 9618 . 9854) (QP.LOOK.FUNCTOR 9856 . 10088) (
QP.LOOK.INSTR 10090 . 10754) (QP.LOOK.NULL 10756 . 10861) (QP.LOOK.OFFSET 10863 . 11376) (
QP.LOOK.ONE.CLAUSE 11378 . 11542) (QP.LOOK.OPCODE 11544 . 13766) (QP.LOOK.PROCEDURE 13768 . 13943) (
QP.LOOK.SIZE.OFFSET 13945 . 14551) (QP.LOOK.SIZE.PROCEDURE 14553 . 14831) (QP.OBJ.TAG 14833 . 15115) (
QP.RECONSULT 15117 . 15890) (QP.STORE.INCORE 15892 . 16025) (QP.STORE.INDEX 16027 . 16251) (
QP.STORE.INSTR 16253 . 19324) (QP.STORE.INSTR.AREG 19326 . 19591) (QP.STORE.INSTR.ATOM 19593 . 19854)
(QP.STORE.INSTR.BYTE 19856 . 20190) (QP.STORE.INSTR.BYTE.ATOM 20192 . 20554) (QP.STORE.INSTR.BYTE.BYTE
20556 . 22447) (QP.STORE.INSTR.BYTE.CELL 22449 . 22977) (QP.STORE.INSTR.BYTE.FUNCTOR 22979 . 23404) (
QP.STORE.INSTR.CELL 23406 . 23793) (QP.STORE.INSTR.EXTEND 23795 . 24064) (QP.STORE.INSTR.EXTEND.CELL
24066 . 24604) (QP.STORE.INSTR.EXTEND.WORD 24606 . 24972) (QP.STORE.INSTR.FUNCTOR 24974 . 25308) (
QP.STORE.INSTR.NULL 25310 . 25468) (QP.STORE.INSTR.OFFSET 25470 . 26032) (QP.STORE.INSTR.PROCEDURE
26034 . 26404) (QP.STORE.INSTR.SIZE.OFFSET 26406 . 27072) (QP.STORE.INSTR.SIZE.PROCEDURE 27074 . 27554
) (QP.TRAP.CLAUSE 27556 . 27822) (QP.UNIT.CLAUSE 27824 . 28186)))))
STOP