cm.mac

TITLE	CM,<ALGOL COMMUNICATES>,08,06-SEP-80,TG/GPK

;	ENTRY POINTS TO THIS MODULE:

;+
; COM02		-
; COM03		-
; COM04		-
; COM05		-
; COM06		-
; COM07		-
; COM10		-
; COM11		-
; COM12		-
; COM13		-
; COM14		-
;-

;	ROUTINES CALLED FROM THIS MODULE:

;+
; GETSPC	-    -
; GETARY	-    -
; GETIME	-    -
; GEDATE	-    -
; INTERP	- RC -
; ERROR		-    -
; SYSTEM	- IO - DO SYSTEM I/O
; EXIT		- IO - EXIT THIS RTS
; STEST		-    -
;-

	ORG	CM
.SBTTL	COM02 -  I/O BUFFER ALLOCATION
;+
;	C O M 0 2
;
; THIS ROUTINE ALLOCATES AN I/O BUFFER.  THE PARAMETERS ARE
; PASSED ON THE STACK AS FOLLOWS:
;
;	1ST WORD (TOS)	- OWN TOG (FOR OWN FILES)
;	2ND WORD	- MYUSE
;	3RD WORD	- MAXRECNO
;	4TH WORD 	- MAXRECSIZE (IN BYTES)
;	5TH WORD	- FILE KIND
;	6TH WORD	- TITLE LENGTH (OR 0)
;	7TH WORD	- ADDRESS OF TITLE (OR 0)
;	8TH WORD	- ADDRESS OF FILE DESCRIPTOR
;+

COM02::	MOV	16(SP),R2		;GET ADDRESS OF FILE DESCRIPTOR
	MOV	(SP),R1			;GET OWN TOG
	ROR	(SP)+			;SEE IF OWN
	BCC	10$			;NO
	TST	2(R2)			;SEE IF FILE ALLOCATED YET
	BEQ	10$			;NO. THIS IS 1ST TIME!
	ADD	#16,SP			;CLEAN UP THE STACK
	BR	50$
10$:	MOV	(SP)+,4(R2)		;SET MYUSE
	MOV	(SP)+,10(R2)		;SET MAXRECNO
	ASL	(SP)			;MULTIPLY MAXRECSIZE BY 8
	ASL	(SP)			;TO PUT IN
	ASL	(SP)			;THE FILE DESCRIPTOR
	MOV	(SP)+,(R2)		;LIKE SO
	BIC	#177770,(SP)		;GAURANTEE GOOD KIND
	BIS	(SP)+,(R2)		;ADD FILE KIND INTO THE DESCRIPTOR
	ROR	R1			;SEE IF FILE IS OWN
	BCC	20$			;NO
	MOV	FSTFIL,6(R2)		;POINT THIS FILE TO 1ST FILE
	MOV	R2,FSTFIL		;MAKE THIS THE NEW 1ST FILE
	BR	30$			;DONE LINKAGE
20$:	ADD	#6,FILINK		;POST LINK TO LAST FILE DECLARED
	MOV	R2,@FILINK		;POINT LAST DECLARED FILE TO THIS ONE
	MOV	R2,FILINK		;MAKE THIS THE LAST DECLARED
	CLR	6(R2)			;CLEAR FORWARD POINTER FOR SAFETY
30$:	MOV	#22*2,R0		;ALLOCATE 22 WORDS PLEASE
	MOV	#M.FIB,R1		;AND THIS IS AN FIB
	CALLX	GETSPC			; AND GET THE SPACE FOR IT
	MOV	R0,2(R2)		;POINT FD TO FIB
	MOV	R2,(R0)+		;POINT MEM-LINKS TO FD
	CLR	(R0)+			;CLEAR THE OPEN BIT AND STATUS WORD
	CLR	2(R0)			;INITIALIZE FILE TITLE TO NULL
	MOV	R0,-(SP)		;SAVE FOR LATER
	MOV	#10*2,R0		;THIS IS THE SIZE WE NEED
	MOV	#M.FIB,R1		;AND IT'S A LINK BLOCK
	CALLX	GETSPC			; AND ALLOCATE IT
	MOV	R0,@(SP)+		;POINT FIB TO LINK-BLOCK
	MOV	R2,(R0)			;POINT LINK BLOCK TO FILE DESCRIPTOR
	TST	(SP)			;SEE IF INITIAL TITLE
	BEQ	40$			;NO
	JMP	COM10			;SET IT WITH OTHER COMMUNICATE
