:TITLE[Ops.0mc, June 29, 1983  3:42 PM, vanMelle];

* Swap, op 375, Swap TOS and TOS-2
@Swap:
	loadpage[pgHStack], call[checkElt2P7], opcode[375];
	Stack&-3, call[Swap1];
	Stack&+2 _ T;
	Stack&-1, call[Swap1];
	Stack&+2 _ T, goto[nxiLBL];

Swap1:	T _ Stack&+2;
	Stack&-2 _ Stack&-2, return;


* Eq, op 360, Compare TOS and TOS-2, push T or Nil if eq or not, resp
@Eq:
	loadpage[pgHStack], call[checkElt2P7], opcode[360];
	StkState _ rsh[StkState, 1];
	T _ Stack&-2;
	lu _ (Stack&+1) xor T;
	T _ Stack&-2, FreezeResult, skip[alu#0];
	  lu _ (Stack) xor T;		* If lolocs were eq, test hi's
	T _ Stack _ 0c, skip[alu#0];	* about to push T or NIL...
	  Stack&+1 _ (KtVal), goto[nxiLBL];
PushTP7:
	Stack&+1 _ T, goto[nxiLBL];


* Nop , op 376, Nop
@Nop:
	NextOpCode, opcode[376];


* Pop ,  op 277, Pop stack, ignore the item
@Pop:
	Stack&-2, goto[PopChk6], opcode[277];


* Listp, op 003, Replace TOS with Nil if TOS is not a list
@Listp:
	call[lspTyp], opcode[003];
	lu _ (lspType) - (listType);
TOSGetsNILifNeq:		* Replace TOS with NIL if alu#0
	skip[alu#0];
	  NextOpCode;
	T _ Stack&-1 _ 0c;
PushTP4:
	Stack&+1 _ T, goto[nxiLBL];


* Ntypx, op 004, Replace TOS with type of TOS
@Ntypx:
	call[lspTyp], opcode[004];	* pop stack, get type in T and Type
	Stack&-1 _ (smallpl), goto[PushTP4];


* Typep, op 005, Replace TOS with Nil if TOS is not type number of alpha byte
@Typep:
	call[lspTyp], opcode[005];	* pop stack, get type in T and Type
	T _ NextData[IBuf];
	lu _ (lspType) - T, goto[TOSGetsNILifNeq];
		* could be just lu _ NextData[IBuf] - T, goto[TOSGetsNILifNeq];

* Dtest, op 006, test if type name of TOS = arg, ufn if not
@Dtest:
	call[lspTyp], opcode[006];	* get type of TOS into Type
	lspGenBrHi _ (DTDSpace);	* point at DataTypeDescriptor table
	lspGenBr _ (DTDBase);
	T _ lsh[lspType, 4];		* table is indexed by type
	PFetch1[lspGenBr, lspType];	* Type _ typename(TOS)
	T _ NextData[IBuf];
	lspL1 _ T;
	T _ NextData[IBuf];
	T _ (lsh[lspL1, 10]) or T;	* T _ alpha,,beta
	lu _ (lspType) - T;		* is T same as typename?
	lspNargs _ 2c, skip[alu#0];
	  NextOpCode;			* Yes, return tos as is
					* do ufn call inline here
	StkState _ lsh[StkState, 1];	* account for push
	Stack&+1 _ (smallpl);		* push typename atom as smallp
	Stack&+1 _ T, loadpage[pgFrame];
	lspDefx1 _ (atomDTESTFAIL), goto[lspCallFn0];


onpage[pgTyp];
* Subroutine to get data type of TOS, returns it in T and lspType;
* transfers TOS into L3,2 in form suitable for use as a base reg pair
lspTyp:
	T _ Stack&-1;
	lspL2 _ T;
	T _ lsh[Stack&+1, 10];
	lspL3 _ T;
	T _ rsh[lspL2, 11];
	T _ (rsh[lspL3, 1]) or T;
	PFetch1[MDSTypeBaseBr, lspType];
	T _ lspType _ rhmask[lspType], return;

* CAR, op 001, replace TOS with car[TOS]
@Car:
	call[lspTyp], opcode[001];	* TOS in L2, 3, type in lspType
	lu _ (lspType) - (listtype);
	lspUFN _ 001c, skip[alu=0];
	  goto[CarCdrNilP];
lspCar1:
	PFetch2[lspL2, lspL0, 0];
	lu _ lhmask[lspL0];
	T _ rhmask[lspL0], goto[CdrTail, alu#0];
	T _ lsh[lspL0, 10];		* indirect cell: L3,2 _ L0,1, retry
	lspL3 _ T;
	T _ lspL1;
	lspL2 _ T, goto[lspCar1];

* CDR, op 002, replace TOS with cdr[TOS]
@Cdr:
	call[lspTyp], opcode[002];
	lu _ (lspType) - (listtype);
	lspUFN _ 002c, skip[alu=0];
	  goto[CarCdrNilP];
lspCdr3:
	PFetch2[lspL2, lspL0, 0];
	T _ ldf[lspL0, 1, 7], skip[R<0];	* T _ cdr code
	  lspL2 _ (lhmask[lspL2]) + T, dblgoto[lspCdr1, lspCdr2, alu=0];
	lspL2 _ (lhmask[lspL2]) + T, goto[lspCdrNil, alu=0];
	T _ (lspL2) + T;		* cdr is on page at offset 2*T
	lspL1 _ T;
	T _ rsh[lspL3, 10];
CdrTail:				* Here with Hiloc[cell] in T, lo in L1
	Stack&-1 _ T;
	T _ lspL1, goto[PushTP4];

lspCdr1:				* cdr full indirect
	T _ lsh[lspL0, 10];		* L3,2 _ L0,1, retry
	lspL3 _ T;
	T _ lspL1;
	lspL2 _ T, goto[lspCdr3];

lspCdrNil:
	T _ Stack&-1 _ 0c, goto[PushTP4];

lspCdr2:	* cdr indirect on page: cdr is contained in cell at page + 2*cdrcode
	PFetch2[lspL2, lspL0];
	T _ rhmask[lspL0], goto[CdrTail];

CarCdrNilP:				* Car/cdr of non-list
	T _ Stack&-1;
	lu _ (Stack&+1) or T;
	skip[alu#0];
	  NextOpCode;
	goto[ufnLBL];

* Bin, op 40.  Takes TOS = Stream, returns byte as smallp
:IF[WithBin];
		* new Bin (5 mi shorter)
@Bin:	lspL6 _ (StreamType), call[lspTyp], opcode[40];
	lu _ (lspL6) - T, loadpage[pgBin];	* Is it a STREAM?
	lspUFN _ 040c, skip[alu=0];
onpage[pgBin];
	  goto[ufnLBL];
	PFetch4[lspL2, XBuf, 0];	* Fetch first 4 words of Stream
					* = Offset, NChars, Flags,,Buffer
	T _ rhmask[XBuf2], skip[R<0];	* Is Buffer Binable?
	  goto[ufnLBL];
	lspL1 _ T;			* lspL1 _ bufHi
	lspL1 _ (lsh[lspL1, 10]) + T + 1;	* convert to baseregHi
	T _ XBuf1;			* nbr Chars in buffer
	lu _ (XBuf) - T;		* Current Offset - NChars
	T _ XBuf3, skip[alu<0];		* Past end of buffer?
	  goto[ufnLBL];
	lspL0 _ T, loadpage[opPage3];	* L0 _ baseregLo
	T _ rsh[XBuf, 1];		* Get Current pos as word ptr
onpage[opPage3];
	PFetch1[lspL0, lspL1];		* Fetch data word
	XBuf _ (XBuf) + 1, dblgoto[.+2,.+1, R odd];
					* Increment position, check which byte
	 T _ rsh[lspL1, 10], skip;	* even byte
	  T _ rhmask[lspL1];		* odd byte
	PStore4[lspL2, XBuf, 0], goto[TOSGetsTSmall];
			* Store back modified OFD, push byte on stack
:ELSE;
@Bin:	lspUFN _ 40c, goto[lspUfnxP4], opcode[40];
:ENDIF;			
:IF[0];		* old Bin
@Bin:	call[lspTyp], opcode[40];
	loadpage[pgBin];
	lu _ (lspType) - (StreamType);	* Is it a STREAM?
onpage[pgBin];
	lspUFN _ 040c, skip[alu=0];
	  goto[ufnLBL];
	PFetch4[lspL2, XBuf, 0];	* Fetch first 4 words of Stream
					* = Offset, NChars, Flags,,Buffer
	T _ XBuf1;			* nbr Chars in buffer
	lu _ (XBuf) - T;			* Current Position - NChars
	skip[alu<0];			* Past end of buffer?
	  goto[ufnLBL];
	T _ rhmask[XBuf2], skip[R<0];	* Is Buffer Readable?
	  goto[ufnLBL];
	lspL1 _ T;
	lspL1 _ (lsh[lspL1, 10]) + T + 1;
	T _ XBuf3, task;
	lspL0 _ T;
	T _ rsh[XBuf, 1];		* Get Current pos as word ptr
	PFetch1[lspL0, lspL1];		* Fetch data word
	XBuf _ (XBuf) + 1, skip[R odd];	* Increment position, check which byte
	 lspL1 _ rsh[lspL1, 10], skip;
	nop;				* Wait for XBuf to get written
	PStore4[lspL2, XBuf, 0];	* Store back modified OFD
	Stack&-1 _ (smallpl);		* Push byte as small int
	T _ rhmask[lspL1];
	Stack&+1 _ T, goto[nxiLBL];
:ENDIF;

RV[Case, IP[lspDefx0]];

* (RPLCONS LST ITEM) does (CDR (RPLACD LST (CONS ITEM NIL)))

:IF[WithCons];
@RplCons:
	loadpage[pgHStack], call[CheckElt2P4], opcode[046];
	Stack&-2, call[lspTyp];		* get LST in 3,2, type in Type
	loadpage[pgCons];
	lu _ (lspType) - (listType);
onpage[pgCons];
	lspUFN _ 46c, skip[alu=0];	* set UFN for punt, skip if listp
	  goto[ufnLBL];			* punt if LST not list

	Pfetch1[lspL2, lspL4, 0];	* L4 _ hiword of LST (can fault)
	T _ 200c;
	T _ (rsh[lspL4, 10]) xor T;	* compare cdr code against cdr.nil
	T _ lspL4, skip[alu=0];
	  goto[ufnLBL];			* punt if (CDR LST) not NIL
	XBuf _ T;			* Save old contents for later so we can update cdr code
	lspL2 _ lhmask[lspL2];		* point L3,2 at LST's page
	Case _ 0c, call[MakeConsCell];	* get back CONS = L3,2 	
					* we are committed to finishing now

	call[GetListpDTD];	* stack points at LST now
	Stack&+2, call[IncrementConsCount];	* now points at ITEM

	T _ Stack&-1;
	lspL1 _ T;
	T _ rhmask[Stack&-1];
	lspL0 _ T, loadpage[pgHtFind];	* ITEM in 0,1
	Case _ lhmask[Case], call[GcLookup];	* Addref ITEM.  Preserves 2,3

	T _ Stack;			* loloc(LST)
	lspL5 _ T;			* save for below
	T _ lspL2;			* loloc(CONS)
	Stack _ T;		* Smash LST on stack (hiloc's are same)

	lspL0 _ (lspL0) or (100000c);	* Put cdr.nil code in ITEM
	PStore2[lspL2, lspL0, 0];	* Store cdr.nil,,ITEM in CONS

	T _ lsh[lspL2, 7];	* 2*Offset of CONS, shifted to cdr code
	XBuf _ (XBuf) or T;		* insert in hi word of old LST
					* (200 bit already known to be on)
	T _ lspL5;			* loloc(LST)
	lspL2 _ T;			* 2,3 now points at LST
	PStore1[lspL2, XBuf, 0];	* Store cdr code back to LST

	loadpage[pgRplptr];
	StkState _ rsh[StkState, 1], goto [GcExit];
			* Account for stack decrement, go check for htpunt


@Cons:
	loadpage[pgHStack], call[CheckElt2P4], opcode[032];
	call[lspTyp];		* get CDR in 3,2, type in Type
	loadpage[pgCons];
	lu _ (lspType) - (listType);
onpage[pgCons];
	lspUFN _ 32c, goto[ConsList, alu=0];	* set UFN for punt, do listp case
	T _ lspL3, call[GetListpDTD];
	lu _ (lspL2) or T;
	goto[ConsNil, alu=0];
	goto[ufnLBL];			* cdr non-NIL non-list

ConsNil:
	nop;				* Even
	Stack&-2, call[GetNextConsPage];	* pop off cdr
	Case _ 0c, call[MakeConsCell];
	call[IncrementConsCount];
	XBuf_ 200c, goto[ConsTail];

ConsList:
	lspL2 _ lhmask[lspL2];		* Point at cdr's page
	Case _ 0c, call[MakeConsCell];	* L2 returns pointer to Cons cell
	call[GetListpDTD];
	T _ Stack&-1;			* Pop CDR into 0,1
	lspL1 _ T, call[IncrementConsCount];
	T _ Stack&-1;
	lspL0 _ T;			* cdr is in 0, 1
	loadpage[pgHtFind];
	Case _ 0c, callp[GcLookup];	* Addref Cdr pointer
	T _ 200c;
	T _ (ldf[lspL1, 10, 7]) + T;
	XBuf _ T;			* cdr code

ConsTail:
	T _ Stack&-1;
	lspL1 _ T;
	T _ Stack&+1;
	lspL0 _ T, loadpage[pgHtFind];
	Case _ lhmask[Case], callp[GcLookup];	* Addref car pointer
	T _ lsh[XBuf, 10];
	lspL0 _ (rhmask[lspL0]) or T;
	PStore2[lspL2, lspL0, 0];	* Store cons cell
	T _ rsh[lspL3, 10];		* Shift hiword to normal place
	Stack&-1 _ T;
	lspL0 _ T;			* Put ptr on stack
	T _ lspL2;
	Stack&+1 _ T;
	lspL1 _ T, loadpage[pgHtFind];
	Case _ (lhmask[Case]) + 1, callp[GcLookup];	* Deleteref cons cell
	loadpage[pgRplPtr];
	StkState _ rsh[StkState, 1], gotop[GcExit];	* Check for htoverflow

GetListpDTD:
	* Set lspGenBr, BrHi to point at DTD for type LISTP
	lspGenBrHi _ (DTDSpace);
	lspGenBr _ (DTDBase);
	lspGenBr _ (lspGenBr)+(120c), return;	* 120 = Listtype lsh 4

IncrementConsCount:
	* assumes lspGenBrHi,Br points at LISTPDTD

	PFetch1 [lspGenBr, lspL0, 14];	* old cons count from LISTPdtd
	lspL0 _ (lspL0)+1;		* increment count
	lu _ (lspL0) - (MaxNewCellCount);	* has count gotten too high?
	PStore1[lspGenBr, lspL0, 14], skip[alu<0];	* store updated count
	  Case _ (Case) or (40000c);	* cause punt later
	return;

GetNextConsPage:
	* set L2,3 pointing at a cons page, or punt.
	* smashes L0

	PFetch1[lspGenBr, lspL0, 15];		* get LISTPDTD:NextPage
 	lu _ lspL0;				* No page if 0
 	skip[alu#0];
 	  goto[ufnLBL];
	T _ lhmask[lspL0];			* form address from page#
	lspL3 _ T;				* hiloc of page address
	T _ lsh[lspL0, 10];
	lspL2 _ T, return;			* loloc of page address

MakeConsCell:
	* enter with L2,3 addressing desired cons page
	* lspUFN = opcode that called it (for punt)
	* returns L2,3 pointing at new cons cell
	* smashes L0,4,5

	PFetch1[lspL2, lspL0, 0];		* get count, next cell
	T _ rhmask[lspL0];
	lspL5 _ T;				* Save offset of cell
	PFetch1[lspL2, lspL4];			* L4 _ hiword of new cell
	lspL0_ (lspL0) - (400c);		* subtract 1 from count
 	skip[alu>=0];
	  goto[ufnLBL];			* call UFN if no cells left
	T _ rsh[lspL4, 10];			* offset of next free cell
	lspL0_ (lhmask[lspL0]) or T;
	PStore1[lspL2, lspL0, 0];		* Store count, next cell
	T _ lspL5;				* word# in page of new cell

	lspL2 _ (lspL2) or T, return;		* Create ptr to new cell

:ELSE;
@RplCons:
	lspUFN _ 46c, goto[lspUfnxP4], opcode[46];
@Cons:	lspUFN _ 32c, goto[lspUfnxP4], opcode[32];
:ENDIF;


* CreateCell[type] -> Cell.  No change to stack state

:IF[WithCreateCell];
@CreateCell:
	T _ lsh[Stack&-1, 4], call[XCreateCell], opcode[37];
	loadpage[pgRplPtr];
	gotop[GcExit];

XCreateCell:
	lu _ (Stack&+1) xor (smallpl);	* Punt if type not smallp
	qBuf _ T, UseCTask, goto[DoCreateCella, alu=0];
	  lspUFN _ 37c, goto[ufnLBL];

* CreateCell subroutine.  Enter with qBuf = lsh[type#,4].
* Returns with TOS replaced by new cell, whose base address is in lspGenBr.
* Caller must finish by going to GcExit.

	onpage[opPage0];

DoCreateCell:
	UseCTask;
DoCreateCella:
	T _ APC&APCTask;
	lspL6 _ T;			* Save return address
	qBuf1 _ (DTDSpace);		* form basereg for DTD
	qBuf _ (qBuf) + (DTDBase);	* finish forming basereg
	PFetch4[qBuf, uBuf, 0], call[retLBL];	* Fetch out of DTD for this type:
						* uBuf = name (not used)
						* uBuf1 = Size in words
						* uBuf2,3 = FREE
					* cannot fault?
	PFetch1[qBuf, lspL4, 14];	* L4 _ DTD:COUNTER
	T _ rhmask[uBuf2];		* FreeHi
	lu _ (uBuf3) or T, loadpage[pgCreateCell];	* test that free # nil
	lspL0 _ T, goto[CreateNIL, alu=0];	* need Hi here for Gcref
onpage[pgCreateCell];
	T _ (lsh[uBuf2, 10]) + T + 1;	* form basereghi
	lspGenBrHi _ T;
	T _ uBuf3;			* FreeLo
	lspGenBr _ T;			* here for addressing
	lspL1 _ T;			* here for Gc
	PFetch2[lspGenBr, uBuf2, 0];	* get old contents of FREE = new FREE
					* can fault
	xBuf _ 0c;
	xBuf1 _ 0c;			* Prepare for clearing...
	T _ uBuf1, call[CreateDec];	* point at end of region for clearing, top down

CreateLp:
	PStore2[lspGenBr, xBuf];	* Clear two words; can fault
CreateDec:
	T _ (Form-2[AllOnes]) + T;	* T _ T-2
	skip[alu<0];
	  return;			* to CreateLp

					* no more faults possible now
:IF[IFE[pgHtFind, pgCreateCell, 0, 1]];
	loadpage[pgHtFind];
:ENDIF;
	Case _ 1c, callp[GcLookup];	* Deleteref new cell
	PStore4[qBuf, uBuf, 0];		* Store back new FREE and old friends
	lspL4 _ (lspL4) + 1;		* increment counter
	T _ rhmask[uBuf2];
	lu _ (uBuf3) or T;		* Check new FREE = NIL
	lu _ (lspL4) - (MaxNewCellCount), skip[alu#0];	* increment counter
	  Case _ (Case) or (CreateCellPunt);	* Punt later if freelist empty
	T _ lspL0, skip[alu<0];
	  Case _ (Case) or (CreateCellPunt);	* Punt later if counter too high
	Stack&-1 _ T;			* TOS _ new cell
	PStore1[qBuf, lspL4, 14];	* Store counter back
	T _ lspL1;
	Stack&+1 _ T;
	APC&APCTask _ lspL6, goto[retLBL];

CreateNIL:				* Freelist is empty, so need to punt,
					* but lspUFN is not set.  Assume only
					* one-byte opcodes call us
	T _ (PCXReg) - 1;		* back up PCF
	lspUFN _ T;
	PCF _ lspUFN, call[retLBL];	* wait for it to write
	T _ NextData[IBuf];		* reread current instruction
	lspUFN _ T, goto[ufnLBL];

:ELSE;
@CreateCell:
	lspUfn _ 37c, goto[lspUfnxP4], opcode[37];
:ENDIF;

	:END[Ops];
(1792)\2598v13V