pdp11.zip

	.TITLE	ZIP	Z-language Interpreter Program

	.IDENT	/ZIP.15/
ZMVERS=	3			;Z-MACHINE VERSION NUMBER
	.ENABL	LC


;	Proprietary documentation of:
;
;		Infocom, Inc.
;		55 Wheeler St.
;		Cambridge, MA 02138
;
;	Copyright (C) 1982, 1983 Infocom, Inc.  All rights reserved.
;
;This listing is furnished for a specific purpose under an
;agreement that it will not be copied in any form or made
;available to any other party.  Neither will the information
;contained herein be disclosed.  When the purpose for which
;this listing has been furnished is completed, the listing
;will be returned to Infocom.  This listing will at all times
;remain the property of Infocom.
	.SBTTL	DEFINE PROGRAM SECTIONS AND ATTRIBUTES

	.PSECT	PARAM,D		;PARAMETERS, MUST BE FIRST
	.PSECT	DATA,D		;MOST MODIFIABLE DATA
	.PSECT	STRING,RO,D	;STRING SPACE, READ ONLY
	.PSECT	CODE,RO		;INSTRUCTIONS, READ ONLY
	.PSECT	BUFFER,D	;EXPANDABLE DATA AREA AT END OF PROGRAM
	.SBTTL	PROGRAMMING CONVENTIONS


;PROGRAM SECTIONS:
;	CODE	READ ONLY, CONTAINS ALL CODE AND SOME CONSTANT DATA
;	DATA	CONTAINS MOST DATA INCLUDING EVERYTHING MODIFIABLE
;	STRING	CONTAINS STRING DATA, MOSTLY FROM STRING MACROS
;	BUFFER	POINTS TO DYNAMICALLY ALLOCATED MEMORY ABOVE PROGRAM
;	PARAM	SET UP PARAMETERS PATCHED IN BY USER (HOPEFULLY)

;EACH SUBROUTINE IS OFFSET FROM THE NEXT BY A BLANK LINE.  EACH BEGINS
;WITH A SHORT DESCRIPTION INCLUDING REGISTERS USED - BOTH ARGUMENTS
;AND RETURNED VALUES.

;GENERALLY, A SINGLE ARGUMENT IS PASSED IN R0.  A SINGLE VALUE WILL
;LIKEWISE BE RETURNED IN R0.  IN ANY CASE, R0 IS A SCRATCH REGISTER
;AND NEED NOT BE PRESERVED.  ALL OTHER REGISTERS, EXCEPT WHERE OTHER-
;WISE SPECIFIED, MUST BE PRESERVED ACROSS EACH SUBROUTINE CALL.  NOTE
;THAT TOP-LEVEL ROUTINES, OPx ROUTINES, ARE EXCLUDED FROM THIS
;RESTRICTION.

;SUBROUTINES ARE NORMALLY CALLED VIA JSR PC.  THOSE THAT SKIP RETURN
;OR TAKE FOLLOWING ARGUMENTS, AS SPECIFIED IN THE INDIVIDUAL DESCRIPTION,
;ARE CALLED VIA JSR R5.  SINCE R5 IS ALSO USED AS THE ZSTACK-POINTER,
;SUCH SUBROUTINES CANNOT USE THE ZSTACK.
	.SBTTL	CONFIGURATION FLAGS


SOBINS=	0			;HAS NO HARDWARE SOB
EIS=	0			;HAS NO HARDWARE EIS
NEW11=	0			;HAS NO SXT, XOR, MARK, RTT, SOB, OR EIS
RT11=	1			;USE RT-11 MONITOR CALLS
	.SBTTL	GENERAL MACROS


	;PUSH REGISTERS ONTO STACK
.MACRO	SAVE	REGS
.IRPC	REGNUM,REGS
	MOV	R'REGNUM,-(SP)
.ENDM
.ENDM	SAVE

	;POP REGISTERS FROM STACK
.MACRO	RESTOR	REGS
.IRPC	REGNUM,REGS
	MOV	(SP)+,R'REGNUM
.ENDM
.ENDM	RESTOR

	;PRINT A STRING STORED IN STRING AREA AND THEN DIE
.MACRO	FATAL	STR
	.PSECT	STRING
	$$$=.
	.ASCIZ	\STR\
	.PSECT	CODE
	JSR	R5,FATALR
	.WORD	$$$
.ENDM	FATAL

	;PRINT A STRING STORED IN STRING AREA WITH INFORMATIONAL HEADER
.MACRO	INFORM	STR
	.PSECT	STRING
	$$$=.
	.ASCIZ	\STR\
	.PSECT	CODE
	JSR	R5,INFRMR
	.WORD	$$$
.ENDM	INFORM

	;PRINT A STRING STORED IN STRING AREA WITH NO NEWLINE
.MACRO	PRIN1	STR
	.PSECT	STRING
	$$$=.
	.ASCII	\STR\<200>
	.PSECT	CODE
	MOV	#$$$,R0
	JSR	PC,OUTSTR
.ENDM	PRIN1

	;DEFINE A VARIABLE IN DATA SECTION
.MACRO	DEFVAR	NAM,VAL
	.PSECT	DATA
.IF	NB	^\VAL\
NAM::	VAL
.IFF
NAM::	0
.ENDC
	.PSECT	CODE
.ENDM	DEFVAR


	;IF NO NEW 11 INSTRUCTIONS, REPLACE WITH OTHER INSTRUCTIONS
.IF	EQ	NEW11

SOBINS=	0			;CAN'T HAVE THESE, EITHER
EIS=	0

	;SIGN EXTEND
.MACRO	SXT	ARG,?NEGLOC,?ENDLOC
	BMI	NEGLOC		;WAS OTHER WORD NEGATIVE?
	CLR	ARG		;NO, MAKE THIS WORD ZERO (NON-NEGATIVE),
	BR	ENDLOC		;& SKIP TO END
NEGLOC:	MOV	#-1,ARG		;YES, MAKE THIS WORD ALL ONES (NEGATIVE)
ENDLOC:
.ENDM	SXT

	;EXCLUSIVE OR
.MACRO	XOR	REG,ARG
	.ERROR			;XOR NOT IMPLEMENTED
.ENDM	XOR

	;MARK STACK
.MACRO	MARK	LOC
	.ERROR			;MARK NOT IMPLEMENTED
.ENDM	MARK

	;RETURN FROM TRAP WITH T-BIT TRAP INHIBITED
.MACRO	RTT
	.ERROR			;RTT NOT IMPLEMENTED
.ENDM	RTT

.ENDC


	;IF NO SOB, REPLACE WITH OTHER INSTRUCTIONS
.IF	EQ	SOBINS
.MACRO	SOB	REG,LOC
	DEC	REG
	BNE	LOC
.ENDM	SOB
.ENDC


	;IF NO EIS INSTRUCTIONS, REPLACE WITH SIMULATION ROUTINES
.IF	EQ	EIS

	;ARITHMETIC SHIFT (SINGLE WORD)
.MACRO	ASH	NUM,REG
	MOV	REG,-(SP)
	MOV	NUM,-(SP)
	JSR	PC,ASHSIM
	MOV	(SP)+,REG
.ENDM	ASH

	;ARITHMETIC SHIFT (DOUBLE WORD)
.MACRO	ASHC	NUM,REG
	.ERROR			;ASHC NOT IMPLEMENTED
.ENDM	ASHC

	;MULTIPLY (SINGLE WORD ONLY)
.MACRO	MUL	NUM,REG
.IF	DIF	REG,R1
.IF	DIF	REG,R3
.IF	DIF	REG,R5
	.ERROR			;DOUBLE WORD MULTIPLY NOT IMPLEMENTED
.ENDC
.ENDC
.ENDC
	MOV	REG,-(SP)
	MOV	NUM,-(SP)
	JSR	PC,MULSIM
	MOV	(SP)+,REG
.ENDM	MUL

	;DIVIDE (DOUBLE WORD)
.MACRO	DIV	NUM,REG
	MOV	REG,-(SP)
	MOV	REG+1,-(SP)
	MOV	NUM,-(SP)
	JSR	PC,DIVSIM
	MOV	(SP)+,REG+1
	MOV	(SP)+,REG
.ENDM	DIV

.ENDC
	.SBTTL	ARITHMETIC OPERATIONS

	.PSECT CODE


	;ADD
OPADD::	ADD	R1,R0		;ADD OPR1 AND OPR2
	JMP	PUTVAL		;RETURN THE VALUE

	;SUB
OPSUB::	SUB	R1,R0		;SUBTRACT OPR2 FROM OPR1
	JMP	PUTVAL		;RETURN THE VALUE

	;MUL
OPMUL::	MUL	R0,R1		;MULTIPLY OPR1 BY OPR2
	MOV	R1,R0		;IGNORING OVERFLOW
	JMP	PUTVAL		;RETURN THE VALUE

	;DIV
OPDIV::	MOV	R1,R2		;REARRANGE OPERANDS FOR DIVIDE
	MOV	R0,R1
	SXT	R0
	DIV	R2,R0		;DIVIDE OPR1 BY OPR2
	JMP	PUTVAL		;RETURN THE VALUE

	;MOD
OPMOD::	MOV	R1,R2		;REARRANGE OPERANDS FOR DIVIDE
	MOV	R0,R1
	SXT	R0
	DIV	R2,R0		;DIVIDE OPR1 BY OPR2
	MOV	R1,R0		;WE WANT REMAINDER
	JMP	PUTVAL		;RETURN THE VALUE

	;RANDOM
	DEFVAR	RSEED		;SEED FOR RANDOM NUMBERS
OPRAND::MOV	RSEED,R1	;GET THE SEED
	MUL	#257.,R1	;TRANSFORM IT
	ADD	#13,R1
	MOV	R0,R2
	MOV	R1,RSEED	;SAVE NEW VALUE
	CLR	R0		;TRIM IT TO PROPER SIZE
	BIC	#100000,R1	;CLEAR BIT TO PREVENT POSSIBLE OVERFLOW
	DIV	R2,R0
	MOV	R1,R0
	INC	R0		;MUST BE BETWEEN 1 AND N, INCLUSIVE
	JMP	PUTVAL		;RETURN THE VALUE

	;LESS?
OPQLES::CMP	R0,R1		;IS OPR1 LESS THAN OPR2?
	BLT	JPT		;YES, PREDICATE TRUE
JPF:	JMP	PFALSE		;NO, PREDICATE FALSE
JPT:	JMP	PTRUE


	;GRTR?
OPQGRT::CMP	R0,R1		;IS OPR1 GREATER THAN OPR2?
	BGT	JPT		;YES, PREDICATE TRUE
	BR	JPF		;NO, PREDICATE FALSE
	.SBTTL	LOGICAL OPERATIONS


	;BTST
OPBTST::BIC	R0,R1		;TURN OFF ALL BITS IN OPR2 THAT ARE ON IN OPR1
	BEQ	JPT		;SUCCESS IF OPR2 COMPLETELY CLEARED
	BR	JPF

	;BOR
OPBOR::	BIS	R1,R0		;LOGICAL OR
	JMP	PUTVAL		;RETURN THE VALUE

	;BCOM
OPBCOM::COM	R0		;LOGICAL COMPLEMENT
	JMP	PUTVAL		;RETURN THE VALUE

	;BAND
OPBAND::COM	R1		;LOGICAL AND
	BIC	R1,R0
	JMP	PUTVAL		;RETURN THE VALUE
	.SBTTL	GENERAL PREDICATES


	;EQUAL?
OPQEQU::NOP			;TELL CALLER TO USE ARGUMENT BLOCK
	CMP	2(R0),4(R0)	;IS OPR1 EQUAL TO OPR2?
	BEQ	1$		;YES
	CMP	(R0),#3		;NO, IS THERE A THIRD OPERAND?
	BLT	2$		;NO
	CMP	2(R0),6(R0)	;YES, IS IT EQUAL TO OPR1?
	BEQ	1$		;YES
	CMP	(R0),#4		;NO, IS THERE A FOURTH?
	BLT	2$		;NO
	CMP	2(R0),10(R0)	;YES, IS IT EQUAL TO OPR1?
	BNE	2$		;NO
1$:	JMP	PTRUE		;PREDICATE TRUE IF EQUAL
2$:	JMP	PFALSE		;PREDICATE FALSE IF NOT

	;ZERO?
OPQZER::TST	R0		;IS OPR ZERO?
	BNE	1$		;NO, PREDICATE FALSE
	JMP	PTRUE		;YES, PREDICATE TRUE
1$:	JMP	PFALSE
	.SBTTL	OBJECT OPERATIONS


	;MOVE (OBJ1 INTO OBJ2)
OPMOVE::SAVE	01		;PROTECT OPRS FROM REMOVE CALL
	JSR	PC,OPREMO	;REMOVE OBJ1 FROM WHEREVER IT IS
	MOV	(SP),R0		;OBJ2
	JSR	PC,OBJLOC	;FIND ITS LOCATION
	MOV	R0,R2		;SAVE FOR LATER
	MOV	2(SP),R0	;OBJ1
	JSR	PC,OBJLOC	;FIND ITS LOCATION
	RESTOR	1		;OBJ2
	MOVB	R1,4(R0)	;PUT OBJ2 INTO OBJ1'S LOC SLOT
	MOVB	6(R2),R3	;GET CONTENTS OF OBJ2'S FIRST SLOT
	RESTOR	1		;OBJ1
	MOVB	R1,6(R2)	;MAKE OBJ1 FIRST CONTENT OF OBJ2
	TST	R3		;WERE THERE ANY OTHER CONTENTS?
	BEQ	1$		;NO
	MOVB	R3,5(R0)	;YES, CHAIN ONTO OBJ1'S SIBLING SLOT
1$:	RTS	PC

	;REMOVE (OBJ FROM ITS PARENT)
OPREMO::MOV	R0,R2		;SAVE OBJ FOR LATER
	JSR	PC,OBJLOC	;FIND ITS LOCATION
	MOV	R0,R1		;SAVE THAT
	MOVB	4(R1),R0	;GET ITS PARENT
	BEQ	3$		;IF NO PARENT, WE'RE DONE
	JSR	PC,OBJLOC	;FIND PARENT'S LOCATION
	MOVB	6(R0),R3	;GET PARENT'S FIRST CONTENT
	CMPB	R3,R2		;IS IT OBJ?
	BNE	1$		;NO
	MOVB	5(R1),6(R0)	;YES, CHANGE SLOT TO OBJ'S SIBLING
	BR	2$		;AND RETURN
1$:	MOV	R3,R0		;CURRENT SIBLING
	JSR	PC,OBJLOC	;FIND ITS LOCATION
	MOVB	5(R0),R3	;GET NEXT SIBLING IN CHAIN
	CMPB	R3,R2		;IS IT OBJ?
	BNE	1$		;NO, CONTINUE LOOP
	MOVB	5(R1),5(R0)	;YES, CHANGE IT TO OBJ'S SIBLING
2$:	CLRB	4(R1)		;OBJ NOW HAS NO PARENT
	CLRB	5(R1)		;OR SIBLING
3$:	RTS	PC

	;FSET? (IS FLAG SET IN OBJ?)
OPQFSE::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	CMP	R1,#20		;SECOND WORD FLAG?
	BLT	1$		;NO
	SUB	#20,R1		;YES, SUBTRACT 16 FROM FLAG NUMBER
	ADD	#2,R0		;AND USE SECOND FLAG WORD
1$:	JSR	PC,GTAWRD	;GET THE FLAG WORD
	SUB	#17,R1		;SHIFT A BIT TO PROPER POSITION
	NEG	R1
	MOV	#1,R2
	ASH	R1,R2
	BIT	R2,R0		;IS THIS BIT SET IN FLAG WORD?
	BEQ	2$		;NO, PREDICATE FALSE
	JMP	PTRUE		;YES, PREDICATE TRUE
2$:	JMP	PFALSE

	;FSET (SET A FLAG IN OBJ)
OPFSET::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	CMP	R1,#20		;SECOND WORD FLAG?
	BLT	1$		;NO
	SUB	#20,R1		;YES, SUBTRACT 16 FROM FLAG NUMBER
	ADD	#2,R0		;AND USE SECOND FLAG WORD
1$:	MOV	R0,R3		;REMEMBER THIS LOCATION
	JSR	PC,GTAWRD	;GET THE FLAG WORD
	SUB	#17,R1		;SHIFT A BIT TO PROPER POSITION
	NEG	R1
	MOV	#1,R2
	ASH	R1,R2
	BIS	R2,R0		;SET THIS BIT IN FLAG WORD
	MOV	R0,R1
	MOV	R3,R0
	JMP	PTAWRD		;STORE THE NEW FLAG WORD

	;FCLEAR (CLEAR A FLAG IN OBJ)
OPFCLE::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	CMP	R1,#20		;SECOND WORD FLAG?
	BLT	1$		;NO
	SUB	#20,R1		;YES, SUBTRACT 16 FROM FLAG NUMBER
	ADD	#2,R0		;AND USE SECOND FLAG WORD
1$:	MOV	R0,R3		;REMEMBER THIS LOCATION
	JSR	PC,GTAWRD	;GET THE FLAG WORD
	SUB	#17,R1		;SHIFT A BIT TO PROPER POSITION
	NEG	R1
	MOV	#1,R2
	ASH	R1,R2
	BIC	R2,R0		;CLEAR THIS BIT IN FLAG WORD
	MOV	R0,R1
	MOV	R3,R0
	JMP	PTAWRD		;STORE THE NEW FLAG WORD

	;LOC (RETURN CONTAINER OF OBJ)
OPLOC::	JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	MOVB	4(R0),R0	;GET LOC SLOT
	JMP	BYTVAL		;RETURN THE BYTE VALUE

	;FIRST? (RETURN FIRST SLOT OF OBJ, FAIL IF NONE)
OPQFIR::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	MOVB	6(R0),R0	;GET FIRST SLOT
	SAVE	0
	JSR	PC,BYTVAL	;RETURN THE BYTE VALUE
	RESTOR	0		;WAS IT ZERO?
	BEQ	JPF1		;YES, PREDICATE FALSE
JPT1:	JMP	PTRUE		;NO, PREDICATE TRUE
JPF1:	JMP	PFALSE

	;NEXT? (RETURN THE NEXT (SIBLING) SLOT OF OBJ, FAIL IF NONE)
OPQNEX::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	MOVB	5(R0),R0	;GET SIBLING SLOT
	SAVE	0
	JSR	PC,BYTVAL	;RETURN THE BYTE VALUE
	RESTOR	0		;WAS IT ZERO?
	BEQ	JPF1		;YES, PREDICATE FALSE
	BR	JPT1		;NO, PREDICATE TRUE

	;IN? (IS OBJ1 CONTAINED IN OBJ2?)