40$:	ADD	#6,SP			;CLEAN UP THE STACK
50$:	JMPX	INTERP			; BACK TO WORK
.SBTTL	COM03 -  I/O CALL
;+
;	C O M 0 3
;
; THIS ROUTINE IS THE LINK BETWEEN A USER'S PROGRAM
; AND THE I/O DRIVERS.  IT GETS THE ARRAY ROW FOR
; THE I/O DRIVER AND THEN CALLS IT.  IF THE ARRAY
; WAS SEGMENTED, THEN THE NEXT SEGMENT IS PASSED TO
; THE DRIVER AGAIN AND SO ON UNTIL THE DRIVER HAS
; COMPLETED THE REQUESTED AMOUNT OF TRANSFER.  THE
; PARAMETERS ARE PASSED ON THE STACK:
;
;   (SP) - ADDRESS OF FILE DESCRIPTOR
;  2(SP) - R/W TOGGLE (0 = READ,1 = WRITE)
;  4(SP) - ADDRESS OF ARRAY DESCRIPTOR
;  6(SP) - TRANSFER COUNT (BYTES)
; 10(SP) - INDEX INTO FILE (-1 => SEQUENTIAL)
;-

COM03::	MOV	(SP)+,R2		;GET FILE DESCRIPTOR
	MOV	R2,SYS.FD		;AND PUT IT IN THE I/O BLOCK
	MOV	2(R2),R1		;INDEX TO ALGOL FIB
	TST	2(R1)			;IS THE FILE OPEN?
	BMI	10$			;YUP
	MOV	#IO.OP,SYS.IO		;CODE FOR 'OPEN'
	CALLX	SYSTEM			; OPEN FILE
10$:	BIT	#7,(R2)			;ASCII FILE?
	BNE	60$			;YES, DIFFERENT ROUTINE
	MOV	(SP)+,SYS.IO		;GET READ/WRITE TOG
	MOV	(SP)+,R0		;FETCH ARRAY DESCRIPTOR
	MOV	(SP)+,R1		;GET TRANSFER COUNT
	MOV	(SP)+,SYS.RN		;GET RECORD NUMBER
	MOV	R0,-(SP)		;SAVE ARRAY DESCRIPTOR
	MOV	R1,R2			;TRY FOR WHOLE TRANSFER
	BIT	#A.SEG,(R0)		;BUT IF IT'S SEGMENTED
	BEQ	20$			; WE CAN'T DO IT
	MOV	#BLKSIZ*2,R2		;SO USE THIS INCREMENTAL COUNT
20$:	MOV	A$LBND(R0),R3		;START AT BEGINNING OF ROW
	MOV	R2,-(SP)		;SAVE BYTE COUNT
	INC	(SP)
	ASR	(SP)			;CONVERT TO WORD COUNT
30$:	CMP	R1,R2			;GOT LESS STUFF THAN USUAL?
	BGE	40$			;NOPE
	MOV	R1,R2			;YES, USE ONLY WHAT WE HAVE
40$:	MOV	R2,SYS.CT		;LOAD UP THE COUNT
	MOV	R3,-(SP)		;STACK THE INDEX
	MOV	4(SP),-(SP)		;AND A COPY OF THE DESCRIPTOR
	CALLX	GETARY			; TO GET US THE ROW
	CMP	(SP)+,(R0)+		;DUMP INDEX, BUMP ADDRESS
	JSR	PC,220$			;WRITE IT OUT
	ADD	(SP),R3			;ADJUST INDEX
	INC	SYS.RN			;MOVE UP TO NEXT RECORD
	SUB	R2,R1			;THAT MUCH IS DONE
	BNE	30$			;OOPS, IT'S ALL DONE
	CMP	(SP)+,(SP)+		;DUMP ARRAY DESCRIPTOR
50$:	MOV	PRT,R3			;RESTORE PRT POINTER
	JMPX	INTERP			; AND EXIT
60$:	MOV	(SP)+,R3		;PUT READ/WRITE TOG HERE
	MOV	R3,SYS.IO		; ... AND HERE
	BEQ	70$			;IF READ, NO FORMATTING
	MOV	4(SP),R1		;GET PRECEDING COUNT
	BLE	70$			;UNLESS NONE IS NEEDED
	JSR	PC,170$			;WRITE OUT SOME CR/LF'S
70$:	MOV	(SP)+,R0		;GET ARRAY DESCRIPTOR
	BIT	#A.SEG,(R0)		;TRYING TO USE A SEG ARRAY?
	BEQ	80$			;NO PROBLEM

	QUIT	<?I/O error in COM3>	; CAN'T DO THAT

80$:	MOV	(R2),R1			;GET FILE'S MAXRECSIZE
	ASH	#-3,R1			;RIGHT JUSTIFIED
	JSR	PC,200$			;CHECK AGAINST XFER COUNT
	MOV	(R0),R1			;CHECK FOR ARRAY SIZE
	ASL	R1			;CONVERT TO BYTE COUNT
	JSR	PC,200$			;COULD BE TOO SMALL
	MOV	R0,-(SP)		;GET SET TO CALL GETARY
	CALLX	GETARY			; ... DO IT
	TST	(R0)+			;INDEX TO DATA
	TST	R3			;DOING READ?
	BEQ	110$			;YES, NOTHING HERE
	TST	2(SP)			;SPECIAL OUTPUT MODE?
	BEQ	110$			;YES, DON'T MESS AROUND
	MOV	R0,R1			;COPY DATA POINTER
	ADD	(SP),R1			;AND INDEX TO THE END
90$:	CMP	R0,R1			;AT BEGINNING OF ROW YET?
	BHIS	100$			;YES, STOP NOW
	TSTB	-(R1)			;IS THIS ONE A NULL?
	BEQ	90$			;YES, IGNORE IT
	CMPB	(R1),#40		;OR A SPACE?
	BEQ	90$			;YES, IGNORE THAT TOO
	INC	R1			;ADJUST FOR LAST CHARACTER
100$:	SUB	R0,R1			;FIND NEW LENGTH
	MOV	R1,(SP)			;AND REPLACE OLD ONE
110$:	MOV	(SP)+,SYS.CT		;AND STICK IT IN
	JSR	PC,220$			;AND WRITE IT OUT
	TST	R3			;ARE WE WRITING?
	BEQ	120$			;NO, GO FIX INPUT DATA
	TST	(SP)+			;NEED A TRAILING CR/LF?
	BEQ	50$			;NOPE, JUST EXIT
	MOV	#1,R1			;JUST WRITE ONE
	JSR	PC,170$			;WRITE IT OUT
	BR	50$			; ... AND EXIT
120$:	TST	(SP)+			;DUMP RECORD NUMBER
	MOV	SYS.CT,R2		;GET BYTE COUNT
130$:	MOV	#190$,R1			;GET TABLE POINTER
140$:	CMPB	(R0),(R1)+		;GOT A MATCH?
	BEQ	150$			;YES, FOUND THE END
	TSTB	(R1)			;AT END OF LIST?
	BNE	140$			;NO, TRY ANOTHER
	INC	R0			;SKIP TO NEXT CHARACTER
	SOB	R2,130$			; ... AND LOOP
	BR	50$			;NO TERMINATOR
150$:	TSTB	(R1)			;WAS IT A FORM FEED
	BNE	160$			;NOPE, REMOVE IT
	TSTB	(R0)+			;KEEP IT IN THE BUFFER
160$:	MOVB	#40,(R0)+		;PUT IN A BLANK
	SOB	R2,160$			;UNTIL WE'VE GOT THEM ALL
	BR	50$			; ... NOW EXIT

;
; THIS SUBROUTINE WRITE AS MANY CR/LF PAIRS AS ARE
; INDICATED BY THE CONTENTS OF R1.
;

170$:	MOV	#190$,SYS.CA		;SET POINTER TO CR/LF
	MOV	#2,SYS.CT		;OUTPUT TWO BYTES
180$:	CALLX	SYSTEM			; WRITE THEM OUT
	SOB	R1,180$			;AND LOOP IF NECESSARY
	RTS	PC			;EXIT

190$:	.ASCIZ	<CR><LF><ESC><FF> 	;CR/LF/ESC/FF
	.EVEN

;
; THIS SUBROUTINE COMPARES THE VALUE IN R1 WITH THAT
; ON THE STACK AND PLACES THE SMALLER ONE ON THE STACK.
;

200$:	BIC	#160000,R1		;ONLY 13 BITS, PLEASE
	CMP	R1,2(SP)		;WHICH IS BIGGER?
	BGE	210$			;STACK IS OKAY
	MOV	R1,2(SP)		;USE R1 INSTEAD
210$:	RTS	PC			;RETURN

;
; THIS SUBROUTINE CALLS FOR I/O AND THEN SETS THE MEMORY
; MODIFIED BIT IF THE I/O WAS A READ.
;

220$:	MOV	R0,SYS.CA		;THAT IS THE CORE ADDRESS
	CALLX	SYSTEM			; DO THE I/O
	TST	SYS.IO			;WAS IT READ?
	BNE	230$			;NO, DATA WASN'T CHANGED
	BIS	#M.MDFY,M$TYPE-M$DATA(R0) ;YES, SET THE BIT