OPQIN::	JSR	PC,OBJLOC	;FIND OBJ1'S LOCATION
	CMPB	4(R0),R1	;IS OBJ1'S PARENT OBJ2?
	BEQ	JPT1		;YES, PREDICATE TRUE
	BR	JPF1		;NO, PREDICATE FALSE

	;GETP (GET SPECIFIED PROPERTY OF OBJ, DEFAULT IF NONE)
OPGETP::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	ADD	#7,R0		;POINT TO PROPERTY TABLE SLOT
	JSR	PC,GTAWRD	;GET ITS LOCATION
	ADD	#BUFFER,R0	;ABSOLUTIZE IT
	MOVB	(R0),R2		;LENGTH OF SHORT DESCRIPTION IN WORDS
	BIC	#^C377,R2	;CLEAN OFF ANY HIGH-ORDER BYTE
	ASL	R2		;CONVERT TO BYTES
	ADD	R2,R0		;ADJUST POINTER TO SKIP IT
	INC	R0		;ALSO SKIP LENGTH BYTE
	BR	2$		;SKIP NEXT LINE FIRST TIME THROUGH LOOP
1$:	JSR	PC,NXTPRP	;POINT TO NEXT PROPERTY
2$:	MOVB	(R0),R2		;GET PROPERTY IDENTIFIER
	BIC	#^C37,R2	;CLEAN OFF LENGTH BITS
	CMP	R2,R1		;COMPARE PROPERTY NUMBER WITH DESIRED ONE
	BGT	1$		;IF GREATER, LOOP (TABLE SORTED IN REVERSE)
	BLT	3$		;IF LESS, NO SUCH PROPERTY HERE
	MOVB	(R0),R2		;GOT IT, NOW FIND LENGTH OF PROPERTY
	INC	R0		;POINT TO PROPERTY VALUE
	ASH	#-5,R2		;GET LENGTH BITS
	BIC	#^C7,R2
	BNE	4$		;ZERO MEANS BYTE VALUE
	MOVB	(R0),R0		;GET THE BYTE
	JMP	BYTVAL		;AND RETURN IT
3$:	DEC	R1		;POINT INTO DEFAULT PROPERTY TABLE
	ASL	R1
	ADD	OBJTAB,R1
	MOV	R1,R0
4$:	JSR	PC,GTAWRD	;GET THE WORD
	JMP	PUTVAL		;AND RETURN IT

	;PUTP (CHANGE VALUE OF A PROPERTY, ERROR IF BAD NUMBER)
	.ENABL	LSB
OPPUTP::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	ADD	#7,R0		;POINT TO PROPERTY TABLE SLOT
	JSR	PC,GTAWRD	;GET ITS LOCATION
	ADD	#BUFFER,R0	;ABSOLUTIZE IT
	MOVB	(R0),R3		;LENGTH OF SHORT DESCRIPTION IN WORDS
	BIC	#^C377,R3	;CLEAN OFF ANY HIGH-ORDER BYTE
	ASL	R3		;CONVERT TO BYTES
	ADD	R3,R0		;ADJUST POINTER TO SKIP IT
	INC	R0		;ALSO SKIP LENGTH BYTE
	BR	2$		;SKIP NEXT LINE FIRST TIME THROUGH LOOP
1$:	JSR	PC,NXTPRP	;POINT TO NEXT PROPERTY
2$:	MOVB	(R0),R3		;GET PROPERTY IDENTIFIER
	BIC	#^C37,R3	;CLEAN OFF LENGTH BITS
	CMP	R3,R1		;COMPARE PROPERTY NUMBER WITH DESIRED ONE
	BEQ	3$		;IF EQUAL, GOT IT
	BGT	1$		;IF GREATER, LOOP (TABLE SORTED IN REVERSE)
	FATAL	<No such property> ;OTHERWISE, FATAL ERROR
3$:	MOVB	(R0),R3		;NOW FIND LENGTH OF PROPERTY
	INC	R0		;POINT TO PROPERTY VALUE
	ASH	#-5,R3		;GET LENGTH BITS
	BIC	#^C7,R3
	BNE	4$		;ZERO MEANS BYTE VALUE
	MOVB	R2,(R0)		;STORE THE NEW BYTE
	RTS	PC		;AND RETURN
4$:	MOV	R2,R1		;STORE THE NEW WORD VALUE
	JMP	PTAWRD
	.DSABL	LSB

	;NEXTP (RETURN NUMBER OF NEXT PROP FOLLOWING GIVEN PROB IN OBJ)
	.ENABL	LSB
OPNEXT::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	ADD	#7,R0		;POINT TO PROPERTY TABLE SLOT
	JSR	PC,GTAWRD	;GET ITS LOCATION
	ADD	#BUFFER,R0	;ABSOLUTIZE IT
	MOVB	(R0),R3		;LENGTH OF SHORT DESCRIPTION IN WORDS
	BIC	#^C377,R3	;CLEAN OFF ANY HIGH-ORDER BYTE
	ASL	R3		;CONVERT TO BYTES
	ADD	R3,R0		;ADJUST POINTER TO SKIP IT
	INC	R0		;ALSO SKIP LENGTH BYTE
	TST	R1		;WERE WE GIVEN ZERO AS PROP?
	BEQ	4$		;YES, GO RETURN FIRST PROPERTY NUMBER
	BR	2$		;NO, SKIP NEXT LINE FIRST TIME THROUGH LOOP
1$:	JSR	PC,NXTPRP	;POINT TO NEXT PROPERTY
2$:	MOVB	(R0),R3		;GET PROPERTY IDENTIFIER
	BIC	#^C37,R3	;CLEAN OFF LENGTH BITS
	CMP	R3,R1		;COMPARE PROPERTY NUMBER WITH DESIRED ONE
	BEQ	3$		;IF EQUAL, GOT IT
	BGT	1$		;IF GREATER, LOOP (TABLE SORTED IN REVERSE)
	FATAL	<No such property> ;OTHERWISE, FATAL ERROR