230$:	RTS	PC			;AND EXIT
.SBTTL	COM04 -  ARRAY ROW FILL
;+
;	C O M 0 4
;
; THIS ROUTINE FILLS AN ARRAY ROW WITH DATA WHICH IS STORED IN
; A SPECIFIED SEGMENT IN THE CODE FILE.  THE PARAMETERS TO THIS
; ROUTINE ARE PASSED ON THE STACK (AS FOLLOWS):
;
;   (SP) -  DISK ADDRESS OF DATA IN CODE FILE
;  2(SP) -  NUMBER OF WORDS OF DATA
;  4(SP) -  ADDRESS OF ARRAY DESCRIPTOR
;
; ALL PARAMETERS ARE REMOVED FROM THE STACK.
;-

COM04::	MOV	(SP)+,SYS.RN		;GET INITIAL RECORD NUMBER
	MOV	(SP)+,R2		;AND NUMBER OF WORDS OF DATA
	MOV	(SP),R0			;AND DESCRIPTOR ADDRESS
	MOV	R2,R3			;DUPE THE SIZE OF THE DATA
	BIT	#A.SEG,(R0)		;IS IT SEGMENTED?
	BEQ	10$			;NO
	MOV	#BLKSIZ,R3		;YES, CHANGE READ SIZE
10$:	MOV	#PROGFD,SYS.FD		;SET TO READ THE CODE FILE
	MOV	#IO.RD,@#SYS.IO		; YES, READ
	MOV	A$LBND(R0),-(SP) 	;START AT BEGINNING OF ARRAY
20$:	CMP	R3,R2			;READ BIGGER THAN ROW?
	BLE	30$			;NOPE
	MOV	R2,R3			;YES, USE ROW SIZE
30$:	MOV	(SP),-(SP)		;COPY ROW INDEX
	MOV	4(SP),-(SP)		;COPY ARRAY DESCRIPTOR
	CALLX	GETARY			; MAKE THAT ROW PRESENT
	BIS	#M.MDFY,M$TYPE-M$PNTR(R0) ;SET THE MODIFIED BIT
	MOV	@(R0)+,R1		;GET ARRAY ROW SIZE
	BIC	#160000,R1		; BUT JUST THE SIZE
	CMP	R1,R3			;IS ROW LARGE ENOUGH?
	BGE	40$			;SURE IS
	MOV	R1,R3			;NOPE, USE ROW SIZE
	MOV	R3,R2			;  AND STOP FILLING HERE
40$:	TST	(SP)+			;DUMP INDEX
	MOV	R0,SYS.CA		;SET THE CORE ADDRESS
	MOV	R3,SYS.CT		;MOVE THE TRANSFER SIZE
	ADD	R3,SYS.CT		; (IN BYTES)
	CALLX	SYSTEM			; DO THE READ
	ADD	R3,(SP)			;ADJUST INDEX
	INC	SYS.RN			;ONLY SEQUENTIAL READS NOW
	SUB	R3,R2			;COUNT DOWN
	BNE	20$			; UNLESS DONE
	TST	(SP)+			;DUMP ARRAY INDEX
	TST	(SP)+			;DUMP ARRAY DESCRIPTOR
	MOV	PRT,R3			;RESTORE PRT POINTER
	JMPX	INTERP			; AND EXIT
.SBTTL	COM05 -  JOB TERMINATION
;+
;	C O M 0 5
;
; THIS ROUTINE CLOSES ALL FILES AND THEN EXITS.
;-

COM05::	MOV	FSTFIL,R0		;GET ALGOL FIB ADDRESS OF CODE FILE
	MOV	#IO.CL,SYS.IO		;SET CODE FOR 'CLOSE'
10$:	MOV	2(R0),R1		;SEE IF FILE IS OPEN-ED.
	TST	2(R1)			;BIT #15 (OPEN BIT) OF 1ST WORD OF FIB
	BPL	20$			;IF NOT OPEN-ED THEN DON'T CLOSE
	MOV	R0,SYS.FD		;SAVE FILE DESCRIPTOR'S ADDRESS
	CALLX	SYSTEM			; NOW CLOSE THE FILE
20$:	MOV	6(R0),R0		;GET NEXT FILE DESCRIPTOR ADDRESS
	BNE	10$			;IF 0 THEN NO MORE
	JMPX	EXIT			;EXIT TO MONITOR
.SBTTL	COM06 -  FILE OPEN STATUS CHANGES
;+
;	C O M 0 6
;
; THIS ROUTINE ALLOWS ONE TO FORCE A FILE TO BE OPENED,
; CLOSED, OR PURGED, OR ALLOW A PRESENCE CHECK.
;
;   (SP) -  CODE: 0-ASSIGN TO PRESENT
;		  1-ASSIGN TO OPEN
;		  2-OBTAIN PRESENT STATUS
;  2(SP) -  STORAGE CODE (0-STON, 1-STOD)
;  4(SP) -  BOOLEAN VALUE
;  6(SP) -  FILE DESCRIPTOR ADDRESS
;-

COM06::	CMP	(SP),#1			;SEE IF PRESENT CHECK
	BLE	20$			;NO
	TST	(SP)+			;POP CODE
	MOV	(SP)+,R0		;GET ADDRESS OF FILE DESCRIPTOR
	MOV	2(R0),R1		;GET FIB POINTER
	TST	2(R1)			;SEE IF OPENED
	BPL	10$			;IF SO THEN WE GOT OUR ANSWER
	MOV	#1,-(SP)		;SET TRUE ON THE STACK
	BR	70$			; AND EXIT
10$:	MOV	R0,SYS.FD		;TIME TO GET STATUS
	MOV	#IO.ST,SYS.IO		;CODE FOR STATUS CHECK
	CALLX	SYSTEM			; DO THE I/O
	BR	70$			;NOW EXIT
20$:	MOV	6(SP),R0		;GET ADDRESS OF FILE DESCRIPTOR
	MOV	R0,SYS.FD		;SET UP FILE DESCRIPTOR IN CASE
	MOV	2(R0),R1		;POINT TO ALGOL FIB
	TST	(R1)+			;POINT TO OPENED BIT
	BIT	#1,4(SP)		;SEE IF BOOLEAN VALUE IS TRUE
	BEQ	30$			;OR FALSE
	TST	(R1)			;IF FILE IS OPENED
	BMI	50$			;THEN OUR WORK IS DONE (FILE ALREADY OPEN!)
	MOV	#IO.OP,SYS.IO		;CODE FOR OPEN
	CALLX	SYSTEM			; DO IT
	BR	50$
30$:	TST	(R1)			;IF FILE IS ALREADY CLOSED
	BPL	40$			;THEN WE ARE AT LEAST 1/2 DONE
	MOV	#IO.CL,SYS.IO		;CODE FOR CLOSE
	CALLX	SYSTEM			; WAS JSR R5, ???
40$:	TST	(SP)			;SEE IF CODE WAS PRESENT
	BNE	50$			;NO
	MOV	#IO.DE,SYS.IO		;CODE FOR DELETE
	CALLX	SYSTEM			; DO I/O
50$:	TST	(SP)+			;POP CODE
	ROR	(SP)+			;SEE IF STOD (1)
	BCC	60$			;NO --> STON
	CMP	(SP)+,(SP)+		;POP EVERYTHING
	BR	70$
60$:	MOV	(SP)+,@SP		;LEAVE BOOLEAN VALUE ON TOS
70$:	JMPX	INTERP			; AND EXIT TO RC
.SBTTL	COM07 -  OTHER FILE ATTRIBUTE CHANGES
;+
;	C O M 0 7
;
; THIS ROUTINE ALLOWS ONE TO CHANGE THE ATTRIBUTES KIND, 
; MAXRECSIZE, CURRENTRECNO, MYUSE, AND MAXRECNO.  ONLY
; CURRENTRECNO MAY BE CHANGED FOR AN OPEN FILE.
;
;	1ST WORD  (TOS)	- WHAT TO CHANGE (0-KIND,1-MAXRECSIZE,
;			    2-CURRENTRECNO,3-MYUSE,4-MAXRECNO)
;	2ND WORD	- STORAGE TYPE (0-STON,1-STOD)
;	3RD WORD	- VALUE TO GET STORED
;	4TH WORD	- ADDRESS OF FILE DESCRIPTOR
;-

	.ENABL	LSB
COM07::	MOV	6(SP),R0		;GET ADDRESS OF FILE DESCRIPTOR
	TST	(R0)+			;GET TO FIB POINTER
	MOV	(R0),R1			;GET TO FIB
	TST	(R1)+			;GET TO FILE STATUS
	CMP	(SP),#2			;CHANGING CURRENTRECNO ?
	BEQ	10$			;YES. IGNORE THIS TEST
	TST	(R1)			;SEE IF FILE IS OPENED
	BMI	50$			;CAN'T  CHANGE THESE ATTRIBUTES