3$:	JSR	PC,NXTPRP	;POINT TO NEXT PROPERTY
4$:	MOVB	(R0),R0		;GET PROPERTY IDENTIFIER
	BIC	#^C37,R0	;EXTRACT PROPERTY NUMBER
	JMP	PUTVAL		;AND RETURN IT
	.DSABL	LSB
	.SBTTL	TABLE OPERATIONS


	;GET (GET THE ITEM'TH WORD FROM TABLE)
OPGET::	ASL	R1		;CONVERT ITEM TO BYTE COUNT
	ADD	R1,R0		;INDEX INTO TABLE
	JSR	PC,BSPLTB	;SPLIT THE POINTER
	JSR	PC,GETWRD	;GET THE WORD
	MOV	R2,R0
	JMP	PUTVAL		;AND RETURN IT

	;GETB (GET THE ITEM'TH BYTE FROM TABLE)
OPGETB::ADD	R1,R0		;INDEX INTO TABLE
	JSR	PC,BSPLTB	;SPLIT THE POINTER
	JSR	PC,GETBYT	;GET THE BYTE
	MOV	R2,R0
	JMP	BYTVAL		;AND RETURN IT

	;PUT (REPLACE THE ITEM'TH WORD IN TABLE)
OPPUT::	ASL	R1		;CONVERT ITEM TO BYTE COUNT
	ADD	R1,R0		;INDEX INTO TABLE
	ADD	#BUFFER,R0	;ABSOLUTIZE POINTER
	MOV	R2,R1
	JMP	PTAWRD		;STORE THE WORD

	;PUTB (REPLACE ITEM'TH BYTE IN TABLE)
OPPUTB::ADD	R1,R0		;INDEX INTO TABLE
	MOVB	R2,BUFFER(R0)	;STORE BYTE
	RTS	PC

	;GETPT (GET POINTER TO PROPERTY TABLE FOR GIVEN PROP)
OPGTPT::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	ADD	#7,R0		;POINT TO PROPERTY TABLE SLOT
	JSR	PC,GTAWRD	;GET ITS LOCATION
	ADD	#BUFFER,R0	;ABSOLUTIZE IT
	MOVB	(R0),R2		;LENGTH OF SHORT DESCRIPTION IN WORDS
	BIC	#^C377,R2	;CLEAN OFF ANY HIGH-ORDER BYTE
	ASL	R2		;CONVERT TO BYTES
	ADD	R2,R0		;ADJUST POINTER TO SKIP IT
	INC	R0		;ALSO SKIP LENGTH BYTE
	BR	2$		;SKIP NEXT LINE FIRST TIME THROUGH LOOP
1$:	JSR	PC,NXTPRP	;POINT TO NEXT PROPERTY
2$:	MOVB	(R0),R2		;GET PROPERTY IDENTIFIER
	BIC	#^C37,R2	;CLEAN OFF LENGTH BITS
	CMP	R2,R1		;COMPARE PROPERTY NUMBER WITH DESIRED ONE
	BGT	1$		;IF GREATER, LOOP (TABLE SORTED IN REVERSE)
	BEQ	3$		;FOUND THE PROPERTY
	CLR	R0		;RETURN ZERO FOR NO SUCH PROPERTY
	BR	4$
3$:	SUB	#BUFFER-1,R0	;POINT TO PROPERTY VALUE & RE-RELATIVIZE IT
4$:	JMP	PUTVAL		;AND RETURN IT

	;PTSIZE (RETURN SIZE OF PROPERTY TABLE)
OPPTSI::MOVB	BUFFER-1(R0),R0	;GET PROPERTY IDENTIFIER
	ASH	#-5,R0		;EXTRACT LENGTH BITS
	BIC	#^C7,R0
	INC	R0		;ADJUST TO ACTUAL LENGTH
	JMP	PUTVAL		;RETURN IT
	.SBTTL	VARIABLE OPERATIONS


	;VALUE (GET VALUE OF VAR)
OPVALU::JSR	PC,GETVAR	;GET THE VALUE
	JMP	PUTVAL		;AND RETURN IT

	;SET (VAR TO VALUE)
OPSET::	JMP	PUTVAR		;STORE THE VALUE

	;PUSH (A VALUE ONTO THE STACK)
OPPUSH::MOV	R0,-(R5)	;PUSH THE VALUE
	RTS	PC

	;POP (A VALUE OFF THE STACK INTO VAR)
OPPOP::	MOV	(R5)+,R1	;POP A VALUE
	JMP	PUTVAR		;AND STORE IT

	;INC (INCREMENT VAR)
OPINC::	SAVE	0
	JSR	PC,GETVAR	;GET VAR'S VALUE
	INC	R0		;INCREMENT IT
OPINC1:	MOV	R0,R1
	RESTOR	0
	JSR	PC,PUTVAR	;STORE NEW VALUE
	RTS	PC

	;DEC (DECREMENT VAR)
OPDEC::	SAVE	0
	JSR	PC,GETVAR	;GET VAR'S VALUE
	DEC	R0		;DECREMENT IT
	BR	OPINC1		;STORE NEW VALUE

	;IGRTR? (INCREMENT VAR & TEST IF GREATER THAN VAL)
OPQIGR::SAVE	0
	JSR	PC,GETVAR	;GET VAR'S VALUE
	INC	R0		;INCREMENT IT
	CLR	R2		;SET FLAG FALSE
	CMP	R0,R1		;NEW VALUE GREATER THAN VAL?
	BLE	OPQIG1		;NO
OPQIG0:	INC	R2		;YES, CHANGE FLAG TO TRUE
OPQIG1:	MOV	R0,R1
	RESTOR	0
	JSR	PC,PUTVAR	;STORE NEW VALUE
	TST	R2		;TEST FLAG
	BEQ	1$		;FALSE, PREDICATE FALSE
	JMP	PTRUE		;ELSE, PREDICATE TRUE
1$:	JMP	PFALSE

	;DLESS? (DECREMENT VAR & TEST IF LESS THAN VAL)
OPQDLE::SAVE	0
	JSR	PC,GETVAR	;GET VAR'S VALUE
	DEC	R0		;DECREMENT IT
	CLR	R2		;SET FLAG FALSE
	CMP	R0,R1		;NEW VALUE LESS THAN VAL?
	BGE	OPQIG1		;NO, PREDICATE FALSE
	BR	OPQIG0		;YES, PREDICATE TRUE
	.SBTTL	I/O OPERATIONS


EOLCHR=	12			;LINE-FEED IS END-OF-LINE CHARACTER
MOVVAR=	22			;NUMBER-OF-MOVES GLOBAL
SCRVAR=	21			;SCORE VARIABLE
RMVAR=	20			;CURRENT ROOM VARIABLE

	;USL (UPDATE STATUS LINE)
	DEFVAR	OLDCHS		;OLD NUMBER OF CHARACTERS PRINTED IN NUMBERS
	DEFVAR	OLDRM		;OLD ROOM
	.ENABL	LSB
OPUSL::	TST	P$TERM		;STATUS LINE REQUESTED?
	BNE	1$		;YES
	RTS	PC		;NO, DO NOTHING
1$:	CLR	R3		;COUNT NUMBER CHARACTERS HERE
	MOV	SAVPOS,R0	;SAVE OLD POSITION & SET ATTRIBUTES
	JSR	PC,OUTSTR
	TST	TIMEMD		;IN TIME MODE?
	BNE	2$		;YES
	MOV	SCRPOS,R0	;NO, MOVE TO SCORE POSITION
	JSR	PC,OUTSTR
	MOV	#SCRVAR,R0	;GET SCORE
	JSR	PC,GETVAR
	JSR	PC,OUTNUM	;PRINT IT
	ADD	R0,R3
	MOV	#'/,R0		;SEPARATOR
	JSR	PC,OUTCHR
	MOV	#MOVVAR,R0	;GET NUMBER-OF-MOVES
	JSR	PC,GETVAR
	JSR	PC,OUTNUM	;PRINT NUMBER OF MOVES
	ADD	R0,R3
	BR	6$
2$:	MOV	TIMPOS,R0	;MOVE TO TIME POSITION
	JSR	PC,OUTSTR
	MOV	#SCRVAR,R0	;GET HOUR
	JSR	PC,GETVAR
	MOV	#'a,R2		;ASSUME AM
	CMP	R0,#12.		;PM?
	BLT	4$		;NO
	BEQ	3$		;YES, BUT 12PM IS SPECIAL
	SUB	#12.,R0		;CONVERT TO 12-HOUR TIME
3$:	MOV	#'p,R2		;MODIFY EARLIER ASSUMPTION
4$:	TST	R0		;00 IS REALLY 12 AM
	BNE	5$
	MOV	#12.,R0
5$:	JSR	PC,OUTNUM	;PRINT HOUR
	ADD	R0,R3
	MOV	#':,R0		;SEPARATOR
	JSR	PC,OUTCHR
	MOV	#MOVVAR,R0	;GET MINUTES
	JSR	PC,GETVAR
	MOV	R0,R1		;OUTPUT MINUTES IN TWO DIGITS
	CLR	R0
	DIV	#10.,R0		;SEPARATE DIGITS
	ADD	#'0,R0		;PRINT FIRST ONE
	JSR	PC,OUTCHR
	MOV	R1,R0		;PRINT OTHER DIGIT
	ADD	#'0,R0
	JSR	PC,OUTCHR
	MOV	#40,R0		;SPACE
	JSR	PC,OUTCHR
	MOV	R2,R0		;AM OR PM
	JSR	PC,OUTCHR
	MOV	#'m,R0
	JSR	PC,OUTCHR
6$:	MOV	#RMVAR,R0	;GET CURRENT ROOM
	JSR	PC,GETVAR
	CMP	R0,OLDRM	;HAS IT CHANGED?
	BNE	7$		;YES
	CMP	R3,OLDCHS	;NO, BUT HAS SIZE OF NUMBERS CHANGED?
	BNE	7$		;YES
	CMP	P$TERM,#1	;NO, BUT IS THIS A VT100?
	BEQ	8$		;OK, GIVE UP
7$:	MOV	R0,OLDRM	;SAVE NEW ROOM
	MOV	R3,OLDCHS	;AND NUMBER OF CHARACTERS
	MOV	LOCPOS,R0	;MOVE TO ROOM POSITION
	JSR	PC,OUTSTR
	MOV	#OUTCHR,CHRFUN	;CHANGE CHARACTER FUNCTION TO DIRECT OUTPUT
	MOV	OLDRM,R0
	JSR	PC,OPPRND	;PRINT ROOM DESCRIPTION
	MOV	#PUTCHR,CHRFUN	;RESET CHARACTER FUNCTION
	MOV	CLRROL,R0	;CLEAR REST OF LINE
	JSR	PC,OUTSTR
8$:	MOV	RETPOS,R0	;RETURN TO OLD POSITION, RESET ATTRIBUTES,
	JMP	OUTSTR		;& RETURN
	.DSABL	LSB

	;READ (A LINE OF INPUT & PARSE IT, LINE BUF IN R0, RETURN BUF IN R1)
	.ENABL	LSB
OPREAD::SAVE	01
	JSR	PC,OPUSL	;UPDATE STATUS LINE
	RESTOR	1
	JSR	PC,TSTSCR	;TEST FOR SCRIPTING & UPDATE FLAGS ACCORDINGLY
	MOVB	#200,@CHRPTR	;DON'T END OUTPUT, IF ANY, WITH NEW LINE
1$:	JSR	PC,BUFOUT	;FORCE OUT ANY QUEUED TEXT
	CLRB	@CHRPTR		;RESTORE CRLF CHARACTER
	MOV	OUTBUF,CHRPTR	;RESET CHARACTER POINTER
	RESTOR	2		;INPUT BUFFER POINTER
	ADD	#BUFFER,R2	;ABSOLUTIZE IT
	MOV	R2,R4
	MOVB	(R2)+,R3	;MAX NUMBER OF CHARACTERS TO GET
2$:	JSR	PC,GETCHR	;INPUT A CHARACTER
	CMP	R0,#EOLCHR	;END OF THE LINE?
	BEQ	5$		;YES
	CMP	R0,#'A		;NO, UPPERCASE?
	BLT	3$		;NO
	CMP	R0,#'Z
	BGT	3$		;NO
	ADD	#40,R0		;YES, LOWERCASIFY IT
3$:	MOVB	R0,(R2)+	;SAVE IN LINE BUFFER
	SOB	R3,2$		;LOOP UNTIL EOL OR BUFFER FULL
	JSR	PC,GETCHR	;BUFFER FULL, LAST CHANCE FOR EOL
	CMP	R0,#EOLCHR	;IS IT?
	BEQ	5$		;YES, WIN
	SAVE	0		;NO, INFORM LOSER
	PRIN1	<Input line too long, flushing: >
	RESTOR	0
4$:	JSR	PC,OUTCHR	;AND FLUSH REST OF LINE
	JSR	PC,GETCHR
	CMP	R0,#EOLCHR
	BNE	4$
	JSR	PC,OUTCHR

5$:	CMPB	1(R4),#'@	;IS THIS A REQUEST FOR A COMMAND FILE?
	BNE	7$		;NO
	TST	CMDBUF		;YES, ALREADY HAVE A COMMAND FILE OPEN?
	BNE	6$		;YES, IGNORE THIS LINE & GET ANOTHER
	JSR	PC,OPNCFL	;NO, OPEN THE COMMAND FILE
6$:	SUB	#BUFFER,R4	;RERELATIVIZE INPUT BUFFER POINTER,
	SAVE	4		;PUT ONTO STACK,
	BR	1$		;AND READ ANOTHER LINE

7$:	DEFVAR	RDWSTR,<.BLKW 4> ;WORD STRING BUFFER FOR ZWORD
	DEFVAR	RDBOS		;BEGINNING OF STRING POINTER
	DEFVAR	RDEOS		;END OF STRING POINTER
	DEFVAR	RDRET		;RETURN TABLE POINTER
	DEFVAR	RDNWDS		;NUMBER OF WORDS READ
	SAVE	5
	MOV	R4,RDBOS	;INITIALIZE RDBOS
	MOV	R2,RDEOS	;AND RDEOS
	ADD	#BUFFER,R1	;ABSOLUTIZE RET POINTER
	MOV	R1,RDRET	;AND STORE IT
	CLR	RDNWDS		;NO WORDS SO FAR
	INC	R4		;SKIP LENGTH BYTE
	MOV	R1,R5		;THIS WILL BE WORD ENTRY POINTER
	ADD	#2,R5		;SKIP MAX WORDS & NWORDS BYTES
8$:	MOV	#RDWSTR,R3	;HERE FOR NEXT WORD, POINT TO WORD STRING
	MOV	R4,R1		;AND SAVE BEGINNING OF WORD POINTER
9$:	CMP	R4,RDEOS	;END OF STRING?
	BNE	10$		;NO
	CMP	R3,#RDWSTR	;YES, WAS A WORD FOUND?
	BEQ	23$		;NO, WE'RE DONE
	BR	15$		;YES, WE STILL HAVE TO LOOKUP WORD
10$:	MOVB	(R4)+,R0	;GET NEXT CHARACTER FROM BUFFER
	MOV	RBRKS,R2	;LIST OF READ BREAK CHARACTERS
11$:	CMPB	R0,(R2)+	;SEARCH LIST FOR THIS ONE
	BEQ	12$		;FOUND IT
	TSTB	(R2)		;END OF LIST?
	BNE	11$		;NO, CONTINUE SEARCH
	CMP	R3,#RDWSTR+6	;YES, NOT A BREAK, WORD STRING FULL?
	BEQ	9$		;YES, LOOP UNTIL END OF WORD
	MOVB	R0,(R3)+	;NO, TACK THIS CHARACTER ONTO STRING
	BR	9$		;AND LOOP
12$:	CMP	R3,#RDWSTR	;WORD READ BEFORE THIS BREAK?
	BNE	14$		;YES
	CMP	R2,ESIBKS	;NO, BUT IS IT A SELF-INSERTING BREAK?
	BLOS	13$		;YES
	INC	R1		;NO, UPDATE BEGINNING OF WORD TO SKIP BREAK
	BR	9$		;AND RETURN TO LOOP TO FIND A WORD
13$:	MOVB	R0,(R3)+	;STORE THE BREAK IN WORD STRING
	BR	15$		;AND GO FOR THE WORD
14$:	DEC	R4		;UNREAD TERMINATING BREAK IN CASE IT WAS SI
15$:	INC	RDNWDS		;INCREMENT FOUND WORD COUNT
	CMPB	RDNWDS,@RDRET	;GREATER THAN MAX ALLOWED?
	BLE	16$		;NO
	PRIN1	<Too many words typed, flushing: > ;YES, INFORM LOSER
	MOV	R1,R0		;BEGINNING OF THIS WORD
	MOVB	@RDEOS,R1	;SAVE BYTE AFTER EOS
	CLRB	@RDEOS		;ZERO IT TO MAKE STRING ASCIZ
	JSR	PC,OUTSTR	;PRINT IT
	MOVB	R1,@RDEOS	;AND RESTORE OLD BYTE
	DEC	RDNWDS		;REMEMBER THAT WE FLUSHED THIS WORD
	BR	23$		;AND WE'RE DONE
16$:	MOV	R1,R0		;CALCULATE NUMBER OF CHARACTERS IN WORD
	NEG	R0
	ADD	R4,R0
	MOVB	R0,2(R5)	;SAVE THE NUMBER IN RET TABLE
	SUB	RDBOS,R1	;BYTE OFFSET FOR BEGINNING OF WORD
	MOVB	R1,3(R5)	;STORE IT, TOO
	CLRB	(R3)		;MAKE WORD STRING ASCIZ
	MOV	#RDWSTR,R0	;POINT TO IT
	JSR	PC,ZWORD	;AND CONVERT TO (2-WORD) ZWORD
	SAVE	45		;SAVE CHAR & WORD ENTRY POINTERS
	MOV	R0,R4		;FIRST ZWORD WORD
	MOV	R1,R5		;SECOND ZWORD WORD
	MOV	VWORDS,R2	;NUMBER OF VOCABULARY WORDS
	MOV	R2,R3
	DEC	R3		;WE WANT TO POINT TO LAST WORD
	MUL	VWLEN,R3	;MULTIPLY BY WORD LENGTH IN BYTES
	ADD	VOCBEG,R3	;ADD POINTER TO BEGINNING TO FIND LAST WORD
	MOV	VWLEN,R1	;CALCULATE INITIAL OFFSET FOR BINARY SEARCH
	ASR	R2
17$:	ASL	R1
	ASR	R2
	BNE	17$
	MOV	VOCBEG,R2	;BEGINNING OF WORD TABLE
	ADD	R1,R2		;ADD CURRENT OFFSET (HALF OF POWER-OF-2 TABLE)
	SUB	VWLEN,R2	;AVOID FENCE-POST BUG FOR EXACT POWER-OF-2 TBL
18$:	ASR	R1		;NEXT OFFSET WILL BE HALF OF PREVIOUS ONE
	MOV	R2,R0		;GET FIRST HALF OF CURRENT ZWORD
	JSR	PC,GTAWRD
	CMP	R4,R0		;COMPARE DESIRED ONE TO IT
	BHI	19$		;GREATER, WE'LL HAVE TO MOVE UP
	BLO	20$		;LESS, WE'LL HAVE TO MOVE DOWN
	MOV	R2,R0		;SAME, GET SECOND HALF
	ADD	#2,R0
	JSR	PC,GTAWRD
	CMP	R5,R0		;COMPARE DESIRED WORD WITH IT
	BHI	19$		;GREATER, WE'LL HAVE TO MOVE UP
	BLO	20$		;LESS, WE'LL HAVE TO MOVE DOWN
	SUB	#BUFFER,R2	;SAME, WE'VE FOUND IT, RELATIVIZE POINTER
	BR	22$		;AND RETURN IT
19$:	ADD	R1,R2		;TO MOVE UP, ADD CURRENT OFFSET
	CMP	R2,R3		;HAVE WE MOVED PAST END OF TABLE?
	BLOS	21$		;NO
	MOV	R3,R2		;YES, POINT TO END OF TABLE INSTEAD
	BR	21$
20$:	SUB	R1,R2		;TO MOVE DOWN, SIMPLY SUBTRACT OFFSET
21$:	CMP	R1,VWLEN	;IS OFFSET RESOLUTION BELOW ONE WORD?
	BGE	18$		;NO, CONTINUE LOOP
	CLR	R2		;YES, WORD NOT FOUND, RETURN ZERO
22$:	RESTOR	54		;RESTORE WORD ENTRY AND CHAR POINTERS
	MOV	R5,R0		;POINTER TO WORD FOUND GOES HERE
	MOV	R2,R1		;THE POINTER
	JSR	PC,PTAWRD	;STORE IT
	ADD	#4,R5		;UPDATE POINTER FOR NEXT WORD ENTRY
	JMP	8$		;GO FOR IT
23$:	INC	RDRET		;DONE, STORE NUMBER OF WORDS FOUND
	MOVB	RDNWDS,@RDRET
	RESTOR	5		;RESTORE USER STACK POINTER
	RTS	PC		;AND RETURN
	.DSABL	LSB

	;PRINTC (PRINT CHAR WHOSE ASCII VALUE IS GIVEN)
OPPRNC::JMP	PUTCHR		;QUEUE THE CHARACTER FOR PRINTING

	;PRINTN (PRINT A NUMBER)
OPPRNN::MOV	R0,R1		;NUMBER TO PRINT
	BNE	1$		;NON-ZERO
	MOV	#'0,R0		;SPECIAL CASE ZERO
	JMP	PUTCHR
1$:	BGT	2$		;POSITIVE?
	MOV	#'-,R0		;NO, PRINT MINUS SIGN
	JSR	PC,PUTCHR
	NEG	R1		;AND MAKE IT POSITIVE
2$:	CLR	R2		;COUNT OF DIGITS ON STACK
	BR	4$		;START WITH GREATER-THAN-10 TEST
3$:	CLR	R0		;EXTRACT A DIGIT
	DIV	#10.,R0
	MOV	R1,-(SP)	;PUSH IT
	INC	R2		;BUMP COUNT
	MOV	R0,R1		;GET QUOTIENT
4$:	CMP	R1,#10.		;MORE DIGITS TO EXTRACT?
	BGE	3$		;YES, GO LOOP
	MOV	R1,R0		;NO, GET LAST (FIRST) DIGIT
	BR	6$		;ALREADY IN PLACE
5$:	MOV	(SP)+,R0	;POP NEXT DIGIT
6$:	ADD	#'0,R0		;ASCIIZE IT
	JSR	PC,PUTCHR	;QUEUE IT
	DEC	R2		;REDUCE DIGIT COUNT
	BGE	5$		;LOOP IF SOME LEFT
	RTS	PC		;ELSE, RETURN

	;PRINT (THE STRING POINTED TO)
OPPRIN::JSR	PC,BSPLIT	;SPLIT THE BLOCK & WORD NUMBERS
	JMP	PUTSTR		;PRINT THE STRING

	;PRINTB (PRINT THE STRING POINTED TO BY THE BYTE-POINTER)
OPPRNB::JSR	PC,BSPLTB	;SPLIT THE BLOCK & BYTE NUMBERS
	JMP	PUTSTR		;PRINT THE STRING

	;PRINTD (PRINT OBJ'S SHORT DESCRIPTION)
OPPRND::JSR	PC,OBJLOC	;FIND OBJ'S LOCATION
	ADD	#7,R0		;PROPERTY TABLE POINTER
	JSR	PC,GTAWRD	;GET IT
	INC	R0		;POINT TO STRING
	JSR	PC,BSPLTB	;SPLIT POINTER
	JMP	PUTSTR		;AND PRINT THE STRING

	;PRINTI (PRINT THE STRING FOLLOWING THIS INSTRUCTION)
OPPRNI::MOV	ZPC1,R0		;GET POINTER TO STRING
	MOV	ZPC2,R1
	JSR	PC,PUTSTR	;AND PRINT IT
	MOV	R0,ZPC1		;UPDATE ZPC
	MOV	R1,ZPC2
	JMP	NEWZPC

	;PRINTR (PRINTI FOLLOWED BY RTRUE)
OPPRNR::JSR	PC,OPPRNI	;DO A PRINTI
	JSR	PC,OPCRLF	;A CRLF
	JMP	OPRTRU		;AND AN RTRUE

	;CRLF (DO A NEWLINE)
OPCRLF::JMP	NEWLIN		;DO A NEWLINE
	.SBTTL	CONTROL OPERATIONS


	;CALL (A FUNCTION WITH OPTIONAL ARGUMENTS)
OPCALL::NOP			;TELL CALLER TO USE ARGUMENT BLOCK
	MOV	R0,R2		;ARGUMENT BLOCK POINTER
	MOV	2(R2),R0	;FUNCTION TO CALL
	BNE	1$		;ZERO?
	CLR	R0		;YES, SIMPLY RETURN A ZERO
	JMP	PUTVAL
1$:	MOV	ZPC1,-(R5)	;OTHERWISE, SAVE OLD ZPC
	MOV	ZPC2,-(R5)
	MOV	ZLOCS,-(R5)	;AND OLD LOCAL POINTER
	SUB	STKBOT,(R5)	;BUT RELATIVIZE IT IN CASE OF SAVE
	JSR	PC,BSPLIT	;SPLIT FUNCTION POINTER
	MOV	R0,ZPC1		;MAKE IT THE NEW ZPC
	MOV	R1,ZPC2
	JSR	PC,NEWZPC	;UPDATE ZPC STUFF
	MOV	R5,ZLOCS	;LOCALS WILL START AT NEXT STACK SLOT
	SUB	#2,ZLOCS
	JSR	PC,NXTBYT	;NUMBER OF LOCALS
	MOV	R0,R1
	MOV	(R2),R3		;NUMBER OF ARGUMENTS TO CALL
	ADD	#4,R2		;POINT TO FIRST OPTIONAL ARG
2$:	DEC	R1		;ANY MORE LOCALS?
	BLT	4$		;NO, WE'RE DONE
	JSR	PC,NXTWRD	;YES, GET THE NEXT LOCAL DEFAULT VALUE
	DEC	R3		;ANY MORE OPTIONALS GIVEN?
	BLE	3$		;NO
	MOV	(R2)+,-(R5)	;YES, USE ITS VALUE
	BR	2$		;AND CONTINUE LOOP
3$:	MOV	R0,-(R5)	;OTHERWISE, USE DEFAULT
	BR	2$		;AND LOOP
4$:	RTS	PC

	;RETURN (FROM CURRENT FUNCTION CALL)
OPRETU::MOV	ZLOCS,R5	;RESTORE OLD TOP OF STACK
	TST	(R5)+
	MOV	(R5)+,ZLOCS	;AND OTHER VALUES
	ADD	STKBOT,ZLOCS	;RE-ABSOLUTIZE THIS ONE
	MOV	(R5)+,ZPC2
	MOV	(R5)+,ZPC1
	SAVE	0		;VALUE TO RETURN
	JSR	PC,NEWZPC	;UPDATE ZPC STUFF
	RESTOR	0
	JMP	PUTVAL		;RETURN THE VALUE

	;RTRUE
OPRTRU::MOV	#1,R0		;RETURN A 1
	BR	OPRETU

	;RFALSE
OPRFAL::CLR	R0		;RETURN A 0
	BR	OPRETU

	;JUMP (TO A NEW LOCATION)
OPJUMP::ADD	R0,ZPC2		;ADD OFFSET TO CURRENT ZPC
	SUB	#2,ZPC2		;ADJUST IT
	JMP	NEWZPC		;NORMALIZE IT & UPDATE ZPC STUFF

	;RSTACK (RETURN STACK)
OPRSTA::MOV	(R5)+,R0	;POP A VALUE
	BR	OPRETU		;AND RETURN IT

	;FSTACK (FLUSH A VALUE OFF THE STACK)
OPFSTA::TST	(R5)+		;FLUSH ONE
	RTS	PC

	;NOOP (NO OPERATION)
OPNOOP::RTS	PC		;DO NOTHING
	.SBTTL	GAME COMMANDS


	;SAVE (THE CURRENT STATE OF THE GAME)
OPSAVE::MOV	PURBOT,R0	;NUMBER OF BLOCKS NEEDED FOR IMPURE STUFF
	INC	R0		;+ 1 BLOCK FOR STACK = SAVE FILE LENGTH
	JSR	R5,NEWSFL	;CREATE THE SAVE FILE
	BR	JPF2		;FAILURE
	MOV	ZPC1,-(R5)	;SUCCESS, SAVE STUFF ON USER STACK
	MOV	ZPC2,-(R5)
	MOV	ZLOCS,-(R5)
	SUB	STKBOT,(R5)	;RELATIVIZE THIS ONE
	MOV	ZORKID,-(R5)
	MOV	R5,@STKBOT	;SAVE USER SP IN KNOWN LOCATION
	SUB	STKBOT,@STKBOT	;RELATIVIZE IT
	CLR	R0		;THIS WILL BE BLOCK ZERO
	MOV	STKBOT,R1	;STARTING AT BOTTOM OF STACK PAGE
	MOV	#1,R2		;STACK IS 1 PAGE LONG
	JSR	R5,PTSBKS	;WRITE IT OUT
	BR	JPF2		;FAILURE
	ADD	#10,R5		;RESET STACK POINTER
	MOV	#1,R0		;IMPURE STUFF STARTS AT BLOCK 1
	MOV	#BUFFER,R1	;BEGINNING OF IMPURE STUFF IN CORE
	MOV	PURBOT,R2	;NUMBER OF PAGES
	JSR	R5,PTSBKS	;WRITE THEM OUT
	BR	JPF2		;FAILURE
	JSR	PC,CLSSFL	;AND CLOSE THE FILE
JPT2:	JMP	PTRUE		;PREDICATE TRUE
JPF2:	JMP	PFALSE		;PREDICATE FALSE

	;RESTORE (A PREVIOUSLY SAVED GAME STATE)
OPREST::JSR	R5,OPNSFL	;OPEN THE SAVE FILE
	BR	JPF2		;FAILURE
	CLR	R0		;GET STACK FIRST FROM BLOCK 0
	MOV	STKBOT,R1	;PUT IT HERE
	MOV	#1,R2		;1 PAGE LONG
	JSR	PC,GTSBKS	;READ IT IN
	MOV	@STKBOT,R5	;RESTORE SAVED USER SP
	ADD	STKBOT,R5	;ABSOLUTIZE IT
	CMP	(R5)+,ZORKID	;IS SAVED ZORKID SAME AS OURS?
	BNE	1$		;NO
	MOV	(R5)+,ZLOCS	;YES, RESTORE OTHER STUFF
	ADD	STKBOT,ZLOCS	;RE-ABSOLUTIZE THIS ONE
	MOV	(R5)+,ZPC2
	MOV	(R5)+,ZPC1
	MOV	BUFFER+PFLAGS,R4 ;SAVE OLD FLAGS
	MOV	#1,R0		;GET IMPURE PART STARTING AT BLOCK 1
	MOV	#BUFFER,R1	;PUT IT HERE
	MOV	PURBOT,R2	;LENGTH OF IMPURE PART
	JSR	PC,GTSBKS	;READ IT IN
	JSR	PC,CLSSFL	;CLOSE THE FILE
	MOV	R4,BUFFER+PFLAGS ;RESTORE OLD FLAGS
	JSR	PC,NEWZPC	;POINT TO PROPER ZPC PAGE
	BR	JPT2		;AND RETURN PREDICATE TRUE
1$:	FATAL	<Wrong game or version>

	;RESTART (THE GAME)
OPRSTT::CLRB	@CHRPTR		;FORCE OUT ANY QUEUED TEXT
	JSR	PC,BUFOUT
	JMP	RESTRT		;SKIP FILE OPENING & USER DIALOGUE

	;QUIT
OPQUIT::TST	P$TERM		;STATUS LINE
	BEQ	1$		;NO
	MOV	TRMUNI,R0	;YES, UNINITIALIZE THE TERMINAL
	JSR	PC,OUTSTR
1$:	JMP	FINISH		;DIE PEACEFULLY

	;VERIFY (GAME FILE)
OPVERI::MOV	#BUFFER+PLENTH,R0 ;GET FILE LENGTH
	CALL	GTAWRD
	CALL	BSPLIT
	SAVE	5
	MOV	R0,R4
	MOV	R1,R5
	CLR	R0		;STARTING BLOCK POINTER
	MOV	#100,R1		;BYTE POINTER
	CLR	R3		;PUT CHECKSUM HERE
	MOV	ENDLOD,-(SP)
	CLR	ENDLOD		;FORCE LOADING FROM DISK
1$:	CALL	GETBYT		;GET NEXT BYTE
	ADD	R2,R3		;ADD IN TO CHECKSUM
	CMP	R0,R4		;DONE YET?
	BNE	1$		;NO
	CMP	R1,R5		;MAYBE
	BNE	1$		;NO
	MOV	#BUFFER+PCHKSM,R0 ;DONE, COMPARE WITH REAL CHECKSUM
	CALL	GTAWRD
	MOV	(SP)+,ENDLOD	;RESTORE PROPER ENDLOD
	RESTOR	5
	CMP	R0,R3
	BNE	2$		;ERROR
	JMP	PTRUE		;SUCCESS
2$:	JMP	PFALSE		;FAILURE
	.SBTTL	LOW LEVEL FUNCTIONS


	;GET CORE WORD, ABSOLUTE POINTER GIVEN IN R0, RETURN WORD IN R0
GTAWRD::SAVE	1
	MOV	R0,R1
	MOVB	(R1)+,R0	;GET HIGH-ORDER BYTE
	SWAB	R0		;POSITION IT
	BIC	#377,R0		;CLEAR UNWANTED BITS
	BISB	(R1),R0		;OR IN LOW-ORDER BYTE
	RESTOR	1
	RTS	PC

	;UPDATE CORE WORD, ABSOLUTE POINTER GIVEN IN R0, NEW VALUE IN R1
PTAWRD::MOVB	R1,1(R0)	;STORE LOW-ORDER BYTE
	SWAB	R1
	MOVB	R1,(R0)		;STORE HIGH-ORDER BYTE
	RTS	PC

	;GET A BYTE, BLOCK-POINTER IN R0, BYTE-POINTER IN R1, RESULT IN R2,
	;UPDATE R0 & R1 TO REFLECT BYTE GOTTEN
GETBYT::SAVE	0
	CMP	R0,ENDLOD	;IS THIS A PRELOADED LOCATION?
	BGE	1$		;NO
	ASH	#9.,R0		;YES, RECONSTRUCT POINTER
	BIS	R1,R0
	MOVB	BUFFER(R0),R2	;GET THE BYTE
	BR	2$		;CLEAR UNWANTED BYTE & RETURN IT
1$:	JSR	PC,GETPAG	;FIND THE PROPER PAGE
	ADD	R1,R0		;POINT TO DESIRED BYTE
	MOVB	(R0),R2		;GET IT
2$:	BIC	#^C377,R2	;CLEAR UNWANTED BYTE & RETURN IT
	RESTOR	0
	INC	R1		;UPDATE POINTER
	CMP	R1,#1000	;END-OF-PAGE?
	BNE	3$		;NO
	CLR	R1		;YES, CLEAR BYTE-POINTER
	INC	R0		;AND UPDATE BLOCK-POINTER
3$:	RTS	PC

	;GET A WORD, BLOCK POINTER IN R0, BYTE-POINTER IN R1, RESULT IN R2
GETWRD::JSR	PC,GETBYT	;GET HIGH-ORDER BYTE
	SWAB	R2		;POSITION IT
	MOV	R2,-(SP)	;SAVE IT
	JSR	PC,GETBYT	;GET LOW-ORDER BYTE
	BIS	(SP)+,R2	;OR IN OTHER BYTE
	RTS	PC

	;GET THE NEXT BYTE, RETURN IT IN R0
NXTBYT::MOV	ZPC2,R0		;BYTE POINTER
	ADD	CURPAG,R0	;INDEX INTO CURRENT PAGE
	MOVB	(R0),-(SP)	;SAVE BYTE
	INC	ZPC2		;UPDATE PC
	CMP	ZPC2,#1000	;END-OF-PAGE?
	BLT	1$		;NO
	JSR	PC,NEWZPC	;YES, UPDATE PAGE
1$:	MOVB	(SP)+,R0	;RETRIEVE BYTE
	BIC	#^C377,R0	;CLEAR UNWANTED BYTE
	RTS	PC		;AND RETURN IT

	;GET THE NEXT WORD, RETURN IT IN R0
NXTWRD::JSR	PC,NXTBYT	;GET HIGH-ORDER BYTE
	SWAB	R0		;MOVE TO PROPER POSITION
	MOV	R0,-(SP)	;SAVE IT
	JSR	PC,NXTBYT	;GET LOW-ORDER BYTE
	BIS	(SP)+,R0	;OR IN HIGH-ORDER BYTE
	RTS	PC		;RETURN THE WORD

	;GET AN ARGUMENT GIVEN ITS TYPE IN R0
GETARG::DEC	R0		;EXAMINE ARGUMENT
	BLT	NXTWRD		;0 MEANT LONG IMMEDIATE
	BEQ	NXTBYT		;1 MEANT SHORT IMMEDIATE
	JSR	PC,NXTBYT	;2 MEANT VARIABLE, GET THE VAR
	TST	R0		;STACK?
	BNE	GETVAR		;NO, JUST GET THE VAR'S VALUE
1$:	MOV	(R5)+,R0	;YES, POP THE STACK
	RTS	PC

	;GET VALUE OF A VARIABLE, VAR IN R0, VALUE RETURNED IN R0
GETVAR::TST	R0		;STACK?
	BNE	1$		;NO
	MOV	(R5),R0		;YES, GET TOP-OF-STACK
	RTS	PC
1$:	CMP	R0,#20		;LOCAL?
	BGE	2$		;NO
	DEC	R0		;YES, POINT TO PROPER STACK ELEMENT
	ASL	R0
	NEG	R0
	ADD	ZLOCS,R0
	MOV	(R0),R0		;AND GET IT
	RTS	PC
2$:	SUB	#20,R0		;GLOBAL, POINT TO PROPER GLOBAL TABLE ELEMENT
	ASL	R0
	ADD	GLOTAB,R0
	JMP	GTAWRD		;AND GET IT

	;UPDATE VALUE OF A VARIABLE, VAR IN R0, NEW VALUE IN R1
PUTVAR::TST	R0		;STACK?
	BNE	1$		;NO
	MOV	R1,(R5)		;YES, UPDATE TOP-OF-STACK
	RTS	PC
1$:	CMP	R0,#20		;LOCAL?
	BGE	2$		;NO
	DEC	R0		;YES, POINT TO PROPER STACK ELEMENT
	ASL	R0
	NEG	R0
	ADD	ZLOCS,R0
	MOV	R1,(R0)		;AND UPDATE IT
	RTS	PC
2$:	SUB	#20,R0		;GLOBAL, POINT TO PROPER GLOBAL TABLE ELEMENT
	ASL	R0
	ADD	GLOTAB,R0
	JMP	PTAWRD		;AND UPDATE IT

	;RETURN VAL IN R0 TO LOCATION SPECIFIED BY NEXTBYTE
	;DESTROYS R1, BUT IS USUALLY CALLED AT END OF TOP-LEVEL FUNCTION
BYTVAL::BIC	#^C377,R0	;THIS ENTRY FOR BYTE VALUE TO CLEAR HIGH BYTE
PUTVAL::MOV	R0,R1		;NORMAL ENTRY
	JSR	PC,NXTBYT	;GET VAR TO USE
	TST	R0		;STACK?
	BNE	PUTVAR		;NO, GO STORE VALUE
	MOV	R1,-(R5)	;YES, PUSH ONTO STACK
	RTS	PC		;AND RETURN

	;PREDICATE HANDLERS TRUE & FALSE
	;DESTROYS REGISTERS, BUT ARE ONLY CALLED FROM END OF TOP-LEVEL FCNS
PFALSE::CLR	R1		;PREDICATE WAS FALSE, CLEAR FLAG
	BR	PTRUE1
PTRUE::	MOV	#1,R1		;PREDICATE WAS TRUE, SET FLAG
PTRUE1:	JSR	PC,NXTBYT	;GET FIRST (OR ONLY) PREDICATE JUMP BYTE
	BIT	#200,R0		;NORMAL POLARITY PREDICATE?
	BEQ	1$		;NO, LEAVE FLAG ALONE
	INC	R1		;YES, INCREMENT FLAG
1$:	BIT	#100,R0		;ONE-BYTE JUMP OFFSET?
	BEQ	2$		;NO
	BIC	#300,R0		;YES, CLEAR SPECIAL BITS
	BR	3$
2$:	BIC	#300,R0		;CLEAR SPECIAL BITS FROM HIGH-ORDER OFFSET BYT
	SWAB	R0		;POSITION IT
	MOV	R0,R2
	JSR	PC,NXTBYT	;GET LOW-ORDER BYTE
	BIS	R2,R0		;OR IN HIGH-ORDER BITS
	BIT	#20000,R0	;IS NUMBER NEGATIVE (14-BIT 2'S COMP NUMBER)?
	BEQ	3$		;NO
	BIS	#140000,R0	;YES, MAKE 16-BIT NUMBER NEGATIVE
3$:	DEC	R1		;TEST FLAG
	BEQ	6$		;WAS 1, THAT MEANS DO NOTHING
	TST	R0		;ZERO JUMP?
	BNE	4$		;NO
	JMP	OPRFAL		;YES, THAT MEANS DO AN RFALSE
4$:	DEC	R0		;ONE JUMP?
	BNE	5$		;NO
	JMP	OPRTRU		;YES, THAT MEANS DO AN RTRUE
5$:	DEC	R0		;ADJUST OFFSET
	ADD	R0,ZPC2		;ADD TO PC
	JMP	NEWZPC		;AND UPDATE ZPC STUFF
6$:	RTS	PC

	;SPLIT BYTE-POINTER IN R0 INTO BLOCK-POINTER IN R0 & BYTE OFFSET IN R1
BSPLTB::MOV	R0,R1
	SWAB	R0		;EXTRACT BLOCK BITS
	ASR	R0
	BIC	#^C177,R0	;CLEAR UNWANTED BITS
	BIC	#^C777,R1	;CLEAR ALL BUT BYTE OFFSET BITS
	RTS	PC

	;SPLIT WORD-POINTER IN R0 INTO BLOCK-POINTER IN R0 & BYTE-OFFSET IN R1
BSPLIT::MOV	R0,R1
	SWAB	R0		;EXTRACT BLOCK BITS
	BIC	#^C377,R0	;CLEAR UNWANTED BITS
	BIC	#^C377,R1	;CLEAR ALL BUT WORD OFFSET BITS
	ASL	R1		;CONVERT TO BYTE OFFSET
	RTS	PC
	.SBTTL	OBJECT HACKERS


	;GIVEN OBJ NUMBER IN R0, RETURN OBJ LOCATION IN R0
OBJLOC::BIC	#^C377,R0	;CLEAR UNWANTED BITS
	MOV	R0,-(SP)	;MULTIPLY BY 9 THE LAZY WAY
	ASL	R0
	ASL	R0
	ASL	R0
	ADD	(SP)+,R0
	ADD	OBJTAB,R0	;INDEX INTO OBJECT TABLE
	ADD	#53.,R0		;SKIPPING DEFAULT PROPERTY TABLE
	RTS	PC

	;GIVEN POINTER TO A PROPERTY IN R0, UPDATE IT TO POINT TO NEXT PROP
NXTPRP::MOV	R0,-(SP)	;SAVE POINTER FOR LATER
	MOVB	(R0),R0		;GET PROPERTY IDENTIFIER
	ASH	#-5,R0		;EXTRACT PROPERTY LENGTH (MINUS 1)
	BIC	#^C7,R0
	ADD	(SP)+,R0	;ADD IT TO OLD POINTER
	ADD	#2,R0		;ADJUST FOR EXTRA LENGTH BYTE PLUS IDENTIFIER
	RTS	PC
	.SBTTL	STRING FUNCTIONS


	.PSECT	STRING

	;ZSTR CHARACTER CONVERSION VECTOR
ZCHRS::	.ASCII	/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ/
	.ASCII	\  0123456789.,!?_#'"/\
	.ASCIZ	/\-:()/

	.PSECT	CODE

PADCHR=	5			;ZSTR PADDING CHARACTER

	;OUTPUT A ZSTR, BLOCK-POINTER IN R0, BYTE-POINTER IN R1
	;RETURN UPDATED POINTER
	DEFVAR	CHRFUN,PUTCHR	;CHARACTER OUTPUT FUNCTION
	DEFVAR	WRDOFF		;OFFSET INTO WORD TABLE FOR CURRENT SET
PUTSTR::SAVE	2345
	CLR	R4		;TEMP CS STARTS AT 0
	CLR	R5		;PERM CS STARTS AT 0
1$:	JSR	PC,GETWRD	;GET NEXT STRING WORD
	SAVE	012		;SAVE POINTER & COPY OF STRING WORD
	MOV	#3,R3		;3 BYTES IN WORD
2$:	SAVE	2		;SAVE CURRENT BYTE (IN LOW-ORDER POSITION)
	ASH	#-5,R2		;SHIFT TO NEXT BYTE
	SOB	R3,2$		;LOOP UNTIL DONE
	MOV	#3,R3		;RETRIEVE THE 3 BYTES
3$:	RESTOR	2		;GET NEXT BYTE
	BIC	#^C37,R2	;CLEAR UNWANTED BITS
	TST	R4		;IN WORD MODE?
	BPL	4$		;NO
	ASL	R2		;YES, CALCULATE WORD OFFSET
	ADD	WRDTAB,R2	;POINT INTO WORD TABLE
	ADD	WRDOFF,R2	;USING PROPER 32-WORD BLOCK
	MOV	R2,R0
	JSR	PC,GTAWRD	;POINT TO WORD STRING
	JSR	PC,BSPLIT	;SPLIT IT
	JSR	PC,PUTSTR	;AND PRINT IT
	BR	15$		;CONTINUE WHERE WE LEFT OFF WITH TEMP CS RESET
4$:	CMP	R4,#3		;CS 3 SELECTED (ASCII MODE)?
	BLT	6$		;NO, NORMAL CS
	BNE	5$		;NO, BUT WE ARE IN ASCII MODE
	SWAB	R4		;SHIFT SOME BITS HIGH TO MAKE NUMBER LARGE
	BIS	R2,R4		;SAVE HIGH-ORDER ASCII BITS HERE
	BR	16$		;GO GET NEXT BYTE
5$:	BIC	#^C3,R4		;EXTRACT PREVIOUSLY SAVED HIGH-ORDER BITS
	ASH	#5,R4		;POSITION THEM
	BIS	R2,R4		;OR IN LOW-ORDER BITS
	MOV	R4,R0
	BR	14$		;GO PRINT THE CHARACTER
6$:	CMP	R2,#6		;SPECIAL CODE?
	BLT	9$		;YES, SPACE, WORD, OR SHIFT
	CMP	R4,#2		;MIGHT ALSO BE SPECIAL IF IN CS 2
	BNE	8$		;BUT WE'RE NOT
	CMP	R2,#7		;CRLF?
	BEQ	7$		;YES
	BGT	8$		;NO, NOT ASCII MODE, EITHER?
	INC	R4		;YES IT IS, SWITCH TO ASCII MODE
	BR	16$		;AND GO GET NEXT BYTE
7$:	JSR	PC,NEWLIN	;CRLF REQUESTED, DO A NEWLINE
	BR	15$
8$:	MOV	R4,R1		;NORMAL CHARACTER, GET CS
	MUL	#26.,R1		;CALCULATE OFFSET FOR THIS CS
	ADD	R2,R1		;ADD IN CHARACTER OFFSET (+6)
	MOVB	ZCHRS-6(R1),R0	;GET THE CHARACTER FROM CONVERSION VECTOR
	BR	14$		;GO PRINT IT
9$:	TST	R2		;IS IT A SPACE?
	BNE	10$		;NO
	MOV	#40,R0		;YES, GO PRINT A SPACE
	BR	14$
10$:	CMP	R2,#3		;IS IT A WORD?
	BGT	11$		;NO, MUST BE A SHIFT
	BIS	#100000,R4	;SWITCH TO WORD MODE FOR NEXT BYTE
	DEC	R2		;CALCULATE WORD-TABLE BLOCK OFFSET
	ASH	#6,R2		;64 BYTES IN A BLOCK
	MOV	R2,WRDOFF	;SAVE IT AND LOOP
	BR	16$
11$:	SUB	#3,R2		;CALCULATE NEW CS
	TST	R4		;TEMPORARY SHIFT (FROM CS 0)?
	BNE	12$		;NO
	MOV	R2,R4		;YES, JUST SAVE NEW TEMP CS
	BR	16$
12$:	CMP	R2,R4		;IS THIS THE CURRENT CS?
	BEQ	13$		;YES, DO A PERM SHIFT TO IT
	CLR	R4		;OTHERWISE, PERM SHIFT TO CS 0
13$:	MOV	R4,R5		;TEMP & PERM CS'S ARE SAME NOW
	BR	16$
14$:	JSR	PC,@CHRFUN	;PRINT THE CHARACTER
15$:	MOV	R5,R4		;RESET TEMP CS TO PERM CS
16$:	SOB	R3,3$		;NEXT BYTE
	RESTOR	210		;RESTORE POINTERS & ORIGINAL STRING WORD
	TST	R2		;END-OF-STRING?
	BGE	1$		;NO, GET NEXT WORD
	RESTOR	5432		;YES, CLEAN UP & RETURN UPDATED POINTER
	RTS	PC

	;GIVEN AN ASCII CHARACTER IN R0, RETURN THE CHARACTER SET # IN R0
CHRCS::	TST	R0		;IS THIS A NULL?
	BNE	1$		;NO
	MOV	#3,R0		;YES, RETURN DUMMY CS NUMBER
	RTS	PC
1$:	SAVE	1
	MOV	#ZCHRS,R1	;POINT TO CONVERSION VECTOR
2$:	CMPB	R0,(R1)+	;FOUND THE CHARACTER?
	BEQ	3$		;YES
	TSTB	(R1)		;NO, END OF STRING?
	BNE	2$		;NO, CONTINUE LOOP
	MOV	#2,R0		;YES, CALL IT CS 2
	BR	5$
3$:	SUB	#ZCHRS,R1	;FIND CHARACTER POSITION
	CLR	R0		;START WITH CS 0
4$:	SUB	#26.,R1		;EVERY 26 CHARACTERS IS A NEW CS
	BLE	5$		;DONE
	INC	R0		;INCREMENT CS # & CONTINUE LOOP
	BR	4$
5$:	RESTOR	1
	RTS	PC

	;GIVEN AN ASCII CHARACTER IN R0, RETURN ZSTR BYTE VALUE IN R0
CHRBYT::SAVE	1
	MOV	#ZCHRS,R1	;POINT TO CHARACTER CONVERSION TABLE
1$:	CMPB	R0,(R1)+	;FOUND THE CHARACTER?
	BEQ	2$		;YES
	TSTB	(R1)		;NO, END OF STRING?
	BNE	1$		;NO, CONTINUE LOOP
	CLR	R0		;YES, RETURN ZERO FOR FAILURE
	BR	4$
2$:	SUB	#ZCHRS-5,R1	;ADJUST POINTER SO FIRST CHARACTER IS 6
	MOV	R1,R0
3$:	CMP	R0,#32.		;SUBTRACT MULTIPLES OF 26 UNTIL BASE CODE
	BLT	4$
	SUB	#26.,R0
	BR	3$
4$:	RESTOR	1
	RTS	PC

	;CONVERT UP TO 6 ASCIZ CHARS POINTED TO BY R0
	;TO A 2-WORD ZSTR RETURNED IN R0 & R1
ZWORD::	SAVE	2345
	MOV	R0,R2		;CHARACTER STRING POINTER
	CLR	R5		;CS STARTS AT 0
	MOV	#6,R3		;MAKE 6 ZSTR BYTES
1$:	MOVB	(R2)+,R1	;GET NEXT CHARACTER
	BNE	3$		;NOT END-OF-STRING
	MOV	#PADCHR,R0	;AT END-OF-STRING, PAD WITH PAD CHARACTER
2$:	SAVE	0		;SAVE A PAD BYTE
	SOB	R3,2$		;LOOP UNTIL DONE
	BR	6$		;THEN GO FORM ZWORD
3$:	MOV	R1,R0
	JSR	PC,CHRCS	;FIND THE CS NUMBER FOR THIS CHAR
	TST	R0		;CS 0?
	BEQ	4$		;YES
	ADD	#3,R0		;NO, CALCULATE TEMP SHIFT BYTE
	SAVE	0		;SAVE THE SHIFT BYTE
	DEC	R3		;REDUCE BYTE COUNT
	BEQ	6$		;DONE
4$:	MOV	R1,R0		;FIND THE PROPER BYTE VALUE FOR THIS CHAR
	JSR	PC,CHRBYT
	TST	R0		;IN NORMAL CS'S?
	BNE	5$		;YES
	MOV	#6,R0		;NO, USE ASCII SHIFT
	SAVE	0
	DEC	R3		;DONE YET?
	BEQ	6$		;YES
	MOV	R1,R0		;NO, SAVE HIGH-ORDER ASCII BITS
	ASH	#-5,R0
	SAVE	0
	DEC	R3		;DONE YET?
	BEQ	6$		;YES
	BIC	#^C37,R1	;NO, SAVE LOW-ORDER ASCII BITS
	MOV	R1,R0
5$:	SAVE	0		;SAVE THIS BYTE
	SOB	R3,1$		;LOOP UNTIL ZWORD FULL
6$:	MOV	12(SP),R0	;BUILD ZWORD WORDS FROM 6 SAVED BYTES
	ASH	#5,R0
	BIS	10(SP),R0
	ASH	#5,R0
	BIS	6(SP),R0
	MOV	4(SP),R1
	ASH	#5,R1
	BIS	2(SP),R1
	ASH	#5,R1
	BIS	(SP),R1
	BIS	#100000,R1	;SET END-OF-STRING BIT IN SECOND WORD
	ADD	#14,SP		;FLUSH STACK
	RESTOR	5432
	RTS	PC
	.SBTTL	TERMINAL I/O


	;QUEUE CHARACTER IN R0 FOR OUTPUT
	DEFVAR	OUTBUF		;POINTS TO OUTPUT BUFFER
	DEFVAR	CHRPTR		;POINTS TO NEXT CHARACTER POSITION
	DEFVAR	ENDBUF		;POINTS JUST PAST END OF OUTPUT BUFFER (0)
PUTCHR::CMP	CHRPTR,ENDBUF	;END OF BUFFER?
	BNE	7$		;NO
	SAVE	012		;YES, ENTER OUTPUT ROUTINE
	MOV	ENDBUF,R1	;END OF BUFFER
	MOV	OUTBUF,R2	;BEGINNING OF BUFFER
1$:	CMPB	-(R1),#40	;SEARCH FOR SPACE BACKWARDS FROM END
	BEQ	3$
	CMP	R1,R2		;STOP AT BEGINNING OF BUFFER
	BNE	1$
2$:	JSR	PC,LINOUT	;NO SPACES, OUTPUT WHOLE LINE
	MOV	R2,CHRPTR	;RESTORE POINTER TO BEGINNING OF BUFFER
	CMP	4(SP),#40	;DID A SPACE CAUSE BUFFER OVERFLOW?
	BNE	6$		;NO
	CLR	4(SP)		;YES, FLUSH IT
	BR	6$		;AND RETURN
3$:	CMP	R1,R2		;DEGENERATE CASE WITH SPACE AT OUTBUF?
	BEQ	2$		;YES, OUTPUT WHOLE LINE
	CLRB	(R1)		;NO, OUTPUT UP TO SPACE
	JSR	PC,LINOUT
	MOV	ENDBUF,R0	;END OF BUFFER
	INC	R1		;START GETTING CHARACTERS AFTER THE SPACE
4$:	CMP	R1,R0		;AT END YET?
	BEQ	5$		;YES
	MOVB	(R1)+,(R2)+	;NO, COPY NEXT CHARACTER TO BEGINNING OF BUF
	BR	4$		;AND CONTINUE
5$:	MOV	R2,CHRPTR	;NEXT CHAR WILL GO AFTER COPIED STUFF
6$:	RESTOR	210		;CLEAN UP
	BEQ	8$		;AND IGNORE A NULL CHARACTER
7$:	MOVB	R0,@CHRPTR	;NOW STORE THE CHARACTER IN BUFFER
	INC	CHRPTR		;UPDATE POINTER
8$:	RTS	PC		;AND RETURN

	;GO TO NEW LINE, OUTPUTTING CURRENT BUFFER
NEWLIN::CLRB	@CHRPTR		;END LINE AT CURRENT POINT
	MOV	OUTBUF,CHRPTR	;RESET CHARACTER POINTER
	JMP	LINOUT		;AND OUTPUT LINE

	;INPUT A CHARACTER FROM TERMINAL OR COMMAND FILE
GETCHR::TST	CMDBUF		;COMMAND FILE OPEN?
	BNE	1$		;YES
	JSR	PC,INCHR	;NO, GET CHARACTER FROM TERMINAL
	BR	4$
1$:	CMP	CMDPTR,CMDEND	;END OF BLOCK?
	BNE	2$		;NO
	JSR	PC,GETCBK	;YES, GET NEXT ONE
	BR	GETCHR		;AND START AGAIN
2$:	MOVB	@CMDPTR,R0	;GET NEXT CHARACTER
	BNE	3$		;NOT NULL
	INC	CMDPTR		;NULL, SKIP IT
	BR	1$
3$:	INC	CMDPTR		;OTHERWISE, INC POINTER AND RETURN
	JSR	PC,OUTCHR	;AND ECHO CHARACTER
	CMP	R0,#EOLCHR	;END-OF-LINE FROM COMMAND FILE
	BNE	4$		;NO
	SAVE	0
	JSR	PC,NXTLIN	;YES, CHECK FOR END-OF-PAGE
	RESTOR	0
4$:	TST	SCRIPT		;SCRIPT?
	BNE	SCRCHR		;YES, QUEUE CHARACTER FOR SCRIPTING
	RTS	PC		;NO, JUST RETURN

	;QUEUE A CHARACTER IN R0 FOR SCRIPTING AND RETURN IT
SCRCHR::MOVB	R0,@SCRPTR	;QUEUE IT
	INC	SCRPTR		;UPDATE POINTER
	CMP	SCRPTR,SCREND	;END OF BUFFER?
	BNE	1$		;NO
	SAVE	0		;DON'T LOSE CHARACTER
	JSR	PC,PUTPBK	;OUTPUT THE PRINT FILE BLOCK
	RESTOR	0		;RETRIEVE CHARACTER
1$:	RTS	PC		;AND RETURN IT

EOICHR=	15			;CARRIAGE RETURN IS NORMAL END OF INPUT

	;READ A NUMBER, RETURN IT IN R0, ALSO SET P$TERM IF ENDED WITH LF
GETNUM::SAVE	1
	CLR	R1		;ACCUMULATE NUMBER HERE
1$:	JSR	PC,INCHR	;GET THE NEXT CHARACTER
	CMP	R0,#'0		;IS IT A DIGIT?
	BLT	2$		;NO
	CMP	R0,#'9
	BGT	2$		;NO
	MUL	#10.,R1		;YES, DECIMAL SHIFT PREVIOUS NUMBER
	SUB	#'0,R0
	ADD	R0,R1		;AND ADD IN NEW DIGIT
	BR	1$		;LOOP
2$:	CMP	R0,#EOICHR	;IS THE CHARACTER A CARRIAGE RETURN?
	BEQ	3$		;YES
	MOV	#1,P$TERM	;NO, SET VT100 TERMINAL TYPE
	BR	4$
3$:	JSR	PC,INCHR	;GET REST OF LINE AND IGNORE IT
4$:	CMP	R0,#EOLCHR
	BNE	3$
	MOV	R1,R0		;RETURN NUMBER
	RESTOR	1
	RTS	PC

	;OUTPUT A NUMBER IN R0, RETURNS NUMBERS OF CHARACTERS USED
OUTNUM::SAVE	12
	CLR	R2		;COUNT CHARACTERS HERE
	MOV	R0,R1
	BGE	1$		;NEGATIVE?
	NEG	R1		;YES, POSITIVIZE IT
	MOV	#'-,R0		;PRINT A MINUS SIGN
	INC	R2
	JSR	PC,OUTCHR
1$:	MOV	#-1,-(SP)	;MARKER END-OF-LIST
2$:	CLR	R0
	DIV	#10.,R0		;EXTRACT NEXT DIGIT
	SAVE	1		;SAVE IT
	MOV	R0,R1
	BNE	2$		;LOOP UNTIL ZERO QUOTIENT
3$:	RESTOR	0		;GET NEXT DIGIT
	BLT	4$		;STOP WHEN MARKER REACHED
	ADD	#'0,R0		;PRINT IT
	JSR	PC,OUTCHR
	INC	R2
	BR	3$		;LOOP THROUGH ALL DIGITS
4$:	MOV	R2,R0		;RETURN NUMBER OF CHARACTERS PRINTED
	RESTOR	21
	RTS	PC

	;RAD50 CONVERSION TABLE
	.PSECT	STRING
R50TAB::.ASCII	<0>/ABCDEFGHIJKLMNOPQRSTUVWXYZ$.%0123456789/
	.PSECT	CODE

	;OUTPUT A RAD50 NUMBER IN R0
OUTR50::SAVE	1
	MOV	R0,R1
	CLR	R0
	DIV	#50,R0		;EXTRACT LAST CHARACTER
	SAVE	1
	MOV	R0,R1
	CLR	R0
	DIV	#50,R0		;SEPARATE FIRST TWO CHARACTERS
	JSR	PC,1$		;PRINT FIRST ONE
	MOV	R1,R0
	JSR	PC,1$		;AND SECOND ONE
	RESTOR	01		;FALL THROUGH TO PRINT THIRD
1$:	MOVB	R50TAB(R0),R0	;GET THE ASCII EQUIVALENT
	BEQ	2$		;IGNORE SPACES (ZERO IN TABLE)
	JSR	PC,OUTCHR	;PRINT THE CHARACTER
2$:	RTS	PC		;AND RETURN
	.SBTTL	OPERATION TABLES


	.PSECT	DATA

	;ZERO ARGUMENT OPERATIONS
ZEROOP::OPRTRU			;176
	OPRFAL			;177
	OPPRNI			;178
	OPPRNR			;179
	OPNOOP			;180
	OPSAVE			;181
	OPREST			;182
	OPRSTT			;183
	OPRSTA			;184
	OPFSTA			;185
	OPQUIT			;186
	OPCRLF			;187
	OPUSL			;188
	OPVERI			;189
	0			;190
	0			;191

	;ONE ARGUMENT OPERATIONS
ONEOP::	OPQZER			;128
	OPQNEX			;129
	OPQFIR			;130
	OPLOC			;131
	OPPTSI			;132
	OPINC			;133
	OPDEC			;134
	OPPRNB			;135
	0			;136
	OPREMO			;137
	OPPRND			;138
	OPRETU			;139
	OPJUMP			;140
	OPPRIN			;141
	OPVALU			;142
	OPBCOM			;143

	;TWO ARGUMENT AND EXTENDED ARGUMENT OPERATIONS
EXTOP::	0			;0
	OPQEQU			;1
	OPQLES			;2
	OPQGRT			;3
	OPQDLE			;4
	OPQIGR			;5
	OPQIN			;6
	OPBTST			;7
	OPBOR			;8
	OPBAND			;9
	OPQFSE			;10
	OPFSET			;11
	OPFCLE			;12
	OPSET			;13
	OPMOVE			;14
	OPGET			;15
	OPGETB			;16
	OPGETP			;17
	OPGTPT			;18
	OPNEXT			;19
	OPADD			;20
	OPSUB			;21
	OPMUL			;22
	OPDIV			;23
	OPMOD			;24
.REPT	7
	0			;25-31
.ENDR
	OPCALL			;224
	OPPUT			;225
	OPPUTB			;226
	OPPUTP			;227
	OPREAD			;228
	OPPRNC			;229
	OPPRNN			;230
	OPRAND			;231
	OPPUSH			;232
	OPPOP			;233
.REPT	22.
	0			;234-255
.ENDR

	.PSECT	CODE
	.SBTTL	TOP LEVEL STUFF


PVERS1=	0			;POSITION OF ZVERSION VERSION BYTE
PVERS2=	1			;ZVERSION MODE BYTE
PZRKID=	2			;ZORKID
PENDLD=	4			;ENDLOD
PSTART=	6			;START
PVOCTB=	10			;VOCAB
POBJTB=	12			;OBJECT
PGLOTB=	14			;GLOBALS
PPURBT=	16			;PURBOT
PFLAGS=	20			;USER FLAG WORD
PSERNM=	22			;SERIAL NUMBER (6 BYTES)
PWRDTB=	30			;WORDS
PLENTH=	32			;LENGTH (IN WORDS)
PCHKSM=	34			;CHECKSUM (ALL BYTES STARTING AT 100 OCTAL)
LSTACK=	1000			;LENGTH OF USER STACK (MUST BE 1 PAGE FOR NOW)
LMOUTB=	132.			;MAX LENGTH OF OUTBUF, EXCLUDING TERMINAL 0
LDOUTB=	80.			;DEFAULT LENGTH OF OUTBUF
LPAGES=	140			;MAX NUMBER OF PAGES EXPECTED
LXBYTS=	LSTACK+LMOUTB+<4*LPAGES>+2000 ;LENGTH OF EXTRA BYTES NEEDED

	.PSECT	STRING
	.NLIST	BEX
IRBRKS::.ASCIZ	<40><11><15><14>/.,?/ ;INITIAL SET OF READ BREAK CHARS
	.LIST	BEX
	.PSECT	CODE


	;INITIALIZATION
	.ENABL	LSB
START::	DEFVAR	TOPSP		;TOP LEVEL STACK POINTER
	MOV	SP,TOPSP	;SAVE FOR LATER
	JSR	PC,SYSINI	;DO ANY SYSTEM INITIALIZATION
	MOV	P$LINE,R0	;CHECK FOR LINE LENGTH
	BNE	1$		;GOT IT ALREADY
	PRIN1	<Line width (default is 80, end with LF for status line): >
	JSR	PC,GETNUM	;GET IT
	TST	R0		;USE DEFAULT?
	BNE	1$		;NO
	MOV	#LDOUTB,R0	;YES, INSERT THAT
1$:	CMP	R0,#LMOUTB	;NUMBER HIGHER THAN MAX ALLOWED?
	BLOS	2$		;NO
	MOV	#LMOUTB,R0	;YES, USE MAX INSTEAD
2$:	DEFVAR	TWIDTH		;TERMINAL WIDTH
	MOV	R0,TWIDTH	;SAVE IT

3$:	JSR	PC,GETMEM	;GET ALL THE MEMORY WE CAN
	CMP	R0,#BUFFER+1000	;IS THERE ENOUGH FOR FIRST PAGE?
	BHI	5$		;YES
4$:	FATAL	<Insufficient memory> ;NO, DIE
5$:	DEFVAR	MEMTOP		;LAST AVAILABLE LOCATION
	MOV	R0,MEMTOP
	JSR	PC,OPNGAM	;OPEN GAME FILE
	CLR	R0		;BLOCK 0
	MOV	#BUFFER,R1	;PUT AT BEGINNING OF BUFFER
	JSR	PC,GETBLK	;GET THE BLOCK
	CMPB	BUFFER+PVERS1,#ZMVERS ;PROPER Z-MACHINE VERSION?
	BNE	6$		;NO
	BITB	#1,BUFFER+PVERS2 ;YES, PROPER MODE BITS?
	BEQ	7$		;YES
6$:	FATAL	<Wrong game version> ;SOMETHING WRONG, DIE
7$:	TST	P$TERM		;STATUS LINE REQUESTED?
	BNE	8$		;YES
	BISB	#20,BUFFER+PVERS2 ;NO, SET NO-STATUS-LINE BIT
	BR	10$
8$:	JSR	PC,SETERM	;SET UP TERMINAL TABLE FOR PROPER TYPE
	MOV	TRMINI,R0	;BEGIN TO SET UP STATUS LINE
	JSR	PC,OUTSTR
	DEFVAR	TIMEMD		;TIME-(VERSUS SCORE)-MODE-FOR-STATUS-LINE FLAG
	MOV	TRMINS,R0	;GET STRING FOR SCORE (INITIAL ASSUMPTION)
	BITB	#2,BUFFER+PVERS2 ;TIME MODE REQUESTED?
	BEQ	9$		;NO
	INC	TIMEMD		;YES, SET TIME-MODE FLAG
	MOV	TRMINT,R0	;& USE TIME STRING INSTEAD
9$:	JSR	PC,OUTSTR	;DISPLAY IT, NOW
10$:	DEFVAR	ZORKID		;UNIQUE GAME & VERSION IDENTIFIER
	MOV	#BUFFER+PZRKID,R0
	JSR	PC,GTAWRD
	MOV	R0,ZORKID
	MOV	#BUFFER+PENDLD,R0 ;GET ENDLOD POINTER
	JSR	PC,GTAWRD
	BIT	#777,R0		;ROUND UP TO NEXT BLOCK
	BEQ	11$
	BIC	#777,R0
	ADD	#1000,R0
11$:	MOV	R0,R2
	ADD	#BUFFER+LXBYTS,R0 ;CALCULATE MINIMUM TOP OF MEMORY NEEDED
	CMP	R0,MEMTOP
	BHI	4$		;NOT ENOUGH MEMORY, DIE
	ASH	#-9.,R2		;EXTRACT ENDLOD BLOCK
	DEFVAR	ENDLOD		;ENDLOD BLOCK NUMBER
	MOV	R2,ENDLOD	;SAVE IT
	DEC	R2		;NUMBER OF BLOCKS LEFT TO LOAD
	MOV	#1,R0		;STARTING WITH BLOCK 1
	MOV	#BUFFER+1000,R1	;LOCATION TO PUT THEM
	JSR	PC,GTBLKS	;GET THE BLOCKS
	MOV	#BUFFER+PVOCTB,R0 ;VOCAB LOCATION
	JSR	PC,GTAWRD	;GET IT
	ADD	#BUFFER,R0	;ABSOLUTIZE IT
	DEFVAR	VOCTAB		;SAVE VOCABULARY TABLE POINTER
	MOV	R0,VOCTAB
	MOV	#BUFFER+POBJTB,R0 ;GET OBJECT TABLE POINTER
	JSR	PC,GTAWRD
	ADD	#BUFFER,R0
	DEFVAR	OBJTAB
	MOV	R0,OBJTAB
	MOV	#BUFFER+PGLOTB,R0 ;GET GLOBAL TABLE POINTER
	JSR	PC,GTAWRD
	ADD	#BUFFER,R0
	DEFVAR	GLOTAB
	MOV	R0,GLOTAB
	MOV	#BUFFER+PWRDTB,R0 ;GET WORD TABLE POINTER
	JSR	PC,GTAWRD
	ADD	#BUFFER,R0
	DEFVAR	WRDTAB
	MOV	R0,WRDTAB
	MOV	#BUFFER+PPURBT,R0 ;GET PURE CODE POINTER
	JSR	PC,GTAWRD
	BIT	#777,R0		;ROUND UP TO NEXT BLOCK
	BEQ	12$
	ADD	#1000,R0
12$:	ASH	#-9.,R0		;EXTRACT BLOCK NUMBER
	BIC	#^C177,R0	;CLEAR UNWANTED BITS
	DEFVAR	PURBOT
	MOV	R0,PURBOT	;SAVE IT
	MOV	ENDLOD,R5	;CALCULATE BEGINNING OF FREE MEMORY
	ASH	#9.,R5
	ADD	#BUFFER,R5
	DEFVAR	STKBOT		;BOTTOM OF STACK
	MOV	R5,STKBOT	;IS HERE
	ADD	#LSTACK,R5	;ADD LENGTH OF USER STACK & INIT USER SP
	MOV	R5,OUTBUF	;ALSO START OF OUTPUT BUFFER
	MOV	R5,R1
	ADD	TWIDTH,R1	;ADD LENGTH OF BUFFER
	MOV	R1,ENDBUF	;THIS IS ENDBUF POINTER
	CLRB	(R1)+		;BUFFER IS FOLLOWED BY A 0 FOR CONVENIENCE
	DEFVAR	RBRKS		;POINTER TO STRING OF READ BREAK CHARACTERS
	DEFVAR	ESIBKS		;END OF SELF-INSERTING BREAK CHARACTERS
	MOV	R1,RBRKS	;STRING STARTS HERE
	MOV	VOCTAB,R2
	MOVB	(R2)+,R0	;FIRST BYTE IN VOCTAB IS NUMBER OF SIBREAKS
13$:	MOVB	(R2)+,(R1)+	;TRANSFER THEM
	SOB	R0,13$
	MOV	R1,ESIBKS	;REMEMBER END OF SI BREAKS
	MOV	#IRBRKS,R3	;ALWAYS END WITH INITIAL BREAK CHARACTERS
14$:	MOVB	(R3)+,(R1)+
	BNE	14$
	DEFVAR	VWLEN		;NUMBER OF BYTES IN A VOCABULARY WORD ENTRY
	MOVB	(R2)+,VWLEN	;BYTE FOLLOWS SIBREAKS
	MOV	R2,R0
	JSR	PC,GTAWRD	;GET NEXT WORD IN TABLE
	DEFVAR	VWORDS		;IT'S THE NUMBER OF WORD ENTRIES IN VOCABULARY
	MOV	R0,VWORDS
	ADD	#2,R2		;MOVE TO NEXT WORD
	DEFVAR	VOCBEG		;THIS IS BEGINNING OF ACTUAL VOCABULARY
	MOV	R2,VOCBEG
	BIT	#1,R1		;MAKE SURE PAGES START ON WORD BOUNDARY
	BEQ	15$
	INC	R1
15$:	DEFVAR	PAGTAB		;PAGE INFORMATION TABLE
	MOV	R1,PAGTAB	;STARTS HERE
	MOV	R1,R2
	NEG	R2		;CALCULATE NUMBER OF PAGES AVAILABLE
	ADD	MEMTOP,R2
	ASH	#-9.,R2
	BIC	#^C177,R2
	MOV	R2,BUFPGS	;SAVE NUMBER OF PAGES FOR EXTERNAL REFERENCE
	ASL	R2		;CALCULATE NUMBER OF 4-BYTE TABLE ENTRIES
	INC	R2		;PLUS ONE WORD FOR END-OF-TABLE MARKER
	ASL	R2
	ADD	R1,R2		;ADD TO TABLE POINTER
	DEFVAR	PAGES		;PAGES THEMSELVES START AFTER TABLE
	MOV	R2,PAGES
	NEG	R2		;RECALCULATE NUMBER OF PAGES (MAY BE ONE LESS)
	ADD	MEMTOP,R2
	ASH	#-9.,R2
	BIC	#^C177,R2
	ASL	R2		;FIND END OF TABLE
	ASL	R2
	ADD	R1,R2
	MOV	#-1,(R2)	;SET MARKER
16$:	MOV	#376,(R1)+	;INITIALIZE TABLE
	CLR	(R1)+
	CMP	R1,R2
	BNE	16$
	JSR	PC,GETIME	;GET THE CURRENT TIME-OF-DAY
	MOV	TIME+2,RSEED	;USE IT TO INITIALIZE RANDOM NUMBER SEED
	BR	START1
	.DSABL	LSB

	;RESTART EXECUTION HERE
RESTRT::CLR	R0		;REREAD ALL OF THE IMPURE STUFF
	MOV	#BUFFER,R1
	MOV	PURBOT,R2
	JSR	PC,GTBLKS
START1:	MOV	TOPSP,SP	;INITIALIZE OUR STACK POINTER
	MOV	OUTBUF,R5	;INITIALIZE USER STACK POINTER
	MOV	OUTBUF,CHRPTR	;INITIALIZE OUTPUT CHARACTER POINTER
	DEFVAR	ZLOCS		;POINTER TO LOCALS
	MOV	R5,ZLOCS	;THEY WOULD START AT FIRST SLOT,
	SUB	#2,ZLOCS	;IF THERE WERE ANY
	MOV	#BUFFER+PSTART,R0 ;GET STARTING LOCATION
	JSR	PC,GTAWRD
	JSR	PC,BSPLTB	;SPLIT BLOCK & BYTE POINTERS
	DEFVAR	ZPC1		;ZPC BLOCK-POINTER
	DEFVAR	ZPC2		;ZPC BYTE-POINTER
	MOV	R0,ZPC1		;INITIALIZE THEM
	MOV	R1,ZPC2
	JSR	PC,NEWZPC	;GET PAGE TO EXECUTE
	
	;MAIN INSTRUCTION INTERPRETATION LOOP
	.ENABL	LSB
NXTINS::JSR	PC,NXTBYT	;GET THE OPERATION BYTE
	MOV	R0,R3		;SAVE A COPY
	CMP	R0,#200		;IS IT A 2OP?
	BLT	9$		;YES
	CMP	R0,#260		;NO, IS IT A 1OP?
	BLT	12$		;YES
	CMP	R0,#300		;NO, IS IT A 0OP?
	BLT	13$		;YES
	BIC	#^C77,R0	;NO, IT'S EXTENDED, GET THE OPCODE
	ASL	R0		;MAKE IT A WORD OFFSET
	MOV	EXTOP(R0),R4	;GET THE OPERATOR POINTER
	BEQ	14$		;NO SUCH OPERATION
	JSR	PC,NXTBYT	;GET THE ARGUMENT BYTE
	MOV	#4,R2		;SPLIT IT INTO 4 2-BIT MODE BYTES
1$:	SAVE	0
	ASR	R0
	ASR	R0
	SOB	R2,1$
	MOV	#4,R3		;RETRIEVE THE 4 BYTES IN PROPER ORDER
	DEFVAR	ARGBLK,<.BLKW 5> ;ARGUMENT BLOCK FOR EXTENDED OPERATIONS
	MOV	#ARGBLK+2,R1	;FIRST ARGUMENT SLOT
2$:	RESTOR	0		;GET NEXT MODE BYTE?
	BIC	#^C3,R0		;CLEAR OFF UNWANTED BITS
	CMP	R0,#3		;NO MORE ARGUMENTS?
	BEQ	4$		;YES, FLUSH ANY OTHER MODE BYTES
	JSR	PC,GETARG	;ELSE, GET THE NEXT ARGUMENT
	MOV	R0,(R1)+	;SAVE IT IN ARGUMENT BLOCK
	INC	R2		;REMEMBER NUMBER OF ARGS GOTTEN
3$:	SOB	R3,2$		;LOOP FOR REST OF MODE BYTES
	BR	5$
4$:	DEC	R3		;DETERMINE NUMBER OF REMAINING MODE BYTES
	ASL	R3		;WORD COUNT
	ADD	R3,SP		;FLUSH THEM
5$:	MOV	#ARGBLK,R0	;POINTER GOES HERE FOR OPERATOR TO USE
	MOV	R2,(R0)		;SAVE NUMBER OF ARGS TO BE PASSED
	CMP	(R4),#NOP	;DOES OPERATOR WANT ARGBLK POINTER?
	BEQ	15$		;YES, CALL OPERATOR NOW
	DEC	R2		;NO, IT WANTS ARGS IN REGISTERS
	BLT	15$		;NO ARGS, JUST CALL OPERATOR
	BEQ	8$		;1 ARG, GET IT
	SUB	#2,R2
	BLT	7$		;2 ARGS
	BEQ	6$		;3 ARGS
	MOV	ARGBLK+10,R3	;ELSE, 4 ARGS, GET 4TH
6$:	MOV	ARGBLK+6,R2	;GET 3RD
7$:	MOV	ARGBLK+4,R1	;GET 2ND
8$:	MOV	ARGBLK+2,R0	;GET FIRST ARG
	BR	15$		;AND CALL OPERATOR
9$:	BIC	#^C37,R0	;2OP, EXTRACT OPERATION BITS
	ASL	R0		;MAKE IT A WORD OFFSET
	MOV	EXTOP(R0),R4	;FIND POINTER TO OPERATOR ROUTINE
	BEQ	14$		;NO SUCH OPERATION
	MOV	#1,R0		;ASSUME FIRST ARG IS AN IMMEDIATE
	BIT	#100,R3		;IS IT INSTEAD A VARIABLE?
	BEQ	10$		;NO
	INC	R0		;YES, CHANGE MODE
10$:	JSR	PC,GETARG	;GET THE FIRST ARG
	SAVE	0		;SAVE IT
	MOV	#1,R0		;ASSUME SECOND ARG IS AN IMMEDIATE
	BIT	#40,R3		;IS IT INSTEAD A VARIABLE?
	BEQ	11$		;NO
	INC	R0		;YES, CHANGE MODE
11$:	JSR	PC,GETARG	;GET THE SECOND ARG
	MOV	R0,R1		;POSITION IT
	RESTOR	0		;RECOVER FIRST ARG
	CMP	(R4),#NOP	;DOES ROUTINE WANT ARGUMENT BLOCK?
	BNE	15$		;NO, GO CALL IT
	MOV	#ARGBLK+6,R2	;YES, MOVE ARGS TO ARGBLK
	MOV	R1,-(R2)
	MOV	R0,-(R2)
	MOV	#2,-(R2)	;ALWAYS 2 ARGS
	MOV	R2,R0
	BR	15$		;NOW CALL OPERATOR
12$:	BIC	#^C17,R3	;1OP, EXTRACT OPERATION BITS
	ASL	R3		;MAKE IT A WORD OFFSET
	MOV	ONEOP(R3),R4	;GET OPERATOR ROUTINE POINTER
	BEQ	14$		;ILLEGAL OPERATION
.REPT	4			;EXTRACT MODE BITS
	ASR	R0
.ENDR
	BIC	#^C3,R0
	JSR	PC,GETARG	;GET THE ARGUMENT
	BR	15$		;AND CALL OPERATOR
13$:	BIC	#^C17,R0	;0OP, EXTRACT OPERATION BITS
	ASL	R0		;MAKE IT A WORD OFFSET
	MOV	ZEROOP(R0),R4	;GET OPERATOR ROUTINE POINTER
	BNE	15$		;IT'S A LEGAL OPERATION
14$:	FATAL	<Illegal operation> ;OTHERWISE, COMPLAIN
15$:	JSR	PC,(R4)		;CALL THE OPERATOR ROUTINE
	JMP	NXTINS		;AND LOOP FOR NEXT INSTRUCTION
	.DSABL	LSB
	.SBTTL	PAGING ROUTINES


	;NORMALIZE ZPC & GET PROPER PAGE
	DEFVAR	CURPAG		;CURRENT PAGE (WHERE ZPC IS) POINTER
	DEFVAR	CURBLK		;CURRENT BLOCK, USUALLY SAME AS ZPC1
	DEFVAR	CURTAB		;CURRENT PAGE TABLE POINTER +1
NEWZPC::SAVE	123
	CLR	R0		;USE DOUBLE-WORD ARITHMETIC
	MOV	ZPC1,R1		;GET BLOCK-POINTER
	SWAB	R1		;POSITION IT
	BIC	#377,R1
	ASL	R1
	ADC	R0
	MOV	ZPC2,R3		;GET BYTE-OFFSET
	SXT	R2		;DOUBLE-WORDIFY IT (MIGHT BE NEGATIVE)
	ADD	R3,R1		;ADD IT TO OTHER DOUBLE WORD
	ADC	R0
	ADD	R2,R0
	MOV	R1,R2
	BIC	#^C777,R2	;EXTRACT BYTE-OFFSET
	MOV	R2,ZPC2		;SAVE IT
	ASH	#-9.,R1		;EXTRACT BLOCK-POINTER
	BIC	#^C177,R1
	BIT	#1,R0		;TEST 17TH BIT
	BEQ	1$		;WAS 0
	BIS	#200,R1		;WAS 1, SET PROPER BIT IN BLOCK-POINTER
1$:	MOV	R1,ZPC1		;SAVE IT
	CMP	R1,CURBLK	;HAS IT CHANGED?
	BEQ	5$		;NO
	MOV	R1,CURBLK	;YES, REMEMBER NEW BLOCK
	MOV	CURTAB,R0	;IS OLD PAGE IN PAGING SPACE?
	BEQ	2$		;NO
	MOVB	RTIME1,(R0)+	;YES, STORE CURRENT REF TIME FOR OLD PAGE
	MOV	RTIME2,(R0)
2$:	CMP	R1,ENDLOD	;NEW PAGE ALREADY IN CORE?
	BLT	3$		;YES
	MOV	R1,R0		;NO, GET NEW PAGE
	JSR	PC,GETPAG
	MOV	R0,R1
	MOV	LPTAB,R0	;GET NEW PAGE TABLE POINTER
	INC	R0		;POINT TO REF SLOT
	MOV	R0,CURTAB	;SAVE THIS POINTER FOR LATER
	MOVB	#-1,(R0)+	;STORE HIGHEST RTIME TO KEEP PAGE FOR US
	MOV	#-1,(R0)
	BR	4$
3$:	ASH	#9.,R1		;CALCULATE PAGE ADDRESS
	ADD	#BUFFER,R1
	CLR	CURTAB		;CLEARING POINTER MEANS PAGE IS PRELOADED
4$:	MOV	R1,CURPAG	;UPDATE PAGE POINTER
5$:	RESTOR	321
	RTS	PC		;AND RETURN

	;GET THE PAGE WHOSE NUMBER IS IN R0, RETURN A POINTER TO IT IN R0
	DEFVAR	RTIME1		;REFERENCE TIME, 1 1/2 WORDS USED
	DEFVAR	RTIME2
	DEFVAR	LPAGE		;LAST REFERENCED PAGE NUMBER
	DEFVAR	LPLOC		;AND ITS CORE LOCATION
	DEFVAR	LPTAB		;AND ITS TABLE POINTER
GETPAG::CMP	R0,LPAGE	;IS THIS THE SAME PAGE AS LAST REFERENCED?
	BNE	1$		;NO
	MOV	LPLOC,R0	;YES, WE ALREADY HAVE LOCATION
	RTS	PC		;RETURN IT
1$:	MOV	R0,LPAGE	;SAVE NEW PAGE NUMBER
	SAVE	1
	ADD	#1,RTIME2	;UPDATE REFERENCE TIME (COUNT)
	ADC	RTIME1
	MOV	PAGTAB,R1	;PAGE INFORMATION TABLE
2$:	CMPB	R0,(R1)+	;SEARCH FOR DESIRED BLOCK
	BNE	4$		;NOT IT
	CMP	R0,CURBLK	;FOUND IT, BUT IS IT THE CURRENT CODE PAGE?
	BEQ	3$		;YES, DON'T TOUCH REFERENCE TIME
	MOVB	RTIME1,(R1)+	;NO, UPDATE ITS REFERENCE TIME
	MOV	RTIME2,(R1)+
	SUB	#3,R1		;BACKUP TO BEGINNING OF TABLE ENTRY
3$:	DEC	R1		;ONE MORE BYTE FOR GOOD MEASURE
	MOV	R1,LPTAB	;SAVE IT
	SUB	PAGTAB,R1	;CALCULATE ADDRESS OF PAGE
	ASH	#7,R1
	ADD	PAGES,R1
	BR	5$		;AND RETURN PAGE POINTER
4$:	ADD	#3,R1		;SKIP REFERENCE TIME
	CMP	(R1),#-1	;END OF TABLE?
	BNE	2$		;NO, CONTINUE SEARCH
	JSR	PC,FINDPG	;YES, FIND A PAGE TO LOAD INTO
	SAVE	0		;PAGE POINTER
	MOV	R1,LPTAB	;SAVE PAGE TABLE POINTER
	MOV	LPAGE,R0	;SAVE NEW BLOCK NUMBER
	MOVB	R0,(R1)+
	MOVB	RTIME1,(R1)+	;AND CURRENT REF TIME
	MOV	RTIME2,(R1)
	RESTOR	1		;PAGE POINTER
	JSR	PC,GETBLK	;GET THE BLOCK
5$:	MOV	R1,R0		;RETURN PAGE POINTER
	MOV	R0,LPLOC	;AND SAVE IT FOR LATER
	RESTOR	1
	RTS	PC

	;FIND A GOOD PAGE, RETURN PAGE POINTER IN R0 & PAGTAB POINTER IN R1
FINDPG::SAVE	23
	MOV	PAGTAB,R0
	MOV	#-1,R2		;FAKE BEST-CASE REFERENCE COUNT
	MOV	R2,R3
	INC	R0		;SKIP BLOCK NUMBER FOR NOW
1$:	CMPB	(R0)+,R2	;IS THIS REF TIME WORSE THAN CURRENT WORST?
	BHI	3$		;NO
	BLO	2$		;YES
	CMP	(R0),R3		;MAYBE, COMPARE LOW-ORDER WORDS, WORSE?
	BHIS	3$		;NO
2$:	MOVB	-1(R0),R2	;YES, SAVE ITS REF COUNT
	MOV	(R0),R3
	MOV	R0,R1		;AND LOCATION (+2)
3$:	TST	(R0)+		;SKIP SECOND WORD
	CMPB	(R0)+,#-1	;LOOP UNTIL END-OF-TABLE
	BNE	1$
	INC	R2		;WAS A PAGE REALLY FOUND?
	BEQ	4$		;NO, GROSS BUG!
	TST	-(R1)		;YES, CALCULATE CORE LOCATION OF PAGE
	MOV	R1,R0
	SUB	PAGTAB,R0
	ASH	#7,R0
	ADD	PAGES,R0
	RESTOR	32
	RTS	PC
4$:	FATAL	<No free pages>
	.SBTTL	TERMINAL-SPECIFIC STUFF


.MACRO	STRING	STR		;CREATE A STRING & POINT TO IT
	.SAVE
	.PSECT	STRING
	$$$=.
	.ASCII	STR
	.RESTOR
	.WORD	$$$
.ENDM	STRING


	.PSECT	STRING
NULSTR:	.ASCII	<200>		;NULL STRING

	.PSECT	DATA		;TABLES OF TERMINAL COMMAND STRINGS
	.NLIST	BEX

	;TABLE OF POINTERS FOR TERMINAL IN USE, OTHERS ARE FORMATTED SAME WAY
TRMINI:	.WORD	0		;INITIALIZE TERMINAL
TRMINS:	.WORD	0		;INITIALIZATION FOR SCORE LINE
TRMINT:	.WORD	0		;INITIALIZATION FOR TIME LINE
SAVPOS:	.WORD	0		;SAVE OLD POSITION & CHANGE ATTRIBUTES
SCRPOS:	.WORD	0		;GO TO SCORE POSITION
TIMPOS:	.WORD	0		;GO TO TIME POSITION
LOCPOS:	.WORD	0		;GO TO LOCATION POSITION
CLRROL:	.WORD	0		;CLEAR REST OF LINE
RETPOS:	.WORD	0		;RETURN TO OLD POSITION
TRMUNI:	.WORD	0		;UNINITIALIZATION STRING

	;VT100 TABLE (P$TERM=1)
VT100:	STRING	^"<15><233>/</<233>/[2;24r/<233>/[J/<233>/#6/<233>/[4m/<200>"
	STRING	^"\Score: \<233>/[m/<0>"
	STRING	^"\Time: \<233>/[m/<0>"
	STRING	^"<233>/7/<233>/[4m/<200>"
	STRING	^"<233>/[;8f/<200>"
	STRING	^"<233>/[;7f/<200>"
	STRING	^"/  /"
	STRING	^"<233>/[K/<200>"
	STRING	^"<233>/8/<15><200>"
	STRING	^"<233>/7/<233>/[r/<233>/8/<233>/[?2l/<0>"

	;VT52 TABLE (P$TERM=2)
VT52:	STRING	^"<233>/H/<233>/J/<233>/Y/<55.><32.><200>"
	NULSTR
	NULSTR
	NULSTR
	STRING	^"<233>/H/<233>/K/<233>/Y/<32.><91.>/Score:  /<200>"
	STRING	^"<233>/H/<233>/K/<233>/Y/<32.><91.>/Time:  /<200>"
	STRING	^"<15>/[/<200>"
	STRING	^"/]/<15><12><233>/K/<200>"
	STRING	^"<233>/Y/<55.><32.><200>"
	NULSTR

	.LIST	BEX
	.PSECT	CODE

	;SELECT PROPER TERMINAL TABLE
SETERM:	SAVE	12
	MOV	#TRMINI,R0
	MOV	#VT100,R1	;ASSUME VT100 FIRST
	CMP	P$TERM,#1	;CORRECT?
	BEQ	1$		;YES
	MOV	#VT52,R1	;NO, MUST BE A VT52
1$:	MOV	#<VT100-TRMINI>/2,R2 ;LENGTH OF TABLE
2$:	MOV	(R1)+,(R0)+	;TRANSFER PROPER TERMINAL TABLE TO GENERAL ONE
	SOB	R2,2$
	RESTOR	21
	MOV	P$TERM,LINES	;INITIALIZE LINE COUNT (WORKS FOR EITHER VT!)
	TST	P$TSXF		;TSX SETUP NEEDED?
	BEQ	3$		;NO
	MOV	#35,R0		;YES, SELECT TSX SINGLE-CHAR MODE
	JSR	PC,OUTCHR
	MOV	#'S,R0
	JSR	PC,OUTCHR
3$:	RTS	PC
	.SBTTL	RT-11 DEPENDENT STUFF

.IF	NE	RT11		;USE THIS CODE ONLY FOR RT-11

	.MCALL	.PRINT,.TTYOUT,.TTYIN ;TERMINAL-RELATED CALLS
	.MCALL	.CSISPC,.LOOKUP,.READW,.ENTER ;FILE STUFF
	.MCALL	.WRITW,.CLOSE,.PURGE,.DELETE,.WRITE,.WAIT ;MORE FILE STUFF
	.MCALL	.DSTATUS,.SETTOP,.GTIM,.EXIT,.SERR,.QSET,.LOCK,.UNLOCK ;OTHER


GMCHAN=	5			;GAME FILE CHANNEL NUMBER
SVCHAN=	2			;SAVE FILE
PFCHAN=	3			;PRINT FILE FOR SCRIPTING
CMCHAN=	4			;COMMAND FILE
ERRBYT=	52			;LOCATION OF ERROR BYTE


	.ASECT

	.=44			;JOB STATUS WORD
	.WORD	40000		;ENABLE LOWERCASE INPUT
	.WORD	BUFFER		;SWAP USR OVER BEGINNING OF BUFFER

	.=56			;RSTS/E & TSX MEMORY REQUIREMENT
	.WORD	34		;ASK FOR 28K WORDS

	.=400			;EXTERNAL REFERENCE INFORMATION
	.WORD	BUFPGS		;POINT TO WORD FOR NUMBER OF BUFFER PAGES
	.ASCII	/Copyright (C) 1982, 1983 Infocom, Inc./ ;COPYRIGHT MESSAGE
	.EVEN

	.PSECT	PARAM		;USER-SUPPLIED PARAMETERS

P$TERM::.WORD	0		;TERMINAL TYPE
P$LINE::.WORD	0		;NUMBER OF CHARACTERS ON A LINE, 0 MEANS ASK
P$PAGE::.WORD	0		;LINES PER PAGE
P$TSXF::.WORD	0		;NON-ZERO TO SET TSX SINGLE-CHAR MODE
	.BLKW	9.		;FUTURE EXPANSION ROOM
	;THE FOLLOWING ARE FOR INFOCOM USE ONLY
P$RAND::.WORD	0		;NON-ZERO TO DISABLE RANDOMNESS
P$GAME::.WORD	0,0		;GAME NAME (IN RAD50)


	.PSECT	DATA

BUFPGS::.WORD	0		;NUMBER OF BUFFER PAGES

	.PSECT	CODE

	;SYSTEM INITIALIZATION STUFF
	DEFVAR	QENTRY,<.BLKW 10.> ;ALLOW ROOM FOR XM MONITOR ELEMENT
SYSINI::.QSET	#QENTRY,#1	;ALLOCATE AN EXTRA QUEUE ELEMENT
	.SERR			;TRAP ALL I/O ERRORS
	RTS	PC

	;TEST FOR SCRIPTING & UPDATE FLAGS APPROPRIATELY
	.ENABL	LSB
	DEFVAR	PFNAME,<.RAD50 /LP ZIP   LST/> ;DEFAULT PRINT FILE NAME
	DEFVAR	SCRIPT		;SCRIPT FLAG
	DEFVAR	PFOPEN		;PRINT FILE OPEN?
	DEFVAR	PFLOST		;PRINT FILE LOST AT SOME POINT?
	DEFVAR	SCRBUF		;CURRENT SCRIPT BUFFER
	DEFVAR	SCREND		;END OF BUFFER
	DEFVAR	SCRPTR		;CHARACTER POINTER
	DEFVAR	SCRBF1		;FIRST SCRIPT BUFFER
	DEFVAR	SCRBF2		;SECOND SCRIPT BUFFER
	DEFVAR	PFBLK		;PRINT FILE BLOCK
TSTSCR::TST	PFLOST		;HAVE WE PREVIOUSLY LOST WITH PRINT FILE?
	BNE	2$		;YES, DON'T TRY AGAIN
	MOV	#BUFFER+PFLAGS,R0 ;GET FLAG WORD
	JSR	PC,GTAWRD
	BIT	#1,R0		;SCRIPT FLAG SET?
	BNE	1$		;YES
	CLR	SCRIPT		;NO, CLEAR SCRIPT FLAG
	RTS	PC		;AND RETURN
1$:	TST	PFOPEN		;ALREADY OPEN?
	BEQ	3$		;NO, TRY TO OPEN IT
	INC	SCRIPT		;IF OPEN, JUST SET SCRIPT FLAG
2$:	RTS	PC		;AND RETURN
3$:	SAVE	1
	CMP	BUFPGS,#4	;ENOUGH PAGES FOR SCRIPT BUFFERS?
	BLT	5$		;NO
	SUB	#2,BUFPGS	;YES, TAKE TWO
	MOV	R5,R0		;TOP OF USER STACK
	MOV	#PFNAME,R1	;POINTER TO DEFAULT FILE NAME AND TYPE TABLE
	JSR	R5,GTFLNM	;GET THE FILE NAME
	BR	7$		;FAILURE
	.ENTER	#AREA,#PFCHAN,#PFNAME,#0 ;TRY TO CREATE THE FILE
	BCS	6$		;FAILURE
4$:	INC	PFOPEN		;SUCCESS, SET OPEN FLAG
	INC	SCRIPT		;AND SCRIPT FLAG
	JSR	PC,FINDPG	;FIND A PAGE FOR FIRST INPUT BUFFER
	MOV	R0,SCRBF1	;FIRST BUFFER POINTER
	MOV	R0,SCRBUF	;SELECT THIS ONE
	MOV	R0,SCRPTR	;AND INITIAL CHARACTER POINTER
	ADD	#1000,R0
	MOV	R0,SCREND	;END OF BUFFER
	MOV	#177400,(R1)+	;PROTECT THIS PAGE
	MOV	#-1,(R1)
	JSR	PC,FINDPG	;FIND A PAGE FOR SECOND INPUT BUFFER
	MOV	R0,SCRBF2	;SECOND BUFFER POINTER
	MOV	#177400,(R1)+	;PROTECT THIS PAGE
	MOV	#-1,(R1)
	BR	8$		;AND RETURN
5$:	INFORM	<Insufficient memory for SCRIPTing>
	BR	7$
6$:	INFORM	<Unable to open SCRIPT file>
7$:	INC	PFLOST		;SET DEATH FLAG
8$:	.UNLOCK			;RELEASE USR
	RESTOR	1
	RTS	PC
	.DSABL	LSB

	;STORE NEXT PRINT FILE BLOCK
	.ENABL	LSB
PUTPBK::.WAIT	#PFCHAN		;WAIT FOR CURRENT OUTPUT TO COMPLETE
	BCS	3$		;OUTPUT ERROR
	.WRITE	#AREA,#PFCHAN,SCRBUF,#256.,PFBLK ;STORE THE NEXT BLOCK
	BCS	2$		;ERROR?
	INC	PFBLK		;NO, POINT TO NEXT BLOCK
	MOV	SCRBF1,R0	;POINTER TO FIRST BUFFER
	CMP	SCRBUF,R0	;WAS THIS FIRST BUFFER?
	BNE	1$		;NO, SELECT IT
	MOV	SCRBF2,R0	;YES, SELECT SECOND BUFFER
1$:	MOV	R0,SCRBUF
	MOV	R0,SCRPTR	;CHARACTER POINTER
	ADD	#1000,R0
	MOV	R0,SCREND	;END OF THIS BUFFER
	RTS	PC
2$:	TSTB	@#ERRBYT	;END OF FILE?
	BNE	3$		;NO
	INFORM	<SCRIPT file full> ;YES, NOTIFY USER
	BR	4$
3$:	INFORM	<SCRIPT file output error> ;GENERAL ERROR MESSAGE
4$:	CLR	SCRIPT		;ON ERROR, END SCRIPTING
	INC	PFLOST		;AND DISABLE IT PERMANENTLY
	RTS	PC
	.DSABL	LSB


	.PSECT	STRING
NMRMSG:	.ASCII	/**MORE**/<200>	;NORMAL MORE MESSAGE
VMRMSG:	.ASCII	<33>/[7m--More--/<33>/[m/<200> ;VT100 MORE MESSAGE
NOMORE:	.ASCII	<15>/        /<15><200> ;ERASE MORE MESSAGE
	.PSECT	CODE

	;NEXT LINE - CHECK FOR END-OF-PAGE CONDITION
	.ENABL	LSB
	DEFVAR	LINES		;LINES USED ON SCREEN SINCE LAST INPUT
NXTLIN:	INC	LINES		;ONE MORE SCREEN LINE USED
	CMP	LINES,P$PAGE	;PAGE FULL?
	BNE	3$		;NOT YET
	MOV	#1,LINES	;YES, RESET COUNTER (ALLOWING FOR THIS LINE)
	TST	P$TERM		;STATUS LINE?
	BEQ	1$		;NO
	ADD	P$TERM,LINES	;YES, ALLOW FOR IT (1 OR 2 EXTRA LINES)
1$:	SAVE	1234
	JSR	PC,OPUSL	;UPDATE STATUS LINE
	RESTOR	4321
	MOV	#NMRMSG,R0	;NORMAL MORE MESSAGE
	CMP	P$TERM,#1	;VT100?
	BNE	2$		;NO, SHOW NORMAL MORE MESSAGE
	MOV	#VMRMSG,R0	;SPECIAL VT100 MORE MESSAGE
2$:	.PRINT
	BIS	#10000,@#44	;DO SINGLE-CHARACTER INPUT
	.TTYIN			;GET ONE
	BIC	#10000,@#44	;IGNORE CHARACTER & RETURN TO NORMAL
	.PRINT	#NOMORE		;ERASE MORE MESSAGE
3$:	RTS	PC
	.DSABL	LSB

	;PRINT THE OUTPUT BUFFER
LINOUT::JSR	PC,NXTLIN	;ENTER HERE TO CHECK FOR END-OF-PAGE
BUFOUT::TST	SCRIPT		;SCRIPT?
	BEQ	4$		;NO
	SAVE	1
	MOV	OUTBUF,R1	;YES, POINT TO STRING
1$:	MOVB	(R1)+,R0	;GET NEXT CHARACTER
	BEQ	2$		;END OF STRING
	CMPB	R0,#200		;200 BYTE ALSO ENDS STRING (NO CRLF)
	BEQ	3$
	JSR	PC,SCRCHR	;SCRIPT THE CHARACTER
	BR	1$		;AND LOOP
2$:	MOV	#15,R0		;QUEUE A CR
	JSR	PC,SCRCHR
	MOVB	#12,R0		;AND A QUEUE
	JSR	PC,SCRCHR
3$:	RESTOR	1
4$:	.PRINT	OUTBUF		;PRINT THE LINE
	RTS	PC

	;PRINT A STRING
OUTSTR::.PRINT			;POINTER ALREADY IN R0
	RTS	PC

	;PRINT A CHARACTER FROM R0
OUTCHR::.TTYOUT			;DO IT
	RTS	PC

	;READ A CHARACTER INTO R0
INCHR::	CLR	LINES		;RESET LINE COUNTER
	TST	P$TERM		;STATUS LINE?
	BEQ	1$		;NO
	ADD	P$TERM,LINES	;YES, ALLOW FOR IT (1 OR 2 EXTRA LINES)
1$:	.TTYIN			;DO IT
	RTS	PC

	;GET ALL THE MEMORY AVAILABLE
GETMEM::.SETTOP	#-2		;ASK FOR HIGHEST POSSIBLE ADDRESS
	RTS	PC		;R0 WILL CONTAIN HIGHEST ADDRESS GOTTEN

	;OPEN THE GAME FILE
	DEFVAR	AREA,<.BLKW 5>	;EMT ARGUMENT BLOCK
	DEFVAR	GAMNAM,<.RAD50 /DK $GAME$IML/> ;GAME FILE NAME
OPNGAM::SAVE	1
	MOV	P$GAME,R1	;GAME NAME SUPPLIED?
	BEQ	1$		;NO, GET ONE
	MOV	R1,GAMNAM+2	;YES, USE IT
	MOV	P$GAME+2,GAMNAM+4
	BR	2$
1$:	MOV	#BUFFER+400,R0	;USE BUFFER AREA FOR CSI (IT'S STILL EMPTY)
	MOV	#GAMNAM,R1	;GAME FILE NAME & TYPE TABLE
	JSR	R5,GTFLNM	;GET THE DESIRED FILE NAME
	BR	4$		;FAILURE
2$:	.LOOKUP	#AREA,#GMCHAN,#GAMNAM ;TRY TO OPEN THE FILE
	BCS	3$		;OPEN FAILED IF CARRY SET
	MOV	GAMNAM+2,R1	;OK, NOW INITIALIZE FILE NAMES
	MOV	R1,PFNAME+2
	MOV	R1,SAVNAM+2
	MOV	R1,CMDNAM+2
	MOV	GAMNAM+4,R1
	MOV	R1,PFNAME+4
	MOV	R1,SAVNAM+4
	MOV	R1,CMDNAM+4
	RESTOR	1
	RTS	PC
3$:	CMP	GAMNAM,#^RINT
	BEQ	4$
	MOV	#^RINT,GAMNAM
	BR	2$
4$:	FATAL	<Game file not found>

	;GET A GAME FILE BLOCK, BLOCK NUMBER IN R0, CORE LOCATION IN R1
GETBLK::SAVE	2
	MOV	#1,R2		;CALL GTBLKS FOR 1 BLOCK ONLY
	JSR	PC,GTBLKS
	RESTOR	2
	RTS	PC

	;GET A SERIES OF GAME FILE BLOCKS,
	;FIRST BLOCK NUMBER IN R0, CORE LOCATION IN R1, NUMBER OF BLOCKS IN R2
GTBLKS::SAVE	023
	MOV	R0,R3
	SWAB	R2		;CONVERT BLOCK COUNT TO WORD COUNT
	.READW	#AREA,#GMCHAN,R1,R2,R3 ;READ THE BLOCKS
	BCS	1$		;READ FAILED IF CARRY SET
	RESTOR	320
	RTS	PC
1$:	FATAL	<Game file read error>

	.PSECT	STRING
FNMSTR::.ASCII	/File name (current default is /<200> ;PROMPT STRING
	.PSECT	CODE

	;GET THE FILE NAME DESIRED, SKIP ON SUCCESS,
	;TOP OF USER STACK IN R0, DEFAULT FILE NAME POINTER IN R1
	.ENABL	LSB
GTFLNM::SAVE	134		;SAVE FILE NAME POINTER FOR LATER
	MOV	SP,R3		;SAVE CURRENT STACK-POINTER
	MOV	R0,R4		;TOP OF USER STACK
	SUB	#78.,R4		;PUT OUTPUT BLOCK ON TOP OF (UNDER) IT
	.PRINT	#FNMSTR		;PRINT PROMPT STRING
	MOV	(R1)+,R0	;PRINT CURRENT FILE NAME DEFAULT
	JSR	PC,OUTR50	;IT'S IN RAD50
	.TTYOUT	#':		;FOLLOW DEVICE WITH COLON
	MOV	(R1)+,R0
	JSR	PC,OUTR50
	MOV	(R1)+,R0
	JSR	PC,OUTR50
	.TTYOUT	#'.		;PRECEDE TYPE WITH DOT
	MOV	(R1),R0
	JSR	PC,OUTR50
	.TTYOUT	#')		;END OF PROMPT
	.TTYOUT	#40
	.LOCK			;LOCK USR IN CORE
	.CSISPC	R4,R1,#0	;GET A FILE NAME
	MOV	R3,SP		;FLUSH ANY SWITCHES TYPED
	ADD	#30.,R4		;POINT TO FIRST INPUT FILE NAME
	TST	(R4)		;ANYTHING ENTERED?
	BEQ	1$		;NO, USE ALL DEFAULTS
	SUB	#6,R1		;YES, BACK UP TO FILE DEVICE NAME
	MOV	(R4)+,(R1)+	;GET DEVICE TYPED
	TST	(R4)		;ANY FILE NAME ENTERED?
	BEQ	1$		;NO, USE DEFAULTS
	MOV	(R4)+,(R1)+	;YES, GET NAME AND TYPE
	MOV	(R4)+,(R1)+
	MOV	(R4),(R1)
1$:	RESTOR	431
	.DSTAT	#AREA,R1	;GET DEVICE STATUS
	BCC	2$
	INFORM	<Illegal device specified> ;NO SUCH DEVICE
	RTS	R5
2$:	TST	AREA+4		;HANDLER IN CORE?
	BNE	3$		;YES
	INFORM	<Handler not loaded> ;NO
	RTS	R5
3$:	TST	(R5)+		;SKIP RETURN FOR SUCCESS
	RTS	R5
	.DSABL	LSB

	;CREATE THE SAVE FILE, LENGTH IN R0, SKIP RETURN ON SUCCESS
	.ENABL	LSB
	DEFVAR	SAVNAM,<.RAD50 /DK ZIP   ISV/> ;SAVE FILE NAME
NEWSFL::SAVE	12
	MOV	R0,R2		;FILE LENGTH
	MOV	4(SP),R0	;TOP OF USER STACK
	MOV	#SAVNAM,R1	;POINTER TO DEFAULT FILE NAME AND TYPE TABLE
	JSR	R5,GTFLNM	;GET THE FILE NAME
	BR	3$		;FAILURE
	TST	AREA		;MAKE SURE IT'S A FILE-STRUCTURED DEVICE
	BPL	2$
	.DELETE	#AREA,#SVCHAN,#SAVNAM ;DELETE EXISTING FILE, IF ANY
	.PURGE	#SVCHAN		;JUST IN CASE...
	.ENTER	#AREA,#SVCHAN,#SAVNAM,R2 ;TRY TO CREATE THE FILE
	BCS	1$		;CREATE FAILED IF CARRY SET
	TST	(R5)+		;SKIP ON SUCCESS
	BR	3$
1$:	CMPB	@#ERRBYT,#1	;NOT ENOUGH ROOM?
	BNE	2$		;NO, USE GENERAL MESSAGE
	INFORM	<Not enough room for SAVE file>
	BR	3$
2$:	INFORM	<Unable to open SAVE file>
	.PURGE	#SVCHAN		;PURGE THE FILE ON ERROR
3$:	RESTOR	21
	.UNLOCK			;RELEASE USR
	RTS	R5		;FAILURE RETURN IF NO SKIP
	.DSABL	LSB

	;OPEN THE SAVE FILE, SKIP ON SUCCESS
	.ENABL LSB
OPNSFL::SAVE	1
	MOV	2(SP),R0	;TOP OF USER STACK
	MOV	#SAVNAM,R1	;SAVE FILE NAME & TYPE TABLE
	JSR	R5,GTFLNM	;GET THE DESIRED FILE NAME
	BR	3$		;FAILURE
	.LOOKUP	#AREA,#SVCHAN,#SAVNAM ;TRY TO OPEN THE FILE
	BCS	1$		;OPEN FAILED IF CARRY SET
	TST	(R5)+		;SKIP RETURN
	BR	3$
1$:	CMPB	@#ERRBYT,#1	;FILE NOT FOUND?
	BNE	2$		;NO, USE GENERAL MESSAGE
	INFORM	<SAVE file not found> ;YES
	BR	3$
2$:	INFORM	<Unable to open SAVE file>
	.PURGE	#SVCHAN		;PURGE THE FILE ON ERROR
3$:	RESTOR	1
	.UNLOCK			;RELEASE USR
	RTS	R5		;RETURN WITHOUT SKIPPING FOR FAILURE
	.DSABL	LSB

	;CLOSE THE SAVE FILE
CLSSFL::.CLOSE	#SVCHAN
	RTS	PC

	;OPEN THE COMMAND FILE, SET CMDBUF FLAG
	DEFVAR	CMDBUF		;COMMAND FILE BUFFER POINTER
	DEFVAR	CMDTAB		;PAGE TABLE POINTER
	DEFVAR	CMDEND		;END OF BUFFER POINTER
	DEFVAR	CMDNAM,<.RAD50 /DK ZIP   COM/> ;COMMAND FILE NAME
	DEFVAR	CMDPTR		;COMMAND CHARACTER POINTER
	DEFVAR	CMDBLK		;FILE BLOCK NUMBER
	.ENABL	LSB
OPNCFL::CMP	BUFPGS,#3	;ENOUGH PAGES FOR BUFFER?
	BGE	1$		;YES
	INFORM	<Insufficient memory for command buffer> ;NO
	RTS	PC
1$:	SAVE	1
	MOV	R5,R0		;TOP OF USER STACK
	MOV	#CMDNAM,R1	;COMMAND FILE NAME & TYPE TABLE
	JSR	R5,GTFLNM	;GET THE DESIRED FILE NAME
	BR	3$		;FAILURE
	.LOOKUP	#AREA,#CMCHAN,#CMDNAM ;TRY TO OPEN THE FILE
	BCC	4$		;OPEN FAILED IF CARRY SET
	CMPB	@#ERRBYT,#1	;FILE NOT FOUND?
	BEQ	2$		;YES
	.PURGE	#CMCHAN		;NO, USE GENERAL MESSAGE
	INFORM	<Unable to open command file>
	BR	3$
2$:	INFORM	<Command file not found>
3$:	RESTOR	1
	.UNLOCK			;RELEASE USR
	RTS	PC
4$:	JSR	PC,FINDPG	;FIND A PAGE FOR INPUT BUFFER
	MOV	R0,CMDBUF	;BUFFER POINTER
	ADD	#1000,R0
	MOV	R0,CMDEND	;END OF BUFFER
	MOV	R1,CMDTAB	;SAVE IT
	MOV	#177400,(R1)+	;PROTECT THIS PAGE
	MOV	#-1,(R1)
	DEC	BUFPGS		;ONE LESS AVAILABLE PAGE
	CLR	CMDBLK		;START WITH BLOCK ZERO
	RESTOR	1
	.UNLOCK			;RELEASE USR
	BR	GETCBK		;GET THE BLOCK AND RETURN
	.DSABL	LSB

	;GET NEXT COMMAND FILE BLOCK
GETCBK::.READW	#AREA,#CMCHAN,CMDBUF,#256.,CMDBLK ;GET THE NEXT BLOCK
	BCC	1$		;CHECK FOR ERRORS
	CLR	CMDBUF		;ON ERROR, END COMMAND FILE INPUT
	MOV	CMDTAB,R0	;FREE BUFFER PAGE
	CLR	(R0)+
	CLR	(R0)
	INC	BUFPGS		;ONE MORE PAGE NOW AVAILABLE
	.PURGE	#CMCHAN		;FLUSH CHANNEL
	RTS	PC		;AND RETURN
1$:	INC	CMDBLK		;IF NO ERROR, POINT TO NEXT BLOCK
	MOV	CMDBUF,CMDPTR	;AND RESET CHARACTER POINTER
	RTS	PC

	;GET A SERIES OF SAVE FILE BLOCKS,
	;FIRST BLOCK NUMBER IN R0, CORE LOCATION IN R1, NUMBER OF BLOCKS IN R2
GTSBKS::SAVE	023
	MOV	R0,R3
	SWAB	R2		;CONVERT BLOCK COUNT TO WORD COUNT
	.READW	#AREA,#SVCHAN,R1,R2,R3 ;READ THE BLOCKS
	BCS	1$		;READ FAILED IF CARRY SET
	RESTOR	320
	RTS	PC
1$:	FATAL	<SAVE file read error>

	;WRITE OUT A SERIES OF SAVE FILE BLOCKS, SKIP ON SUCCESS,
	;FIRST BLOCK NUMBER IN R0, CORE LOCATION IN R1, NUMBER OF BLOCKS IN R2
PTSBKS::SAVE	023
	MOV	R0,R3
	SWAB	R2		;CONVERT BLOCK COUNT TO WORD COUNT
	.WRITW	#AREA,#SVCHAN,R1,R2,R3 ;WRITE THE BLOCKS
	BCS	1$		;WRITE FAILED IF CARRY SET
	RESTOR	320
	TST	(R5)+		;SKIP RETURN
	RTS	R5
1$:	INFORM	<SAVE file write error>
	.PURGE	#SVCHAN		;PURGE THE FILE ON WRITE ERROR
	RTS	R5		;RETURN WITHOUT SKIPPING

	;GET THE CURRENT TIME - USED FOR RANDOM NUMBER SEED
	DEFVAR	TIME,<.WORD 0,0> ;TIME IS TWO WORDS, ALWAYS INIT TO ZEROES
GETIME::TST	P$RAND		;DISABLE RANDOMNESS?
	BNE	1$		;YES, DON'T GET TIME
	.GTIM	#AREA,#TIME	;NO, GET IT
1$:	RTS	PC

	;FATAL ROUTINE - PRINT ERROR MESSAGE AND DIE
	;STRING POINTER FOLLOWS CALL
FATALR::MOV	#'?,R0		;PRINT ERROR HEADER
	JSR	PC,OUTCHR
	MOV	GAMNAM+2,R0
	JSR	PC,OUTR50
	MOV	GAMNAM+4,R0
	JSR	PC,OUTR50
	PRIN1	<-F->
	.PRINT	(R5)		;PRINT ERROR MESSAGE
FINISH::TST	PFOPEN		;PRINT FILE OPEN?
	BEQ	3$		;NO
	TST	PFLOST		;PRINT FILE DIED?
	BNE	2$		;YES, JUST CLOSE IT
	MOV	SCRPTR,R0	;GET SCRIPT POINTER
	CMP	R0,SCRBUF	;BEGINNING OF BUFFER?
	BEQ	2$		;YES
	MOV	SCREND,R1	;NO, GET END OF BUFFER POINTER
1$:	CLRB	(R0)+		;CLEAR NEXT CHARACTER POSITION
	CMP	R0,R1		;END YET?
	BNE	1$		;NO
	JSR	PC,PUTPBK	;YES, STORE THE BLOCK
2$:	.CLOSE	#PFCHAN		;CLOSE THE FILE
3$:	.EXIT			;AND DIE

	;INFORMATIONAL ROUTINE - PRINT INFORMATIONAL MESSAGE
	;STRING POINTER FOLLOWS CALL
INFRMR::MOV	#'?,R0		;PRINT INFORMATIONAL HEADER
	JSR	PC,OUTCHR
	MOV	GAMNAM+2,R0
	JSR	PC,OUTR50
	MOV	GAMNAM+4,R0
	JSR	PC,OUTR50
	PRIN1	<-I->
	.PRINT	(R5)+		;PRINT MESSAGE
	RTS	R5		;AND RETURN

.ENDC
	.SBTTL	EXTENDED INSTRUCTION SET SIMULATION ROUTINES


;ALL ROUTINES TAKE ARGUMENTS ON STACK & RETURN RESULT ON STACK AFTER
;REMOVING CONSTANT ARGUMENT

.IF	EQ	EIS

	;ARITHMETIC SHIFT (SINGLE WORD)
ASHSIM::SAVE	01
	MOV	10(SP),R0	;WORD TO SHIFT
	MOV	6(SP),R1	;NUMBER OF BITS TO SHIFT BY
	BEQ	4$		;NO SHIFT REQUIRED
	BLT	2$		;RIGHT SHIFT
1$:	ASL	R0		;LEFT SHIFT SPECIFIED NUMBER OF TIMES
	SOB	R1,1$
	BR	4$
2$:	NEG	R1
3$:	ASR	R0		;RIGHT SHIFT SPECIFIED NUMBER OF TIMES
	SOB	R1,3$
4$:	MOV	R0,10(SP)	;REPLACE SHIFTED WORD
	MOV	4(SP),6(SP)	;MOVE RETURN ADDRESS WHERE NUMBER ARGUMENT WAS
	RESTOR	10
	TST	(SP)+		;POP OFF OLD COPY OF RETURN ADDRESS
	RTS	PC

	;MULTIPLY (SINGLE WORD ONLY)
MULSIM::SAVE	012
	CLR	R0		;BUILD PRODUCT HERE
	MOV	12(SP),R1	;MULTIPLICAND
	MOV	10(SP),R2	;MULTIPLIER
1$:	ASR	R2		;TEST CURRENT LOW ORDER BIT
	BIC	#100000,R2	;CLEAR SIGN BIT JUST IN CASE...
	BCC	2$		;ZERO?
	ADD	R1,R0		;YES, ADD PARTIAL PRODUCT
2$:	ASL	R1		;MULTIPLY MULTIPLICAND BY 2
	TST	R2		;ANY MULTIPLIER BITS LEFT?
	BNE	1$		;YES, LOOP
	MOV	R0,12(SP)	;RETURN PRODUCT IN MULTIPLICAND SLOT
	MOV	6(SP),10(SP)	;SHIFT RETURN ADDRESS TO CLEAR MULTIPLIER SLOT
	RESTOR	210
	TST	(SP)+		;POP OFF OLD COPY OF RETURN ADDRESS
	RTS	PC

	;DIVIDE (DOUBLE WORD)
DIVSIM::SAVE	012345
	MOV	22(SP),R0	;HIGH ORDER DIVIDEND WORD
	MOV	20(SP),R1	;LOW ORDER DIVIDEND WORD
	CLR	R2		;HIGH ORDER SHIFTED DIVISOR WORD
	MOV	16(SP),R3	;LOW ORDER SHIFTED DIVISOR WORD
	CLR	R4		;SHIFT COUNT
	CLR	R5		;QUOTIENT BUILT HERE
1$:	CMP	R2,R0		;COMPARE SHIFTED DIVISOR WITH DIVIDEND
	BNE	2$
	CMP	R3,R1
2$:	BHI	3$		;DONE WHEN DIVISOR IS GREATER
	INC	R4		;ELSE, INCREMENT SHIFT COUNTER
	ASL	R3		;AND SHIFT DIVISOR
	ROL	R2
	BR	1$		;LOOP
3$:	TST	R4		;ORIGINAL DIVISOR GREATER THAN DIVIDEND?
	BEQ	8$		;YES, RETURN 0 WITH DIVIDEND AS REMAINDER
4$:	ASR	R2		;UNSHIFT DIVISOR ONE BIT
	ROR	R3
	CMP	R2,R0		;COMPARE WITH REMAINING DIVIDEND
	BNE	5$
	CMP	R3,R1
5$:	BHI	6$		;STILL GREATER
	SUB	R3,R1		;ELSE, DECREASE DIVIDEND BY SHIFTED DIVISOR
	SBC	R0
	SUB	R2,R0
	SEC			;AND SET CURRENT QUOTIENT BIT
	BR	7$
6$:	CLC			;RESET CURRENT QUOTIENT BIT
7$:	ROL	R5		;SHIFT CURRENT BIT INTO QUOTIENT
	SOB	R4,4$		;LOOP UNTIL DIVISOR COMPLETELY UNSHIFTED
8$:	MOV	R5,22(SP)	;SAVE QUOTIENT
	MOV	R1,20(SP)	;AND REMAINDER
	MOV	14(SP),16(SP)	;SHIFT RETURN ADDRESS TO CLEAR DIVISOR SLOT
	RESTOR	543210
	TST	(SP)+		;POP OFF OLD COPY OF RETURN ADDRESS
	RTS	PC

.ENDC
	.SBTTL	BUFFER FOR DYNAMIC STORAGE

	.PSECT	BUFFER


BUFFER::

	.END	START