10$:	MOV	2(SP),R2		;FETCH STORAGE TYPE
	MOV	(SP)+,(SP)		;RE-STACK ATTRIBUTE NUMBER
	ASL	(SP)			;MAKE INTO A WORD INDEX
	ADD	(SP)+,PC		; AND DISPATCH
	BR	KIND
	BR	MAXREC
	BR	CRNT
	BR	MYUSE
MAXSIZ:	MOV	(SP),6(R0)		;CHANGE FILE MAXRECNO
	BR	30$
MYUSE:	MOV	(SP),2(R0)		;SET MYUSE
	BR	30$
KIND:	BIC	#7,-(R0)		;CLEAR OUT THE OLD KIND
	MOV	(SP),-(SP)		;DUP A COPY TO WORK WITH
	BIC	#177770,(SP)		;MOD NEW KIND BY 8
	BR	20$
CRNT:	BIC	#77777,(R1)		;CLEAR OUT THE OLD CURRENT REC NO
	BIC	#100000,(SP)		;TURN OFF BIT #15 IN NEW REC NO
	BIS	(SP),(R1)		;ADD IT INTO THE STATUS WORD
	BR	30$
MAXREC:	BIC	#177770,-(R0)		;CLEAR OUT THE OLD MAXRECNO
	MOV	(SP),-(SP)		;DUP IT TO WORK WITH
	ASL	(SP)			;MULTIPLY
	ASL	(SP)			;NEW MAXRECNO
	ASL	(SP)			;BY 8. TO PUT IN THE FD
20$:	BIS	(SP)+,(R0)		;ADD INTO THE FD
30$:	MOV	(SP)+,(SP)		;DELETE FD AND MOVE VALUE IN ITS PLACE
	ROR	R2			;SEE IF STOD (1)
	BCC	40$			;NO. STOD
	TST	(SP)+			;CLEAN THE STACK UP
40$:	JMPX	INTERP			;NEXT !

50$:	QUIT	<?Attribute error in COM07>
.SBTTL	COM10 -  FILE RENAME
;+
;	C O M 1 0
;
; THIS ROUTINE ALLOWS A FILE TITLE TO BE CHANGED.
; ONLY FILES WHICH ARE NOT OPEN MAY HAVE THEIR NAME
; CHANGED.  THE PARAMETERS TO THE ROUTINE ARE:
;
;   (SP) -  LENGTH OF TITLE (BYTES)
;  2(SP) -  POINTER TO TITLE
;  4(SP) -  ADDRESS OF FILE DESCRIPTOR
;-

COM10::	MOV	(SP)+,R2		;LENGTH OF FILE NAME
	MOV	(SP)+,R1		;ADDRESS OF NEW FILE NAME
	MOV	(SP)+,R0		;ADDRESS OF FILE DESCRIPTOR
	MOV	2(R0),R0		;GET ADDRESS OF ALGOL FIB
	TST	(R0)+			;POP OVER LAST MEM-LINK
	TST	(R0)+			;POP OVER STATUS WORD AND TEST
	BMI	50$			;OPEN BIT (BIT #15)
	TST	(R0)+			;POP OVER LINK BLOCK POINTER
	CMP	R2,#37			;WE CAN ONLY HAVE MAX LENGTH OF 37
	BLE	60$			;IS OK
	MOV	#37,R2			;MAX COUNT!
60$:	MOVB	(R1)+,(R0)+		;TRANSFER THE NEW NAME
	SOB	R2,60$			;UNTIL DONE
	CLRB	(R0)			;SET NULL CODE
	JMPX	INTERP			;AND EXIT
	.DSABL	LSB
.SBTTL	COM11 -  GO TO SOLVER
;+
;	C O M 1 1
;
; YES, DEAR FRIENDS, IT'S OUR OLD FRIEND THE GO TO SOLVER.
; THIS ROUTINE GETS THE PROGRAMMER WHERE HE WANTS TO GO
; WHEN HE DECIDES THAT HE NO LONGER LIKES HIS CURRENT
; ENVIRONMENT.  THIS IS USED WHEN AT LEAST ONE BLOCK
; BOUNDARY IS EXITED.  THE PARAMETERS ON THE STACK ARE:
;
;   (SP) - LEVEL+1 OF WHERE WE ARE GOING (OR 0)
;  2(SP) - PROGRAM DESCRIPTOR IF TOS=0
;  4(SP) - RELATIVE ADDRESS IN SEGMENT
;-

COM11::	MOV	(SP)+,R0		;GET LEVEL + 1 (OR 0)
	BNE	GOTO			;IF ZERO THEN ONLY A BLOCK EXIT
	MOV	R4,R1			;SAVE RCW POINTER FOR US
	MOV	R4,-(SP)		;DESCRIPTOR AND RELATIVE ADDRESS
					;ALREADY ON THE STACK. ALL WE HAVE
					;TO DO TO FAKE A RCW IS TO PUSH
					;THE F REG ONTO THE STACK AND THEN
	MOV	SP,R4			;STORE THE STACK POINTER IN THE F REG
	MOV	-2(R1),R0		;FIND RIGHT ARRAY LINKAGE FOR THIS RCW
10$:	TST	@R0			;NOW TO FOLLOW THE ARRAY LINKS UNTIL
	BEQ	30$			;EITHER WE HIT THE END (NULL)
	CMP	@R0,STKLIM		;OR AN ARRAY GETS ALLOCATED INTO
	BLO	20$			;THE PRT. THEN IT DOESN'T GO AWAY
	CMP	@R0,@R3			;OR A POINTER IS LOWER IN CORE THAN
	BLO	30$			;THE CURRENT MKSW WE ARE RETURNING TO
20$:	MOV	@R0,R0			;TO FREE ANY ARRAYS IN NESTED BLOCKS
	BR	10$			;ON THE SAME LEVEL
30$:	MOV	R0,-(SP)		;BETTER TO BE CONSISTENT THAN NOT
	MOV	-4(R1),R0		;NOW FOR THE FILE LINKS
40$:	MOV	6(R0),R1		;SEE IF AT OUR WITS END !
	BEQ	60$
	CMP	R1,STKLIM		;SEE IF FILE IN THE PRT
	BLO	50$			;YES.
	CMP	R1,@R3			;SEE IF NEXT FILE AFTER THIS MKCW
	BLO	60$			;YES
50$:	MOV	R1,R0			;TRY NEXT FILE
	BR	40$
60$:	MOV	R0,-(SP)		;SO MUCH FOR THE FILES
	MOV	PTRLNK,R0		;NOW FOR THE POINTERS!
70$:	TST	@R0			;POINTING OUT THE END?
	BEQ	100$
	CMP	@R0,@R3			;SEE IF NEXT POINTER IS PAST MKS
	BHI	90$			;IF SO THEN DONE
80$:	MOV	@R0,R0			;GET LINK
	BR	70$			;TRY AGAIN
90$:	CMP	-4(R0),#-1		;IS IT THE ORIGIONAL?
	BEQ	80$			;YES. NOT DONE YET.
100$:	MOV	R0,-(SP)		;FINISH WITH THE POINTER-LINK
	JMPX	INTERP			;ALL SET. NOW BACK TO THE ACTION
GOTO:	DEC	R0			;GET THE ACTUAL LEVEL # DESIRED
	MOV	R4,R1			;HAVE TO ENTER IN THE MIDDLE OF A LOOP
					;SO SAVE THE F REG HERE
	BR	20$			;ENTER THE LOOP TO FIND THE LEVEL
10$:	MOV	R4,R1			;SAVE THE PREVIOUS F REG
	MOV	@R4,R4			;GET THE NEXT RCW
20$:	CMP	R0,-10(R4)		;AND SEE IF IN OUR LEVEL YET
	BLT	10$			;LOOP UNTIL NEW F LEVEL = LEVEL GOING TO
	MOV	(SP),4(R1)		;STORE PROG COUNTER IN RCW OF BLOCK
					;THAT WE ARE ABOUT TO ENTER.
	MOV	R1,R4			;RESET THE F REG BECAUSE WE EXITTED 1 BLOCK
					;TOO MANY.  NOW HAVE TO TAKE CARE OF THE
					;MARK STACK CONTROL WORDS (MKSW'S)
30$:	MOV	@(R3)+,-(R3)		;GET NEXT MKSW
	CMP	@R3,R4			;SEE IF WE HAVE PASSED THE F REG YET
	BLOS	30$			;LOOP UNTIL R REG HAS CAUGHT UP
					;AND PASSED THE F REG
RET.ID:	JMPX	INTERP			;AND AWAY WE GO
.SBTTL	COM12 -  TIME FUNCTIONS
;+
;	C O M 1 2
;
; TOS IS AN INDEX INTO THE TIME FUNCTION TABLE:
;	TIME(0)=SECOND
;	TIME(1)=MINUTE
;	TIME(2)=HOUR
;	TIME(3)=DAY OF MONTH
;	TIME(4)=MONTH OF YEAR
;	TIME(5)=YEAR
;
; THE ANSWER IS RETURNED ON TOS IN PLACE OF INDEX.
;-

COM12::	TST	(SP)			;SEE IF A VALID TIME FUNCTION
	BMI	10$			;NOPE, NO NEGATIVE TIME FUNCTIONS
	CMP	(SP),#2			;SEE IF A CLOCK FUNCTION
	BLE	20$			;YES
	CMP	(SP),#5			;NOPE. BETTER BE A DATE FUNCTION
	BLE	50$

10$:	QUIT	<?Time error>

20$:	CALLX	GETIME			; GET CLOCK TIME
30$:	ASL	(SP)			;MULTIPLY FUNCTION BY 4
	ASL	(SP)			;TO INDEX INTO THESE INSTRUCTIONS
	ADD	(SP)+,PC		;*********MODIFIERS BEWARE**********
					;THIS IS A CASE STMT INTO CODE BELOW
	MOV	R0,-(SP)		;PUSH SECOND VALUE
	BR	40$			;BR OUT OF CASE STMT
	MOV	R1,-(SP)		;PUSH MINUTE (OR MONTH) VALUE
	BR	40$
	MOV	R2,-(SP)		;PUSH HOUR (OR YEAR) VALUE
40$:	JMPX	INTERP			;EXIT
50$:	CALLX	GEDATE			; GET THE DATE
	SUB	#3,(SP)			;MOD FUNCTION WITH 3
	BR	30$			;SO WE CAN USE PREVIOUS CODE
.SBTTL	COM13 -  STRING TO BINARY CONVERSION
;+
;	C O M 1 3
;
; THIS ROUTINE CONVERTS A STRING OF CHARACTERS INTO THE
; CORRESPONDING BINARY NUMBER.  THE PARAMETERS ARE:
;
;   (SP) -  NUMBER OF CHARACTERS TO CONVERT
;  2(SP) -  POINTER INDEX IN STRING
;  4(SP) -  ARRAY HOLDING STRING
;-

COM13::	MOV	(SP)+,R2		;# OF CHARS TO TRANSLATE
	MOV	(SP)+,10(R3)		;POINTER INDEX
	MOV	@SP,6(R3)		;ARRAY NAME
	CLR	12(R3)			;CLEAR MAM ADDRESS
	MOV	R2,@SP			;SAVE LENGTH
	CLR	-(SP)			;TEMP STORAGE PLACE
	CLR	-(SP)			;INIT THE ANSWER
	TST	R2			;DONE YET?
	BLE	40$			;YEP. THAT WAS FAST
10$:	CLR	-(SP)			;FILL 1ST POINTER
	CALLX	STEST			; ??
	MOV	(SP)+,R0		;ADDRESS
	MOV	(SP)+,R1		;LENGTH
20$:	MOVB	(R0)+,2(SP)		;GET CHAR
	BIC	#177760,2(SP)		;GET GOOD BITS
	CMP	#6553.,@SP		;SEE IF ANSWER TOO BIG
	BLO	60$			;TOO BIG
	BNE	30$			;NOT YET
	CMP	2(SP),#6		;SEE IF > 5 (IE. > 65535)
	BGE	60$			;YEP.
30$:	ASL	@SP			;MULTIPLY TOS BY 10
	MOV	@SP,-(SP)		;SAVE A COPY
	ASL	@SP
	ASL	@SP			;NOW ADD THE TWO
	ADD	(SP)+,@SP		;LIKE SO
	ADD	2(SP),@SP		;ADD THIS CHAR ALSO!
	INC	10(R3)			;UPDATE POINTER
	DEC	4(SP)			;CONTINUE
	BEQ	40$			;UNTIL DONE
	SOB	R1,20$			;LOOP UNTIL
	BR	10$			;POINTER NEEDS RE-FILLING
40$:	MOV	(SP)+,@SP		;MOVE ANSWER
	MOV	(SP)+,@SP		;TO WHERE IT SHOULD BE
	TST	12(R3)			;POINTER USED?
	BEQ	50$			;NO
	MOV	14(R3),@12(R3)		;UNSAVE MEM-DESC
50$:	JMPX	INTERP			;ALL DONE!

60$:	QUIT	<?Conversion error>
.SBTTL	COM14 -  CHAIN OPERATOR (NOT IMPLEMENTED)
;+
;	C O M 1 4
;
;	NOT IMPLEMENTED.
;-

COM14::	QUIT	<?Chain not implemented yet.>

	.END