Google
 

Trailing-Edge - PDP-10 Archives - CFS_TSU04_19910205_1of1 - update/cblsrc/lcm20.mac
There are 3 other files named lcm20.mac in the archive. Click here to see a list.
; UPD ID= 1248 on 6/6/83 at 9:49 AM by NIXON                            
TITLE	LCM - COBOL COMMUNICATION MODULE FOR TOPS-20
SUBTTL		S. BLOUNT

	SEARCH COPYRT
	SALL

;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

COPYRIGHT (C) 1978, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION


	SEARCH	INTERM
	SEARCH	MACSYM		;SYSTEM USER MACRO FILE
	SEARCH	MONSYM		;MONITOR SYMBOLS

IFN MCS,<
	SEARCH	TCSSYM		;SEARCH TCS COMMON FILE
	SEARCH	TCSINT		;TCS-20 INTERFACE FILE
>

	LCMEDT==:2		;EDIT NUMBER

REPEAT 0,<
THIS MODULE SUPPORTS THE COMMUNICATION VERBS IN COBOL FOR
TOPS-20. IT DIFFERS FROM THE LCM WHICH SUPPORTS MCS-10 IN
MANY WAYS--THUS, THE TWO MODULES ARE NOT INTERCHANGEABLE.
IN ORDER TO INCLUDE THIS MODULE IN THE COBOTS BUILDING PROCESS,
THE "MCS" ASSEMBLY SWITCH MUST BE ON WHEN COBOTS IS BUILT.
>;END OF REPEAT 0


	SALL
	TWOSEG
	.COPYRIGHT		;Put standard copyright statement in REL file
	RELOC	400000
	SUBTTL	TABLE OF CONTENTS OF LCM
	SUBTTL	REVISION HISTORY

COMMENT /
	THIS PAGE CONTAINS A COMPLETE HISTORY OF ALL EDITS MADE TO
	THIS MODULE. EACH TIME A NEW EDIT IS MADE, THE FOLLOWING STEPS
	MUST BE DONE:
		1. INCREMENT THE MODULE EDIT NUMBER SYMBOL (LCMEDT)
		2. OBTAIN A NEW LIBOL EDIT NUMBER
		3. ADD THE LIBOL AND THE LOCAL EDIT NUMBERS BELOW


	LIBOL
	EDIT	DATE		WHO	COMMENT
	====	====		===	=======

	1	6-28-78		SB	FIX FNAREA TO STORE ACTUAL ADDR
	2	7-12-78		SB	CHANGE FSD ERROR TO CRL
	3	8-30-78		SB	ADD SETH'S FIXES HE FOUND

	[END OF REVISION HISTORY]

/
SUBTTL	AC DECLARATIONS

COMMENT /
IN LCM, THERE ARE TWO CATEGORIES OF AC'S - TEMPORARY
AND PERMANENT. THE TEMPORARY AC'S ARE NEVER SAVED ACROSS
ROUTINE CALLS. THE PERMANENT AC'S ARE NEVER CLOBBERED BY
ANYONE EXCEPT OTHER LIBOL ROUTINES WHICH MAY BE CALLED.
THUS, THE PERMANENT AC'S DO NOT HAVE TO BE SAVED UNLESS
A UTILITY LIBOL ROUTINE IS CALLED BY LCM.
/

FG=0		;FLAG REGISTER
T1=1		;TEMP 1
T2=2		;TEMP 2
T3=3		;TEMP 3
T4=4		;TEMP 4
T5=5		;TEMP 5
VH=6		;POINTER TO CURRENT VARIABLE HEADER ON COMMUNICATION PAGE
TB=7		;POINTER TO CURRENT TEXT BLOCK ON COMM. PAGE
CD=10		;POINTER TO USER CD RECORD
S1=11		;FIRST INPUT AC
S2=12		;SECOND INPUT AC
S3=13		;THIRD INPUT AC
TF=14		;TRUE/FALSE REGISTER
AP=16		;ARGUMENT POINTER
PP=17		;PUSHDOWN LIST POINTER


; SAVE - SAVE A SINGLE AC
;
DEFINE SAVE(AC),<
	IRP AC,<PUSH	PP,AC>
>				;END OF SAVE MACRO

; RESTOR - RESTORE A SINGLE AC
;
DEFINE RESTOR(AC),<
	IRP AC,<POP	PP,AC>
>				;END OF RESTOR MACRO
SUBTTL	MACROS FOR ROUTINE CALL/RETURN/STORAGE DECLARATION

; $LCMENTRY - DEFINE AN LCM ENTRY POINT
;
DEFINE $LCMENTRY(NAME),<
	ENTRY NAME
		NAME:
>				;END OF $LCMENTRY MACRO

; $BADENTRY - ENTRY POINT FOR UNIMPLEMENTED OPERATION
;
DEFINE $BADENTRY (CODE,TEXT),<
	$LCMENTRY(CODE)
	HRROI	S1,[ASCIZ /TEXT/]
	JRST	UNIMP
>

; $EXIT - EXIT TO USER PROGRAM
;
DEFINE $EXIT,<
	RETURN
>				;END OF $EXIT MACRO

; $LOCALS - DEFINE LOCAL STORAGE
;
DEFINE $LOCALS(LLIST),<
	STKVAR<LLIST>
>				;END OF $LOCALS MACRO



; CALL - INVOKE A SUBROUTINE
;
DEFINE CALL(SUB),<
	PUSHJ	PP,SUB
>				;END OF CALL MACRO
SUBTTL	MACROS TO RETURN FROM A SUBROUTINE

; RETURN - RETURN FROM A SUBROUTINE
;
DEFINE RETURN,<
	POPJ	PP,
>				;END OF RETURN MACRO


; RETT - RETURN WITH "TRUE" FROM A SUBROUTINE
;
DEFINE RETT,<
	JRST	[MOVE	TF,[TRUE]	;;GET VALUE
		 RETURN]
>				;END OF RETT MACRO

;RETF - RETURN WITH "FALSE" FROM A SUBROUTINE
;
DEFINE RETF(VALUE),<
	JRST	[ IFNB <VALUE>,< MOVEI S1,VALUE>
		 MOVE	TF,[FALSE]
		 RETURN]
>				;END OF RETF MACRO

; SKIPT - SKIP IF CURRENT VALUE IS "TRUE"
;
DEFINE SKIPT,<
	CAME	TF,[TRUE]
>				;END OF SKIPT
; JUMPT - JUMP IF CURRENT VALUE IS "TRUE"
;
IFDEF TRUE,<IFGE TRUE,<PRINTX ?THE VALUE FOR TRUE WILL MAKE JUMPT FAIL>>
DEFINE JUMPT(PLACE),<
	JUMPL	TF,PLACE
>				;END OF JUMPT MACRO


; JUMPF - JUMP IF CURRENT VALUE IS "FALSE"
;
IFL FALSE,<PRINTX ?THE VALUE FOR FALSE WILL MAKE JUMPF FAIL>
DEFINE JUMPF(PLACE),<
	JUMPGE	TF,PLACE
>				;END OF JUMPF MACRO

; SKIPF - SKIP IF CURRENT VALUE IS "FALSE"
;
DEFINE SKIPF,<
	SKIPE	TF		;;CHECK STATUS VALUE
>				;;END OF SKIPF
SUBTTL	MACROS TO PROCESS ERRORS OF ALL KINDS

; ERR - PRINT AN LCM ERROR AND DISPATCH
;
DEFINE ERR(ERR$,RET$),<
	JRST	[TMSG	<?LCM - UNEXPECTED ERROR OCCURRED IN LCM
?ERROR IS:  >
		 HRROI	T1,ERR$		;GET ERROR ADDRESS
		 PSOUT			;PRINT IT
	IFNB <RET$>,<JRST RET$>
	IFB <RET$>,<JRST .+1>]		;GO BACK
>
; JSYSF - PROCESS AN UNEXPECTED ERROR RETURN FROM A JSYS
;
DEFINE JSYSF,<
	PUSHJ	P,JERROR	;GO PROCESS JSYS ERRORS
>				;END OF JSYSF MACRO
SUBTTL	MISCELLANEOUS MACROS FOR LCM


; TSWT - TEST A SWITCH AND SKIP IF IT IS ON
;
DEFINE TSWT(SWITCH),<
	TRNN	FG,SWITCH
>				;END OF TSWT MACRO

; TSWF - TEST A SWITCH AND SKIP IF IT IS OFF
;
DEFINE TSWF(SWITCH),<
	TRNE	FG,SWITCH
>				;END OF TSWF MACRO

; BUG - MACRO TO DECLARE AN INTERNAL LCM ERROR CONDITION
;
DEFINE BUG(ADR),<
	PUSHJ	P,BG.'ADR	;JUMP TO PROPER LOCATION
>				;END OF BUG MACRO

; NOFAIL - MACRO TO CHECK TO SEE IF A ROUTINE FAILED WHICH SHOULDN'T
;
DEFINE NOFAIL(CODE),<
	JRST	[SKIPF		;;DID ROUTINE SUCCEED?
		 JRST	.+1	;;YES, CONTINUE
		 BUG	(CODE)]	;;NO, DECLARE INTERNAL BUG
>				;;END OF DEFINE

; OCTAL - PRINT AN OCTAL NUMBER OF USER'S TTY
;
DEFINE OCTAL(COLS),<
	MOVEI	1,.PRIOU	;;OUTPUT TO TTY
	MOVE	3,[NO%LFL+COLS_^D18+^D8]	;;OCTAL
	NOUT			;;PRINT JSYS CODE
	 JFCL
>				;;END OF OCTAL
SUBTTL	MISCELLANEOUS SYMBOLS FOR LCM



;ASCII CHARACTER CODES
LF==12		;LINE FEED
CR==15		;RETURN
VT==13		;VERT TAB
FF==14		;FORM FEED
DLE==20		;DATA LINK ESCAPE
DC1==21		;DATA CONTROL...
DC2==22		;...
DC3==23		;...
DC4==24		;...


;SHIFTING CONSTANTS
P2WLSH==^D9	;MAKE ADDRESS FROM PAGE
W2PLSH==^D-9	;ADDRESS TO PAGE NUMBER

;TRUE/FALSE VALUES
TRUE==-1	;SUCCESS
FALSE==0	;FAILURE

;FLAG BITS DEFINED IN THE FLAG REGISTER:
F.SEND==1B35	;THIS IS A "SEND"
F.WAIT==1B34	;RECEIVE WITH WAIT
F.EMPT==1B33	;TCSCON RETURNED "FORM Q EMPTY"



;VALUES OF CODES WHICH ARE USED TO INTERFACE TO THE REST OF LIBOL
LF%GOT==6	;GET CORE
LF%RAD==3	;RETURN CORE
LF%PAG==15	;PAGE FUNCTION CODE
TP%INT==2	;INTEGER DATA-TYPE
TP%LIT==17	;LITERAL DATA-TYPE

;FLAG BITS IN ARG BLOCK
FG%FIG==(1B2)	;FIG CONSTANT
SUBTTL	ENTRY POINTS IF TCS-20 NOT ENABLED

IFE MCS,<
$LCMENTRY (M.INIT)
$LCMENTRY (M.RMW)
$LCMENTRY (M.RMNW)
$LCMENTRY (M.RSW)
$LCMENTRY (M.RSNW)
$LCMENTRY (M.SEND)
$LCMENTRY (M.IFM)
$LCMENTRY (M.EIT)
$LCMENTRY (M.DIT)
$LCMENTRY (M.EI)
$LCMENTRY (M.EO)
$LCMENTRY (M.DI)
$LCMENTRY (M.DO)
$LCMENTRY (M.AC)
$LCMENTRY (MNAME)
$LCMENTRY (MBIND)
	TMSG	<?COBOTS not built with MCS support
>
	JRST	STOPR.##
	END
>;END OF IFE MCS
SUBTTL	STATUS KEY AND ERROR KEY CONVERSION TABLE

;THIS TABLE IS USED FOR CONVERTING STATUS VALUES RETURNED FROM
; TCSCON TO STATUS KEY AND ERROR KEY VALUES TO GO IN THE USER'S
; CD RECORD. FOR INSTANCE, IF TCSCON RETURNED A STATUS
; CODE OF "2", ONE COULD INDEX INTO THIS TABLE TO THE THIRD (OFFSET=2)
; WORD. THIS WORD WOULD CONTAIN THE VALUE WHICH SHOULD GO INTO
; THE USER'S STATUS KEY FIELD IN THE RIGHT HALF
; THE FORMAT OF THE TABLE IS:
;
;	0,,STATUS KEY
;
;THE TABLE IS INDEXED BY THE STATUS CODE RETURNED BY TCSCON.
; NOTE THAT THE VALUES ARE IN ACTUAL ASCII FORMAT (NOT BINARY).
;
;DEFINE STRUCTURES FOR ACCESSING FIELDS
$BLOCK	ST		;START OF STATUS KEY ENTRY
 $HALF	ST.XXX		;UNUSED
 $HALF	ST.SKY		;STATUS KEY
$EOB

; ECODE - DEFINE THE ERROR CODES RETURNED IN THE USER'S CD
;
; NOTE THAT THESE CODES ARE ACTUAL ASCII TEXT, NOT NUMERIC VALUES.
; THIS FACILITATES MANIPULATING THESE VALUES AND STORING THEM INTO
; THE CD.
DEFINE	ECODE(NAME,VALUE),<
	ER$'NAME="VALUE"	;;DEFINE AS ASCII TEXT
	IFDEF TS%'NAME,<$SET (TS%'NAME,ER$'NAME)>;;PUT ERROR COD INTO CONVERSION TABLE
>				;END OF ECODE MACRO

;DEFINE THE ERROR CODE CONVERSION TABLE
STTAB:
	$INIT TS
	ECODE (FQE,00)		;;FORM Q IS EMPTY
	ECODE (AOK,00)		;;NO ERROR...GOOD RETURN FROM TCSCON
	ECODE (SHT,01)		;;SYSTEM SHUTDOWN HAS OCCURED
	ECODE (SYS,02)		;;TCSCON INTERNAL ERROR OR RESET R-U BY TCS OPR
	ECODE (DDA,10)		;;DESTINATION DISABLED
	ECODE (BMC,13)		;;BAD MESSAGE CLASS
	ECODE (TAO,15)		;;TERMINAL ALREADY OWNED
	ECODE (UFT,15)		;;UNOWNED FORMS TERMINAL
	ECODE (BTS,20)		;;BAD TRANSACTION SET NAME
	ECODE (BDE,20)		;;DESTINATION UNKNOWN
	ECODE (BFN,21)		;;BAD FORM NAME
	ECODE (ABO,22)		;;TRANSACTION ABORTED BY TERMINAL OPERATOR
	ECODE (BDC,30)		;;BAD DESTINATION COUNT
	ECODE (PSW,40)		;;BAD PASSWORD
	ECODE (BTL,50)		;;BAD TEXT LENGTH 
	ECODE (TTL,51)		;;TEXT TOO LONG FOR TCS WINDOW
	ECODE (CRL,52)		;;FORM LENGTH DESCREPANCY (COMPILE/RUN-TIME)
	ECODE (CRV,53)		;;FORM VERSION DESCREPANCY (COMPILE/RUN-TIME)
	ECODE (DIC,54)		;;DATA ERROR (PREDICATE EVALUATION)
	ECODE (BEI,61)		;;BAD END INDICATOR (NOT CURR. USED)
	ECODE (BAI,62)		;;NEGATIVE ADVANCING ITEM
	ECODE (CCE,64)		;;MESSAGE CLASS CONTRADICTS END INDICATOR
	ECODE (BTR,66)		;;BAD TRANSACTION NAME (ACCEPT COUNT ONLY)
	ECODE (CCD,67)		;;MSG CLASS CONTRADICTS SYM DESTINATION
	ECODE (CCF,68)		;;MSG CLASS CONTRADICTS "FROM" CLAUSE
	$ENDINIT
SUBTTL	MACROS TO DEFINE THE STRUCTURE OF THE CD


REPEAT 0,<

THE FOLLOWING MACROS ARE USED TO DEFINE THE STRUCTURE OF THE
INPUT AND OUTPUT CD'S. IN DOING SO, THEY DEFINE A SERIES
OF SYMBOLS WHICH DEFINE THE SIZE AND POSITION OF EACH CD
FIELD. ALSO, THEY CREATE (WHEN INVOKED) A TABLE OF BYTE
POINTERS WHICH POINT TO EACH FIELD IN THE CD. THIS POINTER
TABLE IS INDEXED BY A SYMBOL WHICH IS ALSO GENERATED BY
THESE MACROS AND CAN BE CONSTRUCTED FROM THE NAME OF THE
CD FIELD IN QUESTION.

TO ILLUSTRATE, CONSIDER THE "MESSAGE DATE" FIELD IN THE
INPUT CD. THE MNEMONIC CHOSEN FOR THIS FIELD IS "DAT".
THE FOLLOWING SYMBOLS WILL BE CREATED BELOW:

	IS.DAT		SIZE IN CHARACTERS OF THE FIELD
	IB.DAT		BIT NUMBER IN WORD WHERE FIELD BEGINS
	IO.DAT		OFFSET INTO POINTER TABLE WHERE POINTER IS

THE "I" WHICH PRECEDES EACH SYMBOL INDICATES THAT THE FIELD
IS CONTAINED IN THE INPUT CD. FOR OUTPUT-CD FIELDS, THE SYMBOLS
WILL HAVE AN "O" AT THE FRONT (E.G., OS.STS).

FOR OUTPUT CD'S, THE SYMBOLS AND POINTER TABLES ASSUME THAT
THERE IS ONLY ONE ENTRY IN THE DESTINATION TABLE. THUS, IF
MULTIPLE DESTINATION ARE SUPPORTED, SOME CALCULATION MUST BE
DONE TO COMPUTE THE POINTER FOR THE "MESSAGE CLASS" FIELD,
WHICH COMES AFTER THE DESTINATION TABLE.
>				;END OF REPEAT 0

; INITCD - INITIALIZE THE DEFINITION OF A CD
;
DEFINE INITCD,<
	CD%OFF==0
>				;END OF INITCD MACRO

; CDFLD - DECLARE A FIELD IN THE CD
;
DEFINE CDFLD(TYPE,NAME,OFFSET,BIT,LENGTH),<
	TYPE'S.'NAME=^D<LENGTH>		;;DEFINE SYMBOL FOR FIELD SIZE
	TYPE'O.'NAME=CD%OFF		;;CURRENT OFFSET INTO POINTER TABLE
	TYPE'B.'NAME=^D<BIT>		;;SAVE BIT NUMBER
	CD%OFF==CD%OFF+1		;;BUMP TABLE OFFSET
	IFN BIT,<POINT	7,OFFSET(CD),BIT-1>	;;DEFINE BYTE POINTER
	IFE BIT,<POINT	7,OFFSET(CD)>		;;DEFINE BYTE POINTER FOR 1ST FIELD
>					;END OF CDFLD MACRO
SUBTTL	STRUCTURE OF INPUT AND OUTPUT CD

; THIS MACRO DEFINES ALL SYMBOLS WHICH SPECIFY THE POSITION AND
; SIZE OF EACH THE FIELD IN THE CD.

ICDTAB:	INITCD			;INITIALIZE ALL VARIABLES
	CDFLD (I,QQ,0,^D0,12)	;;SYMBOLIC FORM
	CDFLD (I,SQ1,2,^D14,12)	;;SUB-QUEUE-1
	CDFLD (I,SQ2,4,^D28,12)	;;SUB-QUEUE-2
	CDFLD (I,SQ3,7,^D7,12)	;;SUB-QUEUE-3
	CDFLD (I,DAT,11,^D21,6)	;;MESSAGE DATE
	CDFLD (I,TIM,12,^D28,8)	;;MESSAGE TIME
	CDFLD (I,SRC,14,^D14,12);;SYMBOLIC SOURCE
	CDFLD (I,LEN,16,^D28,4)	;;TEXT LENGTH
	CDFLD (I,END,17,^D21,1)	;;END INDICATOR
	CDFLD (I,STS,17,^D28,2)	;;STATUS KEY
	CDFLD (I,CNT,20,^D7,6)	;;MESSAGE COUNT

;OUTPUT CD TABLE
;
OCDTAB:	INITCD			;INITIALIZE AGAIN
	CDFLD (O,DCT,0,^D0,4)	;;DESTINATION COUNT
	CDFLD (O,LEN,0,^D28,4)	;;TEXT LENGTH
	CDFLD (O,STS,1,^D21,2)	;;STATUS KEY
	CDFLD (O,KEY,2,^D0,1)	;;ERROR KEY
	CDFLD (O,DST,2,^D7,12)	;;SYMBOLIC DESTINATION
	CDFLD (O,CLS,4,^D21,12)	;;MESSAGE CLASS
SUBTTL	SYMBOLS FOR COMMUNICATION PACKET FORMATS

;SIZE OF PACKET DESCRIPTOR BLOCK FOR [SYSTEM-INFO]:
IP%PDS==6
SUBTTL	NON-SUPPORTED ENTRY POINTS FOR TCS

$LCMENTRY (M.EI)
$LCMENTRY (M.EO)
$LCMENTRY (M.DI)
$LCMENTRY (M.DO)
$LCMENTRY (M.EIT)
$LCMENTRY (M.DIT)
$LCMENTRY (M.IFM)
$LCMENTRY (M.RSNW)
$LCMENTRY (M.RSW)
	TMSG	<%LCM - LIBOL DOES NOT SUPPORT LEVEL 2 STATEMENTS>
	RETURN
IFN MCS,<
SUBTTL	INIT - INITIALIZE LCM WHEN APPLICATION PROGRAM COMES UP

;THIS ENTRY POINT IS CALLED ONLY ONCE DURING A PARTICULAR RUN
; OF AN APPLICATION PROGRAM. HOWEVER, SINCE WE DON'T
; KNOW THE NAME OF THE TCS-20 SYSTEM AT THIS POINT,
; THIS ROUTINE SIMPLY RETURNS.

$LCMENTRY (M.INIT)
	SKIPE	AP		;DID WE HAVE AN INITIAL CD?
	 BUG	(BCA)		;YES, COMPILER ERROR
	$EXIT
SUBTTL	MBIND - PERFORM FORM BINDING
;
; THIS ROUTINE IS CALLED ONLY BY THE "ENTER MACRO" STATEMENTS
; AT THE START OF THE PROCEDURE DIVISION IN THE USER'S COBOL
; PROGRAM. THE GENERAL FORM OF THESE STATEMENTS IS:
;
;	ENTER MACRO MBIND USING "FORM-NAME",FORM-NAME,FORM-NAME-CONTROL.
;
; THIS ROUTINE CREATES AND MAINTAINS A TABLE OF FORM NAMES
; AND POINTERS TO "FORM DESCRIPTORS". THIS TABLE IS IN THE
; STANDARD FORMAT FOR COMMAND TABLES (I.E., AS USED IN THE
; TBADD AND TBLUK JSYS'S).
;
; THE LEFT HALF OF EACH ENTRY IN THE TABLE IS A POINTER TO THE
; FORM NAME. THE RIGHT HALF OF THE WORD IS NOT
; USED, SINCE THE ADDRESS OF THE 1-WORD DESCRIPTOR CAN
; BE COMPUTED BY ADDING THE OFFSET OF THE TABLE ENTRY TO
; THE HALF-WAY POINT IN THE TABLE.
;
; THE 1-WORD DESCRIPTOR  CONTAINS THE FORM CONTROL AREA ADDRESS IN THE LEFT HALF,
; AND THE FORM AREA ADDRESS IN THE RIGHT HALF. THE DESCRIPTORS
; ARE ALLOCATED AT THE BOTTOM OF THE FORM NAME TABLE IN THE SAME
; ORDER AS THE FORM NAMES IN THE TOP HALF OF THE TABLE. NOTE THAT
; THE LENGTH OF THE TABLE (IN THE FIRST WORD) REPRESENTS ONLY
; THE TOP HALF, SINCE THE TABLE JSYS'S ONLY OPERATE ON THE TOP HALF.
; NOTE ALSO THAT ALTHOUGH THE JSYS'S ADD ENTRIES TO THE TOP
; HALF OF THE TABLE, THE BOTTOM HALF MUST BE MAINTAINED BY
; LCM. THUS, THERE IS CODE BELOW (AT MB2A) WHICH MOVES THE ENTRIES
; DOWN IF A NEW FORM NAME IS INSERTED INTO THE TOP OF THE TABLE.
;
; DEFINE THE STRUCTURE OF THE 1-WORD DESCRIPTOR
$BLOCK	FT			;FORM TABLE DESCRIPTOR
  $HALF	FT.CTL			;ADDR OF FORM CONTROL AREA
  $HALF	FT.FRM			;ADDR OF FORM AREA
$EOB
; THE ENTIRE TABLE LOOKS LIKE THIS:

;	!=====================================!
;	!      COUNT       !    SIZE (N-1)    ! 0
;	!-------------------------------------!
;	!   ADDR OF NAME-1 !                  ! 1
;	!-------------------------------------!
;	!                  .                  !
;	!                  .                  !
;	!                  .                  !
;	!-------------------------------------!
;	!   ADDR OF NAME-N !                  ! N
;	!-------------------------------------!
;	!              <UNUSED>               ! N+1
;	!-------------------------------------!
;	!  FORM CTL AREA-1 !  FORM DATA AREA-1! N+2
;	!-------------------------------------!
;	!                  .                  !
;	!                  .                  !
;	!                  .                  !
;	!-------------------------------------!
;	!  FORM CTL AREA-N !  FORM DATA AREA-N! 2N
;	!=====================================!
;INITIAL SIZE OF FORM NAME (BIND) TABLE
; NOTE THAT THIS TABLE INCLUDES SPACE FOR POINTERS TO THE
; FORM AREA AND THE FORM CONTROL AREA ALSO. THUS, THE NUMBER OF
; FORMS WHICH CAN BE INCLUDED IN THE TABLE IS ONLY 1/2 OF THE 
; FOLLOWING NUMBER.
MX%FRM==^D50	;MAX # OF FORMS IN A SINGLE TABLE (IF TABLE
			; OVERFLOWS, A BIGGER ONE WILL BE ALLOCATED)
SZ%HDR==MX%FRM-1	;SIZE TO STORE IN FORM TABLE HEADER
..HALF==MX%FRM+1	;=SIZE OF ENTIRE FORM TABLE (TOP HALF)
SZ%TAB==..HALF*2	;=TOTAL SIZE OF SPACE TO ALLOCATE
;
;
;
$LCMENTRY	(MBIND)
	PUSH	P,AP		;SAVE AP
	SKIPN	S1,TP.BTP##	;IS THERE A BIND TABLE YET?
	JRST	MB2		;YES
	MOVS	T1,(S1)		;GET HEADER IN OLD TABLE
	CAME	T1,(S1)		;IS COUNT=LENGTH OF TABLE? (I.E., FULL?)
	JRST	MB3		;NO
MB2:	MOVE	S1,TP.BTP##	;NO, ALLOCATE ONE
	CALL	MAKTAB		;NO, GO MAKE ONE
	MOVEM	S1,TP.BTP##	;UPDATE OUR TABLE ADDRESS
MB3:	POP	P,AP		;GET THE AP
	MOVE	T1,TP.BTP##	;GET ADDRESS AGAIN
	MOVE	T2,(AP)		;GET ADDRESS OF TEXT PTR
	HRLZ	T2,(T2)		;GET ADDRESS OF STRING
				;USE 0 FOR "USER DATA"
	TBADD			;ADD ENTRY TO TABLE
	MOVE	T3,T1		;GET PTR TO ENTRY LOC IN TABLE
	MOVE	T2,TP.BTP##	;GET ADDRESS OF TABLE
	HRRZ	T2,(T2)		;GET LENGTH OF TABLE
	MOVE	T4,T3		;GET PTR AGAIN
	SUB	T4,TP.BTP##	;=OFFSET INTO TABLE OF NEW ENTRY
	ADDI	T3,1(T2)	;=ADDR IN BOTTOM HALF OF NEW DESC
	MOVE	T1,TP.BTP##	;GET PTR TO TABLE AGAIN
	HLRZ	T1,(T1)		;GET ACTUAL ENTRY COUNT
	CAMN	T4,T1		;IF OFFSET INTO TABLE .NEQ. LENGTH OF
				;TABLE (I.E., NOT LAST ENTRY), THEN
	JRST	MB4		;...WE MUST MOVE THE EXISTING DESC'S IN
	MOVE	T1,TP.BTP##	;...THE BOTTOM HALF DOWN TO MAKE ROOM
	HLRZ	T4,(T1)		;GET ACTUAL ENTRY COUNT
	ADDI	T1,1(T2)	;=ADDR OF FIRST WORD IN BOTTOM HALF
	ADD	T1,T4		;=FIRST UNUSED WORD IN BOTTOM HALF

;LOOP OVER BOTTOM HALF AND MOVE EACH WORD DOWN 1 WORD
MB2A:	MOVE	T4,-1(T1)	;GET LAST WORD
	MOVEM	T4,(T1)		;STORE IT HERE
	SOS	T1		;DECREMENT PTR
	CAME	T1,T3		;HAVE WE REACHED IN PLACE FOR THE NEW WORD?
	JRST	MB2A		;NO, KEEP GOING

;CONTINUED ON NEXT PAGE...
;STORE THIS ENTRY IN BOTTOM HALF OF TABLE
MB4:	HRRZ	T2,1(AP)	;FORM AREA ADDRESS
	STOR	T2,FT.FRM(T3)	;STORE IT
	HRRZ	T2,2(AP)	;FORM CONTROL AREA ADDRESS
	SKIPN	0(T2)		;...UNLESS TRANS-CONTEXT
	SETZM	T2		;INDIC "NO" 2ND ARG
	STOR	T2,FT.CTL(T3)	;STORE IT
				;...TABLE ENTRY
	$EXIT			;OK!
SUBTTL	ROUTINE TO PROCESS MBIND CALLS

; MAKTAB - MAKE A FORM NAME TABLE
;
; CALL
;	S1 = ADDRESS OF CURRENT TABLE OR 0 IF NONE
;
; RETURNS:
;	S1 = ADDRESS OF NEW TABLE (OLD ONE IS RELEASED)
;
MAKTAB:
	$LOCALS	<HDRSIZ,NEWPTR,OLDPTR,OLDSIZ>
	MOVEM	S1,OLDPTR	;SAVE OLD BLOCK ADDRESS
	JUMPE	S1,[MOVEI	S1,SZ%TAB	;NO, USE DEFAULT SIZE
		    JRST	MAKT2]
	HRRZ	S1,(S1)		;GET SIZE OF TABLE
	MOVEM	S1,HDRSIZ	;SAVE THIS FOR LATER
	AOS	S1		;ACCOUNT FOR HEADER
	LSH	S1,1		;DOUBLE IT TO GIVE ACTUAL SIZE
	MOVEM	S1,OLDSIZ	;SAVE THIS SIZE
	LSH	S1,1		;=SIZE OF NEW TABLE
MAKT2:	CALL	GETCOR		;ALLOCATE CORE FOR TABLE
	SKIPT			;OK?
	ERR	MSGCGC,STOPR.	;NO, BOMB OUT
	MOVEM	S1,NEWPTR	;ADDRESS OF NEW BLOCK
	LSH	S2,-1		;1/2 OF ACTUAL SIZE=SIZE TO PUT
				; IN HEADER OF BLOCK
	SOS	S2		;LENGTH DOESN'T INCLUDE HEADER
	MOVE	T1,OLDPTR	;GET PTR TO OLD BLOCK
	SKIPE	T1		;IF THERE IS ONE...
	HLL	S2,(T1)		;PICK UP THE OLD ENTRY COUNT
	MOVEM	S2,(S1)		;STORE SIZE OF TABLE IN TABLE
	SKIPN	OLDPTR		;WAS THERE AN EXISTING BLOCK?
	JRST	RETT.		;NO
	HRLZ	T1,OLDPTR	;ADDRESS OF OLD BLOCK
	HRR	T1,NEWPTR	;MOVE TOP OF OLD BLOCK TO NEW
	ADD	T1,[1,,1]	;DON'T MOVE HEADER
	MOVE	T2,HDRSIZ	;COMPUTE WHERE TO END MOVE
	ADDI	T2,-1(T1)	;ADD START OF NEW BLOCK
	BLT	T1,(T2)		;MOVE TOP HALF

	HRRZ	T1,OLDPTR	;SET UP TO MOVE BOTTOM HALF OF OLD
	ADD	T1,HDRSIZ	; TABLE.
	ADDI	T1,2		;=ADDRESS OF FIRST WORD OF BOTTOM HALF
	HRLZS	T1		;PUT IN LEFT HALF
	HRR	T1,NEWPTR	;ADDRESS OF NEW BLOCK
	ADD	T1,OLDSIZ	;=1ST WORD IN BOTTOM OF NEW BLOCK
	AOS	T1		;1ST WORD ACTUALLY USED
	MOVEI	T2,-1(T1)	;MOVE OVER PTR
	ADD	T2,HDRSIZ	;ADD SIZE OF BOTTOM HALF
	BLT	T1,(T2)		;MOVE BOTTOM HALF
	MOVE	S1,OLDPTR	;GET ADDR OF OLD TABLE
	MOVE	S2,OLDSIZ	;GET SIZE OF OLD TABLE
	CALL	RELCOR		;RELEASE OLD TABLE
	MOVE	S1,NEWPTR	;ADDR OF NEW TABLE
	RETT
SUBTTL	MNAME - BIND NAME OF TCS-20 SYSTEM

; THIS ROUTINE IS CALLED ONLY FROM THE USER'S PROGRAM AT THE
; BEGINNING OF THE PROCEDURE DIVISION. IT IS CALLED BY A:
;		ENTER MACRO MNAME USING "TCS-NAME".
;
; THIS ROUTINE MUST SIMPLY MOVE THIS NAME TO THE LOCATION "TP.NAM".
; IT THEN MUST GET A PID FOR THE NAME, SEND A HELLO MESSAGE
; TO TCSCON, WAIT FOR A RESPONSE, AND PERFORM ALL PRELIMINARY
; PROCESSING.
;

$LCMENTRY	(MNAME)		;NO "M." 'CAUSE COBOL WONT ALLOW
				;PERIODS ON EXTERNAL CALLS
	MOVE	S1,@0(AP)	;GET ADDRESS OF STRING DESC
	MOVE	S2,[POINT 7,TP.NAM##]
	MOVEI	S3,MX%TCN	;MAX SIZE OF NAME
	CALL	MOVTNF		;MOVE STRING
	MOVE	S1,1(AP)	;GET DISPATCH VARIABLE ADDRESS
	MOVE	T1,1(S1)	;GET SIZE WORD
	TLNE	T1,FG%FIG	;DID HE SUBSTITUTE A VALUE HERE?
	JRST	NAME2		;NO
	HLRZ	T1,S1		;GET DATA TYPE
	CAIE	T1,100		;NUMERIC?
	ERR	MSGBDT,STOPR.##	;NO
	MOVEM	S1,TP.DVP##	;YES, SAVE IT
NAME2:	SETZM	TP.LPD##	;CLEAR OUR PID
	CALL	HISPID		;GET A PID FOR IT
	 JUMPF	STOPR.##	;STOP IF FAILURE
	CALL	HELLO		;SAY HELLO TO TCS
	 JUMPF	STOPR.##	;STOP IF FAILURE
	CALL	THELLO		;LET TCS SAY HELLO TO US
	 JUMPF	STOPR.##	;STOP IF FAILURE
	CALL	OPENCF		;OPEN THE COMMUNICATION FILE
	 JUMPF	STOPR.##	;STOP IF FAILURE
	CALL	DEATH		;SET UP DEATH NOTICE
	$EXIT
SUBTTL	SEND - SEND A FORM FROM LCM TO TCS-20

;THIS ROUTINE PROCESSES THE SEND STATEMENT FOR LIBOL.
; IT PASSES THE DATA PROVIDED BY THE COBOL PROGRAM TO TCS-20
; FOR TRANSMISSION TO AN APPLICATION TERMINAL (OR PERHAPS TO
; AN INTERNAL QUEUE-STRUCTURE IN THE CASE OF PGT'S).

$LCMENTRY	(M.SEND)

	CALL	SETUP		;PERFORM NORMAL INITIALIZATON
	TXO	FG,F.SEND	;REMEMBER THAT THIS IS A SEND
	CALL	SETSVH		;SET UP THE SEND VARIABLE HEADER
	 JUMPF	STRSTS		;EXIT NOW IF ERROR DETECTED
	CALL	SETTXT		;SET UP THE TEXT BLOCK
	 JUMPF	STRSTS		;EXIT NOW IF ERROR DETECTED
	CALL	MOVSHID		;MOVE THE HIDDEN DATA
	CALL	CKSERR		;CHECK FOR SEND ERRORS OF ALL TYPES
	 JUMPF	STRSTS		;LEAVE NOW IF AN ERROR FOUND
	MOVEI	S1,AE%SEN	;GET SEND FUNCTION CODE
	CALL	POST		;TELL TCS THAT WE HAVE A REQUEST
	 NOFAIL	(IRF)		;**SHOULD NOT FAIL
	CALL	WAIT		;WAIT FOR RESPONSE
	CALL	SNDSTS		;STORE THE USER'S STATUS KEY
	$EXIT			;RETURN TO LIBOL

;COME HERE ON A USER ERROR (S1=ASCII ERROR CODE)
STRSTS:
	MOVE	S2,OO.STS+OCDTAB	;GET POINTER TO STATUS KEY
	EXCH	S1,S2		;PTR IN S1, CODE IN S2
	CALL	STSKEY		;STORE CODE THRU POINTER
	MOVEI	S1,AE%SAB	;TELL TCSCON THERE WAS AN ERROR
	CALL	POST
	$EXIT			;EXIT TO USER
SUBTTL	RECEIVE - RECEIVE A FORM FROM TCS-20

;THIS ENTRY POINT IS USED TO RECEIVE A FORM FROM TCS-20 AND
; PLACE IN A USER'S DATA ITEM. THE USER MAY WAIT FOR SUCH A
; FORM TO BE AVAILABLE, OR HE MAY RETURN IMMEDIATELY IF NO
; FORM IS IN THE QUEUES.

$LCMENTRY (M.RMW)		;RECEIVE MESSAGE AND WAIT

	CALL	SETUP		;PERFORM COMMON SETUP
	TXO	FG,F.WAIT	;REMEMBER THAT THIS IS A RCV WITH WAIT
	MOVEI	S1,AE%RMW	;ASSUME WAITING
	CALL	DORCV		;CONTINUE
	$EXIT			;RETURN TO USER

;THIS ENTRY POINT IS USED IF NO WAITING IS TO BE DONE
;

$LCMENTRY (M.RMNW)		;NO WAIT

	CALL	SETUP		;COMMON SETUP
	MOVEI	S1,AE%RMNW	;NO, CHANGE FUNCTION CODE
	CALL	DORCV		;PERFORM THE RECEIVE STUFF
	TSWF	F.EMPT		;WAS FORM Q EMPTY?
	AOS	(PP)		;YES, BUMP RETURN ADDRESS
	$EXIT			;RETURN TO USER

; DORCV - PERFORM THE MAIN BODY OF RECEIVE PROCESSING
;
; CALL:
;	S1 = FUNCTION CODE TO USE IN HEADER
;
; RETURN:
;	<NO RETURN VALUE>
;	(BUT F.EMPT MAY BE SET IN THE NO-WAIT CASE)
;
DORCV:
	$LOCALS	<FCODE>		;STORE FUNCTION CODE HERE
	MOVEM	S1,FCODE	;...
	CALL	SETRVH		;SET UP PAGE FOR RECEIVE
	 NOFAIL	(IRF)		;**SHOULD NOT FAIL
	CALL	SETHD		;SETUP TEXT AND HIDDEN DATA
	MOVE	S1,FCODE	;GET FUNCTION CODE BACK
	CALL	POST		;SEND IT TO TCS-20 FOR ACTION
	 NOFAIL	(IRF)		;**SHOULD NOT FAIL
	CALL	WAIT		;WAIT FOR A RESPONSE
	 NOFAIL	(IRF)		;**SHOULD NOT FAIL
	CALL	RCVSTS		;STORE RESULTS IN USER'S CD
	 JUMPF	RETF.		;RETURN IF NOT SUCCESSFUL
	CALL	SETCD		;UPDATE THE USER'S CD
	CALL	GETTXT		;MOVE THE FORM INTO RECEIVING ITEM
	RETT			;RETURN WITH TRUE
SUBTTL	ENABLE/DISABLE OUTPUT/INPUT ENTRY

;THESE ROUTINES ALL PROCESS THE ENABLE OR DISABLE COBOL VERBS.
; SINCE THESE VERBS ARE NOT SUPPORTED IN LEVEL 1 OF THE ANSI
; STANDARD, LCM PRINTS OUT A SIMPLE ERROR MESSAGE IF THESE
; ENTRY POINTS ARE TAKEN.

$BADENTRY (DI,'DISABLE INPUT')	;DISABLE INPUT
$BADENTRY (EI,'ENABLE INPUT')	;ENABLE INPUT
$BADENTRY (DO,'DISABLE OUTPUT')	;DISABLE OUTPUT
$BADENTRY (EO,'ENABLE OUTPUT')	;ENABLE OUTPUT

;COME HERE TO PRINT MESSAGE OUT:
UNIMP:	TMSG	<?LCM - UNIMPLEMENTED COBOL OPERATION FOUND
?STATEMENT IS: >
	MOVE	1,S1		;GET BAD STATEMENT TEXT
	PSOUT			;PRINT IT
	TMSG	<
>
	$EXIT
SUBTTL	ACCEPT COUNT PROCESSOR

;THIS ROUTINE PROCESSES THE ACCEPT COUNT COBOL VERB. IT RETURNS
; THE NUMBER OF FORMS IN A PARTICULAR QUEUE.

$LCMENTRY (M.AC)
	CALL	SETUP		;COMMON SETUP
	CALL	SETRVH		;SET UP PAGE IN RECEIVE FORMAT
	 NOFAIL	(IRF)		;**SHOULD NOT FAIL
	MOVE	S1,IO.SQ1+ICDTAB	;MOVE TRANSACTION NAME TOO
	MOVEI	S2,WH.SQ1(VH)	;DESTINATION ON PAGE
	HRLI	S2,AS%IBP	;FOR ASCII BYTE PTR
	MOVEI	S3,IS.SQ1	;SIZE OF FIELD
	CALL	MOVTNF		;MOVE TRANSACTION NAME
	STOR	S1,WH.LQ1(VH)	;STORE LENGTH
	MOVE	S1,IO.SQ2+ICDTAB	;MOVE FORM NAME TOO
	MOVEI	S2,WH.SQ2(VH)	;DESTINATION ON PAGE
	HRLI	S2,AS%IBP	;FOR ASCII BYTE PTR
	MOVEI	S3,IS.SQ2	;SIZE OF FIELD
	CALL	MOVTNF		;MOVE TRANSACTION NAME
	STOR	S1,WH.LQ2(VH)	;STORE LENGTH
	MOVEI	S1,AE%AC	;SET UP FUNCTION CODE
	CALL	POST		;SEND REQUEST TO TCSCON
	 NOFAIL	(IRF)		;**SHOULD NOT FAIL
	CALL	WAIT		;WAIT FOR RESPONSE
	 NOFAIL	(IRF)		;**SHOULD NOT FAIL
	CALL	RCVSTS		;STORE STATUS CODE
	MOVE	S2,WH.CNT(VH)	;GET FORM COUNT FROM PAGE
	SKIPT			;WAS THE STATUS CODE OK?
	MOVEI	S2,0		;NO, SET FORM COUNT TO 0
	MOVE	S1,IO.CNT+ICDTAB	;GET PTR FOR MESSAGE COUNT FIELD
	MOVEI	S3,IS.CNT	;SIZE OF FIELD
	CALL	PUTDEC		;CONVERT MESSAGE COUNT AND STORE IN CD
	$EXIT			;RETURN TO USER
SUBTTL	HELLO/THELLO - ROUTINES TO TALK TO TCSCON

; HELLO - ROUTINE TO CALL TCSCON THE FIRST TIME
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<TRUE ALWAYS>
;
HELLO:
	MOVEI	T1,.IPCCA	;CREATE APPLICATION CODE
	MOVEM	T1,TP.PKT##	;STORE IN PACKET
	MOVE	S1,[1,,TP.PKT##]	;GET SIZE AND ADDRESS OF PACKET
	MOVE	S2,TP.LPD##	;OUR PID
	MOVE	S3,TP.TPD##	;PID OF TCS
	CALL	IPSEND		;SEND THIS MESSAGE
	RETURN

; THELLO - GET A RESPONSE FROM TCSCON
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<TRUE ALWAYS>
;
THELLO:
	MOVE	S1,[TP.PKS##,,TP.PKT##]
	CALL	IPRECV		;GET A RESPONSE FROM TCS
	JUMPF	RETF.		;RETURN IF FAILED
	MOVEI	T1,TP.PKT##	;GET PTR TO PACKET
	LOAD	S2,PK.STS(T1)	;GET STATUS CODE
	CAIE	S2,TS%AOK	;IS IT OK?
	JRST	SYSERR		;UNEXPECTED ERROR
	LOAD	T2,PK.OFF(T1)	;GET PROGRAM OFFSET INTO DIREC PAGE
	MOVEM	T2,TP.ID##	;SAVE IT
	LOAD	T2,PK.IPC(T1)	;GET PAGE # OF PARTITION
	MOVEM	T2,TP.IPC##	;SAVE
	LOAD	T2,PK.WSZ(T1)	;SIZE OF WINDOW
	MOVEM	T2,TP.WNS##	;SAVE
	RETT
SUBTTL	COMMON SETUP

; SETUP - PERFORM COMMON INITIALIZATION FOR ALL VERBS
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<NO RETURN VALUES>
;
SETUP:
	SKIPN	TP.BTP##	;DID WE PERFORM INITIALIZATION?
	ERR	MSGNBF,STOPR.##	;NO, USER DIDN'T HAVE COPY FOR BIND FILE
	SETZ	FG,		;CLEAR FLAG REGISTER
	MOVE	CD,0(AP)	;SET UP POINTER TO USER CD
	MOVE	CD,(CD)		;GET PTR TO CD
	MOVE	T1,1(AP)	;GET SECOND ARG
	MOVEM	T1,TP.RG2##	;STORE IT
	MOVE	T1,2(AP)	;GET THIRD ARG
	MOVEM	T1,TP.RG3##	;STORE IT
	MOVE	T1,3(AP)	;GET FOURTH ARG
	MOVEM	T1,TP.RG4##	;STORE IT
	MOVE	T1,4(AP)	;GET FIFTH ARG
	MOVEM	T1,TP.RG5##	;STORE IT
	RETURN
SUBTTL	SETRVH - SET UP VARIABLE HEADER FOR "RECEIVE"

; SETRVH - SET UP THE VARIABLE HEADER FOR A "RECEIVE"
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE ALWAYS
;
SETRVH:
	MOVEI	S1,SZ%RWH	;SIZE OF RECEIVE VARIABLE HEADER
	CALL	SETFH		;SET UP FIXED HEADER
	MOVE	S1,IO.QQ+ICDTAB	;PTR TO QUEUE NAME
	MOVEI	S2,WH.QQ(VH)	;POINTER TO QUEUE NAME ON PAGE
	HRLI	S2,(POINT CP%BSZ,0)	;USE RIGHT BYTE SIZE
	MOVEI	S3,IS.QQ	;MOVE QUEUE NAME
	CALL	MOVTNF		;MOVE TEXT WITH NO FILL ONTO COMM. PAGE
	STOR	S1,WH.LQQ(VH)	;STORE LENGTH OF QUEUE NAME
	RETT			;GO BACK

; SETHD - SETUP HIDDEN DATA AND TEXT BLOCK PTR ON RECEIVE
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<TRUE ALWAYS>
;
SETHD:
	MOVEI	S1,WH.SQ1(VH)	;GET PTR TO TRAN-NAME
	CALL	TNAREA		;LOCATE COBOL STRING PTR FOR THIS TRAN'S CONTEXT AREA
	MOVEM	S1,TP.HDP##	;PERMANIZE IT
	HRRZ	T1,1(S1)	;GET LENGTH IN BYTES
	MOVE	S1,(S1)		;GET BYTE PTR
	LDB	T3,[POINT 6,S1,11]	;BYTE SIZE
	MOVEI	T2,^D36		;GET READY TO COMPUTE SIZE OF H.D.
	IDIV	T2,T3		;=NUMBER OF BYTES IN WORD
	IDIV	T1,T2		;=SIZE IN WORDS OF H.D.
	SKIPE	T2		;REMAINDER?
	AOS	T1		;YES
	MOVEM	T1,TP.HDS##	;SAVE IT FOR LATER
SETTB:
	LOAD	TB,WH.TBO(VH)	;GET OFFSET OF TEXT BLK
	ADD	TB,VH		;SET UP TEXT PTR
	RETT
SUBTTL	SETSVH - SET UP VARIABLE HEADER FOR "SEND"

; SETSVH - SET UP THE VARIABLE HEADER IN THE COMM. PAGE FOR "SEND"
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE:	HEADER SET UP
;	FALSE:	ERROR DETECTED
;	S1 = ERROR CODE
;
SETSVH:
	MOVEI	S1,SZ%SWH	;AND SIZE OF SEND VARIABLE HEADER
	CALL	SETFH		;SET UP FIXED HEADER
	MOVE	S1,OO.CLS+OCDTAB	;GET PTR TO MESSAGE CLASS
	MOVEI	S2,WH.CLS(VH)	;GET ADDRESS OF MESSAGE CLASS IN PAGE
	HRLI	S2,(POINT CP%BSZ,0)	;FORM ASCII BYTE POINTER
	MOVEI	S3,OS.CLS	;LENGTH OF MESSAGE CLASS
	CALL	MOVTNF		;MOVE TEXT WITH NO FILL
	STOR	S1,WH.LMC(VH)	;STORE LENGTH OF MESSAGE CLASS
	CALL	STRDST		;STORE DESTINATION TABLE
	 JUMPF	RET.		;LEAVE ON ERROR
	CALL	SETADV		;SET UP ADVANCING ITEM
	 JUMPF	RET.		;EXIT NOW IF BAD ADVANCING ITEM
	RETT			;RETURN SUCCESS

; SETFH - SET UP FIXED HEADER FOR BOTH SEND AND RECEIVE
;
; CALL:
;	S1 = LENGTH OF WINDOW HEADER
;
; RETURN:
;	TRUE ALWAYS
;	VH = ADDRESS OF TOP OF COMMUNICATION PAGE (I.E., FIXED HEADER)
;	TB = ADDRESS WHERE TEXT BLOCK SHOULD BE (FOR RCV, IT'S IGNORED)
;
;
; NOTES:
; 1.	NOTE THAT THE AC "VH" ACTUALLY POINTS TO THE TOP OF
;	THE PAGE, NOT AT THE VARIABLE HEADER ITSELF.
;
SETFH:
	MOVE	VH,TP.CPP##	;GET POINTER TO COMM. PAGE
	STOR	S1,WH.TBO(VH)	;STORE AS OFFSET TO TEXT DATA
	MOVE	TB,S1		;SET UP PTR
	ADD	TB,VH		;TB NOW PTR RATHER THAN OFFSET
	RETT			;RETURN WITH NO VALUE
SUBTTL	SETCD - SET UP THE USER'S CD ON A "RECEIVE"

; SETUP - SET UP THE USER'S CD ON A "RECEIVE"
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<NO RETURN VALUES>
;
;
SETCD:
	MOVEI	S1,WH.SQ1(VH)	;ADDRESS OF SUB-QUEUE-1
	HRLI	S1,(POINT CP%BSZ,0)	;BYTE SIZE
	MOVE	S2,IO.SQ1+ICDTAB	;PTR TO SUB-QUEUE-1 ON PAGE
	LOAD	S3,WH.LQ1(VH)	;GET LENGTH OF SUB-QUEUE 1
	CALL	MOVTF		;MOVE TEXT AND SPACE FILL
	MOVEI	S1,WH.SQ2(VH)	;ADDRESS OF SUB-QUEUE-2
	HRLI	S1,(POINT CP%BSZ,0)	;BYTE SIZE
	MOVE	S2,IO.SQ2+ICDTAB	;PTR TO SUB-QUEUE-2 ON PAGE
	LOAD	S3,WH.LQ2(VH)	;GET LENGTH OF SUB-QUEUE 2
	CALL	MOVTF		;MOVE TEXT AND SPACE FILL
	CALL	SETSRC		;SET UP SYMBOLIC SOURCE IN CD
	CALL	DAYTIM		;CONVERT DATE AND TIME
	LOAD	T1,WH.QID(VH)	;GET QUEUE ID
	SKIPE	T2,TP.DVP##	;DISPATCH VARIABLE?
	MOVEM	T1,(T2)		;YES, STORE ID

	RETURN			;EXIT

; SETSRC - SET UP SYMBOLIC SOURCE FIELD IN INPUT CD
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<NO RETURN VALUE>
;
SETSRC:
	MOVEI	S1,WH.SRC(VH)	;ADDRESS OF SYMBOLIC SOURCE
	HRLI	S1,(POINT CP%BSZ,0)	;BYTE SIZE
	MOVE	S2,IO.SRC+ICDTAB	;PTR TO SOURCE ON PAGE
	LOAD	S3,WH.LSS(VH)	;GET LENGTH OF SYMBOLIC SOURCE
	CALL	MOVTF		;MOVE TEXT AND SPACE FILL
	RETT
SUBTTL	GETTXT - GET A FORM AND MOVE IT TO USER'S DATA ITEM

; GETTXT - GET A FORM FROM COMMUNICATION PAGE
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<NO RETURN VALUES>
;
GETTXT:
	$LOCALS	<RISIZE,RIPTR,FRMCTL>
	LOAD	T1,TB.EI(TB)	;GET END INDICATOR
	CAIE	T1,EI%EMI	;MUST BE EMI
	BUG	(EMI)		; **INTERNAL ERROR IF NOT
	ADDI	T1,"0"		;CONVERT TO ASCII
	MOVE	S1,IO.END+ICDTAB	;PTR TO END INDICATOR IN CD
	IDPB	T1,S1		;STORE IT IN CD
	CALL	MOVRHID		;MOVE HIDDEN DATA
	MOVEI	S1,WH.SQ2(VH)	;PTR TO FORM NAME
	CALL	FNAREA		;FIND FORM NAME IN TABLE
	MOVE	S2,(S2)		;GET ACTUAL AREA ADDRESS
	MOVEM	S2,FRMCTL	;SAVE CONTROL AREA PTR
	HRRZ	S2,1(S1)	;S2=SIZE OF RECEIVING ITEM
	MOVE	S1,(S1)		;S1=PTR TO RECEIVING ITEM
	MOVEM	S2,RISIZE	;SAVE SIZE OF RCV ITEM
	MOVEM	S1,RIPTR	;AND PTR TO RCV ITEM
	LOAD	T1,TB.LEN(TB)	;GET LENGTH OF FORM
	MOVE	T2,T1		;ASSUME FORM IS SMALLER THAN RCV ITEM
	CAME	T1,RISIZE	;ARE THEY SAME SIZE?
	JRST	[MOVE	S1,IO.STS+ICDTAB	;NO, MUST STORE ERROR CODE
		 MOVEI	S2,ER$CRL	;SIZE DESCREPANCY
		 CAML	T1,RISIZE	;WHICH IS SMALLER
		 MOVE	T2,RISIZE	;RECEIVING ITEM IS SMALLER
		 SAVE	<T2>		;SAVE T2 JUST IN CASE
		 CALL	STSKEY		;STORE NEW STATUS KEY
		 RESTOR	<T2>		;GET T2 BACK AGAIN
		 JRST	.+1]		;RETURN TO MAIN LINE

;CONTINUED ON NEXT PAGE...
;T2 = SMALLER SIZE OF RECEIVING ITEM OR FORM

	MOVE	S1,IO.LEN+ICDTAB	;PTR TO TEXT LENGTH FIELD IN CD
	MOVE	S2,T2		;GET SIZE TO OUTPUT
	MOVEI	S3,IS.LEN	;SIZE OF TEXT LENGTH FIELD
	CALL	PUTDEC		;OUTPUT NUMBER
	MOVE	S3,S2		;GET LENGTH OF STRING
	MOVEI	S1,TB.TXT(TB)	;PTR TO TEXT ON PAGE
	HRLI	S1,(POINT CP%BSZ,0)	;SET UP BYTE SIZE
	MOVE	S2,RIPTR	;GET RECEIVING ITEM POINTER
	CALL	CVTTXT		;CONVERT TEXT
	LOAD	T1,WH.VERS(VH)	;GET VERSION # OF INPUT FORM
	MOVE	T2,FRMCTL	;ADDR OF FORM CONTROL AREA
	CAMN	T1,FC.VER(T2)	;COMPARE VERSION NUMBERS
	RETURN			;YES	
	MOVE	S1,IO.STS+ICDTAB	;PTR TO STATUS KEY FIELD
	MOVEI	S2,ER$CRV	;VERSION DESCREPANCY
	CALL	STSKEY		;STORE IT
	RETURN
SUBTTL	CVTTXT - CONVERT FORM TEXT 

; CVTTXT - CONVERT FORM TEXT AND MOVE IT TO A DESTINATION
;
; CALL:
;	S1 = POINTER TO SOURCE STRING
;	S2 = POINTER TO DESTINATION STRING
;	S3 = LENGTH OF STRING TO MOVE
;
; RETURN:
;	TRUE ALWAYS
;
;
CVTTXT:
	JUMPE	S3,RETT.	;RETURN NOW IF NULL STRING
	LDB	T1,[POINT 6,S1,11]	;GET BYTE SIZE OF SOURCE ITEM
	LDB	T2,[POINT 6,S2,11]	;GET BYTE SIZE OF RCV ITEM
	CAIN	T1,^D9		;FOR EBCDIC, MAKE IT 8-BIT TO INDEX BETTER
	SUBI	T1,1		; INTO THE EXTEND TABLE BELOW
	SUBI	T1,6		;NORMALIZE
	SUBI	T2,6		;DO SAME WITH DESTINATION BYTE SIZE
	IMULI	T1,4		;FIND MAJOR OFFSET INTO TABLE
	ADDI	T1,CVTTAB(T2)	;FIND EXTEND INSTRUCTION IN TABLE
	SAVE	<T1>		;SAVE THIS ADDRESS
	MOVE	T1,S3		;GET LENGTH
	MOVE	T4,T1		;MAKE IT DEST LENGTH TOO
	TLO	T1,SIG.		;SET SIG FLAG
	MOVE	T2,S1		;GET SOURCE POINTER
	MOVE	T5,S2		;AND DESTINATION POINTER
	RESTOR	<S1>		;PUT ADDRESS IN S1
	EXTEND	T1,@S1		;MOVE THE STRING
	 RETF			;IT FAILED
	RETT			;SUCCESS
SUBTTL	CONVERSION TABLE FOR LIBOL ROUTINES


CVTTAB:
	MOVSO	0		;SIXBIT-SIXBIT
	MOVSO	40		;SIXBIT-ASCII
	Z			;8-BIT BYTES?
	MOVST	ALP.69##	;SIXBIT-EBCDIC
	MOVST	ALP.76##	;ASCII-SIXBIT
	MOVSO	0		;ASCII-ASCII
	Z			;8-BIT BYTES?
	MOVST	ALP.79##	;ASCII-EBCDIC
	MOVST	ALP.96##	;EBCDIC-SIXBIT
	MOVST	ALP.97##	;EBCDIC-ASCII
	Z			;8-BIT BYTES?
	MOVSO	0		;EBCDIC-EBCDIC
SUBTTL	MOVTNF - MOVE TEXT STRING WITH NO FILL

; MOVTNF - MOVE TEXT STRING WITH NO FILL
;
; CALL:
;	S1 = BYTE POINTER TO SOURCE
;	S2 = BYTE POINTER TO DEST
;	S3 = MAX NUMBER OF CHARS TO MOVE
;
; RETURN:
;	TRUE:	BYTE STRING MOVED SUCCESSFULLY
;		S1 = NUMBER OF CHARS ACTUALLY MOVED
;	FALSE:	A NULL OR SPACE WAS FOUND IN TEXT STRING
;		<T1-T5 INTACT FROM EXTEND INSTRUCTION>
;
MOVTNF:
	MOVE	T1,S3		; AND LENGTH
	TLO	T1,SIG.		;SET SIGNIFICANCE FLAG
	MOVE	T2,S1		;GET SOURCE POINTER
	MOVE	T5,S2		;GET DEST POINTER
	MOVE	T4,S3		; AND LENGTH
	MOVE	TF,[TRUE]	;ASSUME TRUE RETURN
	EXTEND	T1,[MOVST MOVTAB ;DO THE MOVE
			 Z
			 Z]
	 MOVE	TF,[FALSE]	;BAD RETURN
	MOVE	S1,S3		;GET STARTING MAX LENGTH
	SUB	S1,T4		;COMPUTE NUMBER OF BYTES MOVED
	RETURN			;RETURN CURRENT VALUE
SUBTTL	MOVTF - MOVE STRING WITH FILL


; MOVTF - MOVE TEXT WITH SPACE FILL (USED TO MOVE FROM COMM. PAGE TO CD)
;
; CALL:
;	<SAME INPUT ARGS AS MOVTNF>
;
; RETURN:
;	TRUE ALWAYS
;
; NOTES:
; 1.	THIS ROUTINE MOVES THE AMOUNT OF TEXT INDICATED BY
;	THE CONTENTS OF S3. IF A NULL IS ENCOUNTERED, THE
;	REST OF THE FIELD IS SPACE-FILLED
;
MOVTF:
	CALL	MOVTNF		;MOVE THE TEXT
				;T5 = UPDATED DESTINATION POINTER
	SUBI	S1,IS.QQ	;DID WE MOVE MAX SIZE?
	JUMPE	S1,RETT.	;YES
	SKIPL	S1		;DID WE MOVE MORE THAN MAX?
	  BUG	(EIF)		;YES...BUG
	MOVMS	S1		;=# OF CHARS LEFT TO FILL
	MOVEI	T1," "		;SPACE-FILL
	IDPB	T1,T5		;DEPOSIT SPACE
	SOJG	S1,.-1		;LOOP
	RETT			;OK
SUBTTL	SETTXT - SET UP THE TEXT BLOCK ON A SEND

; SETTXT - SET UP THE TEXT BLOCK ON A "SEND"
;
; CALL:
;	<NO EXPLICIT ARGS>
;
; RETURN:
;	TRUE ALWAYS
;
; NOTES:
; 1.	THIS ROUTINE CHECKS TO MAKE SURE THE TEXT LENGTH IS
;	NOT GREATER THAN THE SIZE OF THE SENDING ITEM.
;
SETTXT:
	MOVE	S1,TP.RG3##	;GET END INDICATOR
	CALL	GETDSC		;CONVERT IT TO BINARY
	STOR	S1,TB.EI(TB)	;STORE IN TEXT BLOCK
	MOVE	S1,OO.LEN+OCDTAB	;GET PTR TO TEXT LENGTH IN CD
	MOVEI	S2,OS.LEN	;AND SIZE OF TEXT LENGTH ITEM
	CALL	BINARY		;CONVERT TO BINARY
	 NOFAIL	(EIF)		;**SHOULD NOT FAIL
	SKIPN	TP.RG2##		;IF NO SENDING ITEM...
	SETZ	S1,		; ASSUME NO TEXT
	CAILE	S1,MX%TLEN	;DOES TEXT LEN FIT IN WINDOW?
	RETF	ER$TTL		;NO
	STOR	S1,TB.LEN(TB)	;STORE TEXT LENGTH IN TEXT BLOCK
SETHO:
	MOVEI	T3,AS%BPW-1(S1)	;S1=TEXT LEN, BPW-1 ACCTS FOR ROUNDING UP
	IDIVI	T3,AS%BPW	;CONVERT TO NUM WDS
	ADDI	T3,TB.TXT(TB)	;ACCT FOR HDR OF TEXT BLK & CONV TO ADDR
	SUB	T3,VH		;CONVERT TO OFFSET FROM TOP OF WINDOW
	MOVE	T2,TP.HDS##	;GET HID WORDS
	CAILE	T2,MX%WHID	;HID SIZE OK?
	RETF	ER$TTL		;NO, TOO MUCH HID TEXT
	ADD	T2,T3		;MERGE HID & TEXT LEN
	CAILE	T2,MX%WMAP	;DOES TEXT+HID FIT ON MAPPED PART?
	MOVEI	T3,MX%WMAP	;NO, ADJ HID OFFSET TO START OF UNMAPPED PART
	STOR	T3,WH.THO(VH)	;DONE
	MOVE	S3,S1		;MOVE TEXT LENGTH
	SKIPN	S1,TP.RG2##	;GET SENDING ITEM ARG IF ONE
	TDZA	T1,T1		;NONE, SO SET LEN TO 0
	HRRZ	T1,1(S1)	;GET ITS LENGTH
	CAMGE	T1,S3		;IS VAL OF TEXT LEN IN CD LE LEN OF "FROM" ITEM
	RETF	ER$BTL		;NO, ERROR EXIT
	JUMPLE	S3,RETT.	;RET IF NO "FROM" DATA
	MOVE	S1,(S1)		;GET ACTUAL BYTE POINTER
	MOVE	S2,[POINT CP%BSZ,0]	;FORM BYTE PTR TO TEXT BLOCK
	ADDI	S2,1(TB)	;FORM ADDRESS OF IT
	CALL	CVTTXT		;MOVE TEXT BLOCK ONTO PAGE
	 NOFAIL	(EIF)		;**SHOULD NOT FAIL
	RETT			;RETURN TRUE
SUBTTL	CKSERR - CHECK FOR ERRORS ON "SEND"

; CKSERR - CHECK FOR USER ERRORS ON A "SEND"
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE:	NO ERRORS FOUND
;
;	FALSE:
;	S1 = ASCII ERROR CODE FOR STATUS KEY
;
; NOTES:
; 1.	THIS ROUTINE ASSUMES THAT THE ENTIRE COMMUNICATION
;	PAGE HAS ALREADY BEEN CREATED. IT INSPECTS THE DATA
;	IN THIS PAGE (AS OPPOSED TO THE CD DATA) TO CHECK FOR
;	ERRORS.
;
; 2.	THE FOLLOWING ERRORS ARE CHECKED FOR:
;		A. END INDICATOR MUST BE EMI OR EGI
;
; 3.	****CURRENTLY, LEVEL 1 OF THE COBOL STANDARD DOES NOT
;	ALLOW THE "WITH <IDENTIFIER>" CLAUSE. THUS, IT IS
;	THEORETICALLY IMPOSSIBLE FOR THIS ROUTINE TO FAIL. HOWEVER,
;	THE ROUTINE IS LEFT INTACT FOR FUTURE EXPANSION.
;
;
CKSERR:

;1. CHECK END INDICATOR:
;
	LOAD	T1,TB.EI(TB)	;GET END INDICATOR FROM TEXT BLOCK
	CAIE	T1,EI%EMI		;IS IT AN EMI?
	CAIN	T1,EI%EGI		;OR EGI?
	SKIPA			;YES, ITS OK
	 BUG	(IRF)		;**SHOULD NOT FAIL

	RETT			;NO ERRORS FOUND
SUBTTL	OPEN THE COMMUNICATION FILE

; OPENCF - OPEN AND MAP THE COMMUNICATION FILE
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE:	FILE OPENED
;	FALSE:	FILE CAN'T BE OPENED, ERROR MESSAGE PRINTED
;
OPENCF:
	$LOCALS	<CPWIND>
	MOVE	1,[GJ%OLD+GJ%SHT+GJ%DEL]	;SET UP JFN BITS
	HRROI	2,TP.PKT##+PK.CFN	;PTR TO FILE NAME
	GTJFN			;GET A JFN
	 ERR	MSGCGJ,RETF.	;CANT GET A JFN
	MOVEM	1,TP.JFN##	;SAVE THE JFN
	MOVEI	2,OF%RD+OF%WR+OF%THW	;OPEN BITS
	HRLI	2,440000	;BYTE SIZE
	OPENF			;OPEN THE COMMUNICATION FILE
	 ERR	MSGCOF,RETF.	;CANT OPEN FILE
	MOVE	S1,TP.WNS##	;GET SIZE OF PARTITION 
	CALL	GETPGS		;GET SOME PAGES FOR IT
	 NOFAIL	(NOC)		;**SHOULD NOT FAIL
	MOVEM	S1,TP.CPP##	;SAVE AS POINTER
	LSH	S1,W2PLSH	;MAKE INTO AN ADDRESS
	MOVEM	S1,CPWIND	;SAVE WINDOW POINTER
	MOVEI	S1,PN%ADIR	;SIZE OF COMMUNICATION REGION
	CALL	GETPGS		;GET SOME PAGES
	 NOFAIL	(NOC)		;**SHOULD NOT FAIL
	MOVEM	S1,TP.CRP##	;SAVE AS POINTER
	LSH	S1,W2PLSH	;ROTATE
	HRLZ	1,TP.JFN##	;GET JFN FOR FILE
	HRRI	1,PG%ADIR	;PAGE NUMBER OF COMM REGION
	HRLI	2,.FHSLF	;THIS FORK
	HRR	2,S1		;PAGE NUMBER TO MAP INTO
	MOVE	3,[PM%RD+PM%WR]	;READ/WRITE ACCESS TO PAGE
	PMAP			;MAP THE COMMUNICATION REGION
	ERCAL	JERROR		;SHOULD NOT FAIL
	HRR	1,TP.IPC##	;GET FILE PAGE NUMBER OF PARTITION
	HRR	2,CPWIND	;PAGE TO MAP INTO
	MOVE	3,[PM%CNT+PM%RD+PM%WT]	;PMAP BITS
	HRR	3,TP.WNS##	;SIZE OF PARTITION
	PMAP			;MAP FILE PARTITION INTO MY SPACE
	ERCAL	JERROR		;SHOULD NOT FAIL
	RETT
SUBTTL	POST - POST A SERVICE REQUEST FOR TCSCON

; POST - POST A SERVICE REQUEST FOR TCSCON
;
; CALL:
;	S1 = FUNCTION CODE TO STORE IN DIRECTORY PAGE
;
; RETURN:
;	TRUE ALWAYS
;
; NOTES:
; 1.	THIS ROUTINE COMMUNICATES WITH TCSCON VIA THE
;	COMMUNICATION FILE. THIS ROUTINE IS CALLED ONLY
;	AFTER THE PARTITION BELONGING TO THIS PROCESS HAS
;	BEEN COMPLETELY INITIALIZED WITH DATA. THEN, THIS
;	ROUTINE MUST DO THE FOLLOWING:
;
;	A) STORE THE FUNCTION CODE IN THE PROPER DIRECTORY OFFSET
;	B) INCREMENT THE REQUEST COUNT IN THE COMMUNICATION REGION.
;	C) IF THE COUNT IS NOW 1, GENERATE AN IPCF MESSAGE TO
;		TCSCON FOR SERVICE
;	D) RETURN TO WAIT FOR A RESPONSE
;
;
POST:
	MOVE	T1,TP.CRP##	;GET PTR TO DIRECTORY PAGE
	MOVE	T2,TP.ID##	;GET PROGRAM ID OF THIS PROCESS
	ADD	T2,T1		;FORM ADDRESS OF RIGHT WORD
	STOR	S1,AD.AEC(T2)	;STORE FUNCTION CODE

;NOW, INCREMENT THE REQUEST COUNT:
	AOS	T1,CR.CNT(T1)	;BUMP THE COUNT
	CAIG	T1,1		;AM I THE FIRST TO DO SO?
	CALL	WAKTCS		;YES, WAKE TCSCON UP
	RETT			;NO, JUST GO AWAY
SUBTTL	WAKTCS - WAKE UP TCS FOR A REQUEST

; WAKTCS - WAKE UP TCS TO PERFORM SOME ACTION
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE ALWAYS
;
WAKTCS:
	MOVEI	S1,TP.PKT##	;ZERO LENGTH!!
	MOVE	S2,TP.LPD##	;MY PID
	MOVE	S3,TP.TPD##	;HIS PID
	CALL	IPSEND		;SEND MSG TO TCS
	RETURN
SUBTTL	WAIT - WAIT FOR RESPONSE FROM TCS

; WAIT - WAIT FOR RESPONSE
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<NO RETURN VALUES>
;
WAIT:
	MOVE	S1,[TP.PKS##,,TP.PKT##]	;WAIT FOR RESPONSE
	CALL	IPRECV		;RECEIVE A PACKET
	 JUMPF	INFOER		;UNEXPECTED ERROR
	RETT
SUBTTL	DAYTIM - CONVERT DATE/TIME FOR INPUT CD

; DAYTIM - CONVERT TCS-20 FORM TIME STAMP AND MOVE TO INPUT CD
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<NO RETURN VALUES>
;
;
DAYTIM:
	$LOCALS	<YEAR,MONTH,DAY,SECONDS>
	MOVE	2,WH.DAT(VH)	;GET TIME STAMP
	SETZ	4,		;NO FLAGS
	ODCNV			;PARSE EACH PORTION OF IT
	HLRZM	2,YEAR		;SAVE EACH PIECE
	HRRZM	2,MONTH		;...
	HLRZM	3,DAY		;...
	HRRZM	4,SECONDS	;...
	MOVE	S1,IO.DAT+ICDTAB	;PTR TO DATE FIELD IN CD
	MOVE	S2,YEAR		;GET YEAR
	IDIVI	S2,^D100	;OFFSET INTO CENTURY
	MOVE	S2,S3		;GET REMAINDER
	IMULI	S2,^D<10000>	;ADJUST IT
	MOVE	T1,MONTH	;GET MONTH
	ADDI	T1,1		;MAKE JANUARY=1
	IMULI	T1,^D<100>	;ADJUST IT
	ADDI	S2,(T1)		;ADD IT IN
	ADD	S2,DAY		;ADD DAY VALUE IN
	ADDI	S2,1		;MAKE FIRST DAY=1
	MOVEI	S3,IS.DAT	;SIZE OF FIELD (=6)
	CALL	PUTDEC		;OUTPUT AS DECIMAL NUMBER

;NOW, WE MUST TAKE THE TIME STAMP OF THE FORM AND MOVE IT TOO.
; THE RESOLUTION OF THE GTAD JSYS IS APPROXIMATELY
; 1/3 OF A SECOND.

	MOVE	T1,SECONDS	;GET # OF SECS SINCE MIDNIGHT
	IDIVI	T1,^D<60*60>	;FIND NUMBER OF HOURS
	IMUL	T1,[^D<1000000>]	;MOVE TO HOURS FIELD
	MOVE	S2,T1		;START ACCUMULATING TOTAL
	MOVE	T1,T2		;GET REMAINDER
	IDIVI	T1,^D60		;FIND NUMBER OF MINUTES IN THIS HOUR
	IMULI	T1,^D<10000>	;ADJUST IT TO CORRECT POSITION
	ADD	S2,T1		;ADD INTO TOTAL
	IMULI	T2,^D<100>	;ADJUST SECONDS
	ADD	S2,T2		;STORE SECONDS IN TOTAL 
	MOVEI	S3,IS.TIM	;SIZE OF TIME FIELD
	MOVE	S1,IO.TIM+ICDTAB	;PTR TO TIME FIELD
	CALL	PUTDEC		;OUTPUT NUMBER
	RETURN
SUBTTL	SNDSTS - SET UP THE USER STATUS CODE 

; SNDSTS - SET UP THE USER STATUS CODE IN THE CD
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE ALWAYS
;
; NOTES:
; 1.	THIS ROUTINE ASSUMES THAT ONLY 1 DESTINATION IS POSSIBLE
;	BECAUSE IT DEPOSITS DIRECTLY INTO THE ERROR KEY FIELD
;	WITHOUT COMPUTING THE OFFSET AFTER THE DESTINATION TABLE.
SNDSTS:
	MOVE	T1,TP.CPP##	;GET PTR TO PARTITION PAGE
	LOAD	T1,WH.STS(T1)	;GET STATUS CODE RETURNED
	HRRE	T1,T1		;EXTEND SIGN ACROSS
	CAILE	T1,MX%TS	;IS IT WITHIN LIMITS?
	 BUG	(STS)		;NO, TCSCON BUG
	LOAD	S2,ST.SKY+STTAB(T1)	;GET STATUS KEY
	JUMPE	S2,SYSERR	;NO MAPPING MEANS SYS ERROR
	MOVE	S1,OO.STS+OCDTAB	;GET PTR TO STATUS LEY
	CALL	STSKEY		;STORE STATUS KEY
	MOVEI	T1,"0"		;ASSUME 0 GOES INTO ERROR KEY
	CAIN	S2,ER$BDE	;DESTINATION DISABLED?
	MOVEI	T1,"1"		;YES, SET UP ERROR KEY AS 1
	MOVE	S1,OO.KEY+OCDTAB	;GET PTR TO ERROR KEY
	IDPB	T1,S1		;STORE ERROR KEY BYTE
	RETT			;RETURN OK
SUBTTL	RCVSTS - STORE STATUS KEY VALUE FOR RECEIVE

; RCVSTS - STORE STATUS KEY VALUE IN USER'S INPUT CD FOR "RECEIVE"
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE: OPERATION WAS A SUCCESS
;	FALSE: TCSCON RETURNED AN ERROR CODE
;
; NOTES:
;
; 1.	F.EMPT MAY BE SET IF TCSCON RETURNED "TS%FQE".
;
RCVSTS:
	MOVE	T1,TP.CPP##	;GET PTR TO PARTITION PAGE
	LOAD	T1,WH.STS(T1)	;GET STATUS CODE
	CAILE	T1,MX%TS	;LESS THAN MAXIMUM VALUE?
	 BUG	(STS)		;BAD STATUS CODE
	ADDI	T1,STTAB	;ADD START OF TABLE
	LOAD	S2,ST.SKY(T1)	;GET STATUS KEY VALUE
	JUMPE	S2,SYSERR	;IF NO MAPPING, GIVE ERROR MSG
	MOVE	S1,IO.STS+ICDTAB	;GET PTR TO STATUS KEY FIELD
	CALL	STSKEY		;STORE VALUE
	MOVE	T1,TP.CPP##	;GET POINTER TO COMMUNICATION PAGE
	LOAD	T1,WH.STS(T1)	;GET STATUS CODE AGAIN
	CAIN	T1,TS%ABO	;WAS IT THE ABORT KEY?
	JRST	[CALL SETSRC	;YES, SET UP SYMBOLIC SOURCE
		 RETF]		;AND GIVE FALSE RETURN
	CAIN	T1,TS%FQE	;WAS IT "FORM Q EMPTY"?
	JRST	EMPTY		;YES, DO SPECIAL STUFF
	CAIE	T1,TS%AOK	;IS IT "OPERATION OK"?
	RETF			;NO, GIVE BAD RETURN VALUE
	RETT			;YES

;COME HERE TO SET UP OTHER CD FIELDS IF QUEUE IS EMPTY
EMPTY:	TXO	FG,F.EMPT	;REMEMBER THIS CONDITION
	MOVE	S1,IO.LEN+ICDTAB	;PTR TO TEXT LENGTH FIELD
	MOVEI	S2,0		;STORE 0 IN IT
	MOVEI	S3,IS.LEN	;SIZE OF FIELD
	CALL	PUTDEC		;OUTPUT NUMBER
	MOVE	S1,IO.CNT+ICDTAB	;FORM COUNT FIELD
	MOVEI	S3,IS.CNT	;SIZE OF FIELD
	CALL	PUTDEC		;OUTPUT ZERO (STILL IN S2)
	RETF			;GIVE BAD RETURN
SUBTTL	STRDST - STORE DESTINATION TABLE FOR "SEND"

; STRDST - STORE DESTINATION TABLE
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	TRUE:
;		NO ERROR DETECTED
;	FALSE:
;		S1 = ERROR CODE FOR STATUS KEY
;
; NOTES:
; 1.	THIS ROUTINE MOVES THE DESTINATION TABLE FROM THE
;	USER'S OUTPUT CD INTO THE COMMUNICATION AREA. IT 
;	ALSO CHECKS THAT THE DESTINATION COUNT IS 1. IF SO,
;	IT RETURNS AN ERROR CODE TO THAT EFFECT.
;
;
STRDST:
	MOVE	S1,OO.DCT+OCDTAB	;GET PTR TO DEST COUNT
	MOVEI	S2,OS.DCT	;AND SIZE
	CALL	BINARY		;CONVERT TO BINARY
	SKIPN	S1		;IF ZERO,
	MOVEI	S1,1		;MAKE IT 1
	CAIE	S1,1		;IS IT 1?
	RETF	ER$BDC		;NO, RETURN ERROR
	STOR	S1,WH.DCT(VH)	;STORE IN VARIABLE HEADER
	MOVE	S1,OO.DST+OCDTAB	;GET PTR TO DEST STRING
	MOVEI	S2,WH.DST(VH)	;GET ADDRESS OF DEST
	HRLI	S2,(POINT CP%BSZ,0)	;FORM BYTE POINTER
	MOVEI	S3,OS.DST	;SIZE OF DESTINATION FIELD
	CALL	MOVTNF		;MOVE DESTINATION STRING ONTO PAGE
	MOVEI	S2,WH.DST(VH)	;GET PTR TO DEST TABLE
	STOR	S1,DE.NLEN(S2)	;STORE LENGTH OF THIS ENTRY
	RETT			;EXIT OK
SUBTTL	SETADV - SET UP THE ADVANCING ITEM ON A "SEND"

; SETADV - SET UP THE ADVANCING ITEM ON A "SEND"
;
; CALL:
;	<NO INPUT ARGS>
;	
; RETURN:
;	TRUE:
;		ADVANCING ITEM SET UP
;	FALSE:
;		S1 = ASCII ERROR CODE FOR STATUS KEY (ER$BAI)
;
;
SETADV:
	$LOCALS	<CCOUNT,ACHAR>	;DEFINE LOCAL STORAGE

;SET UP THE FOLLOWING DEFAULTS FOR LATER PROCESSING:
;	CHARACTER COUNT = 1
;	ADVANCING ITEM = LF
	MOVEI	T1,LF		;GET DEFAULT ITEM
	MOVEM	T1,ACHAR	;STORE IT AWAY	
	MOVEI	T1,1		;1 CHAR
	MOVEM	T1,CCOUNT	;SAVE IT

;CHECK IF THERE IS AN ADV. ITEM AND A SENDING ITEM...
	MOVE	S1,TP.RG4##	;GET ADVANCING ITEM
	JUMPN	S1,ADV0		;JUMP IF THERE IS ONE
	MOVE	T1,TP.RG2##	;IS THERE A SENDING ITEM?
	JUMPE	T1,ADVXIT	;NO
	MOVE	T1,1(T1)	;GET SENDING ITEM SIZE
	JUMPE	T1,ADVXIT	;LEAVE IS SIZE=0

;WE NOW HAVE THE FOLLOWING SITUATION:
;	NO ADVANCING ITEM
;	"FROM" PHRASE WAS SPECIFIED
;	TEXT LENGTH IS GREATER THAN ZERO
;SO, USE ADVANCING 1 LINE
	JRST	ADV1CH		;GO ON

	;SETADV IS CONINUED ON NEXT PAGE...
;COME HERE IF WE HAVE AN ADVANCING ITEM
ADV0:
	TLNN	S1,-1		;IS IT PAGE OR MNEMONIC?
	JRST	[HLRZ	T1,(S1)		;YES, GET CHARACTER
		 MOVE	T1,CHNTAB-1(T1)	;FROM TABLE
		 MOVEM	T1,ACHAR	;SAVE IT
		 JRST	ADV1CH]		; AND GO ON

;THIS IS NOT A PAGE OR MNEMONIC PHRASE...
	CALL	GETDSC		;CONVERT ARG TO BINARY
	SKIPGE	S1		;ADVANCING ITEM MUST BE POSITIVE
	RETF	ER$BAI		;**ERROR EXIT
	MOVEM	S1,CCOUNT	;CHARACTER COUNT
	JRST	ADVXIT		;GO SET UP ADVANCING DESCRIPTOR

;COME HERE TO SET THE CHAR COUNT TO 1
ADV1CH:	SKIPA	T1,[1]		;SET COUNT TO 1

;COME HERE TO STORE ADVANCING DESCRIPTOR
ADVXIT:	MOVE	T1,CCOUNT	;GET CHAR COUNT
	MOVE	T2,TP.RG5##	;GET BEFORE/AFTER FLAG
	SKIPN	(T2)		;SKIP IF AFTER
	MOVNS	T1		;MAKE COUNT NEGATIVE
	HRL	T1,ACHAR	;GET ADVANCING CHAR
	MOVSM	T1,WH.ADV(VH)	;STORE IN HEADER
	RETT			;RETURN OK

;CHANNEL TABLE FOR ADVANCING TABLE (INDEXED BY CHANNEL NUMBER)
;
DEFINE ACHAR(CHAR),<
	IRP CHAR,<EXP	CHAR>
>
CHNTAB:	ACHAR	<FF,DLE,DC1,DC2,DC3,DC4,VT,FF>
SUBTTL	ROUTINES TO SEND AND RECEIVE IPCF PACKETS

; IPRECV - RECEIVE A PACKET FROM TCS
;
; CALL:
;	S1 = LENGTH OF BUFFER,,ADDRESS OF BUFFER
;
; RETURN:
;	TRUE:	PACKET IS IN BUFFER
;	FALSE:	RECEIVE FAILED
;
IPRECV:
	MOVEI	2,TP.PDB##	;GET ADDRESS OF PACKET DESC BLOCK
	SETZM	.IPCFL(2)	;CLEAR FLAGS
	SETOM	.IPCFR(T2)	;USE ANY PID I GOT
	MOVEM	S1,.IPCFP(T2)	;SET UP BUFFER ADDRESS
	MOVEI	1,TP.PDS##	;SIZE OF PDB
	MRECV			;GET THE PACKET
	 JSYSF			;COULDN'T
	MOVE	T1,TP.PDB##+.IPCFL	;GET FLAGS
	ANDI	T1,IP%CFE	;LEAVE STATUS CODE
	LSH	T1,-6		;MOVE TO RIGHT
	JUMPE	T1,RETT.	;LEAVE IF OK
	CAIE	T1,.IPCNN	;UNKNOWN NAME AND
	CAIN	T1,.IPCEN	;..AND INVALID NAME ARE REASONABLE ERRORS
	RETF			;SO WE WILL EXIT
	CAIN	T1,.IPCDN	;..AND DUP NAME IS ALSO OK
	RETF			;SO WE WILL EXIT
	MOVE	S1,T1		;MOVE ARGUMENT
	JRST	INFOER		;PRINT INFO ERROR MESSAGE
; IPSEND - SEND A PACKET TO EITHER TCSCON OR <SYSTEM>INFO
;
; CALL:
;	S1 = LENGTH,,PACKET ADDRESS
;	S2 = SENDER'S PID (0 MEANS GET ME A PID)
;	S3 = RECEIVER'S PID (0 MEANS SEND TO INFO)
;
; RETURN:
;	TRUE ALWAYS
;	S2 = SENDER'S PID
;
IPSEND:
	SETZ	T1,		;ASSUME NO FLAGS
	SKIPN	S2		;DO I NEED A PID?
	MOVE	T1,[IP%CPD]	;YES, RETURN A PID FOR ME
	MOVEM	T1,TP.PDB##+.IPCFL	;STORE IN PDB
	MOVEM	S2,TP.PDB##+.IPCFS	;STORE MY PID
	MOVEM	S3,TP.PDB##+.IPCFR	;HIS PID
	MOVEM	S1,TP.PDB##+.IPCFP	;FLAGS
	MOVEI	1,TP.PDS##	;GET SIZE OF PDB
	MOVEI	2,TP.PDB##	;AND ADDRESS
	MSEND			;SEND THE PACKET
	 JSYSF
	MOVE	S2,TP.PDB##+.IPCFS	;RESTORE SENDER'S PID
	RETT
SUBTTL	HISPID - GET A PID FOR TCSCON

; HISPID - GET A PID FOR THE CONTROLLER
;
; CALL:
;	<NO INPUT ARGS>
; 
; RETURN:
;	TRUE:	TCS PID IS IN TP.TPD
;		LCM PID IS IN TP.LPD
;	FALSE:	INCORRECT TCS NAME TYPED BY USER
;		AN ERROR MESSAGE WILL BE PRINTED 
;
; NOTES:
; 1.	ON ENTRY, THE TCS SYSTEM NAME IS IN TP.NAM##
;
HISPID:
	MOVEI	T1,.IPCIW	;FUNCTION CODE
	MOVEM	T1,TP.PKT##	;STORE IN PACKET
	SETZM	TP.PKT##+1	;
	MOVE	S2,TP.LPD##	;GET PID OF LCM
	SETZ	S3,		;NO RECEIVER PID
	MOVE	S1,[IP%PDS+2,,TP.PKT##]	;PACKET CONTAINS TP.NAM
	CALL	IPSEND		;SEND MESSAGE TO INFO
	MOVEM	S2,TP.LPD##	;RESTORE OUR PID
	CALL	IPRECV		;RECEIVE THE REPLY
	JUMPF	[TMSG <?LCM - >
		HRROI	T1,TP.NAM##	;PRINT NAME OF SYSTEM
		PSOUT			;...
		TMSG	< SYSTEM NOT RUNNING...CANNOT CONTINUE>
		 RETF]
	MOVE	T1,TP.PKT##+.IPCI1	;GET HIS PID
	MOVEM	T1,TP.TPD##	;SAVE IT
	RETT
SUBTTL	GETDSC - ROUTINES TO CONVERT INPUT ARGUMENTS

; GETDSC - CONVERT EITHER TP.RG3 OR TP.RG4 TO BINARY FORMAT
;
; CALL:
;	S1 = ARGUMENT TO CONVERT
;
; RETURN:
;	TRUE:
;		S1 = NUMERIC VALUE OF ARG
;	FALSE:
;		CONVERSION FAILED
;
; NOTES:
; 1.	THE ARGUMENT WHICH IS PASSED TO THIS ROUTINE IS THE
;	ACTUAL COMPILER ARGUMENT - E.G. 640,[POINT 7,CD],
;	100,[EXP I], ETC.
;
; 2.	IF A 2-WORD COMP ITEM HAS A NON-ZERO HIGH ORDER VALUE,
;	THEN THE RETURN VALUE IS -1. THIS IS BECAUSE SUCH A HIGH
;	NUMBER WOULD BE AN ERROR FOR ANY NUMERIC VALUE SUPPORED
;	BY LCM.
;
;
GETDSC:
	SKIPN	S1		;IS INPUT ARG OK?
	 BUG	(BIA)		;NO
	HLRZ	T1,S1		;GET DATA-TYPE
	CAIN	T1,100		;1-WORD COMP?
	JRST	[MOVE	S1,(S1)		;YES. GET VALUE
		 RETT]			;AND RETURN
	CAIN	T1,440		;2-WORD COMP?
	JRST	[SKIPE	(S1)		;YES, IS HIGH ORDER 0?
		 SKIPA	S1,[-1]		;NO, RETURN -1
		 MOVE	S1,1(S1)	;YES, GET LOW ORDER VALUE
		 RETT]			; AND RETURN

;WE NOW KNOW THAT THE ITEM IS A DISPLAY...
	CAIE	T1,640		;MAKE SURE
	 BUG	(BIA)		;BAD INPUT ARGUMENT BUG
	MOVE	S2,1(S1)	;GET LENGTH OF ITEM
	MOVE	S1,(S1)		;AND PTR TO STRING
	CALL	BINARY		;CONVERT
	RETURN			;RETURN THAT VALUE
SUBTTL	MISCELLAENOUS ROUTINES (ARRANGED ALPHABETICALLY)

;BINARY - CONVERT DISPLAY STRING TO BINARY VALUE
;
; CALL:
;	S1 = BYTE POINTER TO NUMERIC STRING
;	S2 = LENGTH OF STRING
;
; RETURN:
;	S1 = BINARY VALUE
;
;
BINARY:
	SKIPN	S2		;IS LENGTH OK?
	 BUG	(BIA)		;NO, INTERNAL ERROR
	PUSH	PP,VH		;SAVE VH
	PUSH	PP,TB		;SAVE TB
	PUSH	PP,CD		;SAVE CD
	MOVE	T1,S1		;GET BYTE PTR
	TLZ	T1,7777		;CLEAR BYTE SIZE
	TLO	T1,(S2)		;MOVE STRING SIZE INTO AC
	TLO	T1,(1B6)	;SET SIGNED BIT
	HRRI	T1,@S1		;ADJUST FOR INDEXING OFF OF "CD"
	MOVEM	T1,TP.TMP##	;STORE IN TEMP LOC
	LDB	T2,[POINT 6,S1,11]	;GET BYTE SIZE
	SUBI	T2,6		;NORMALIZE TO 0 FOR SIXBIT
	MOVE	AP,[Z S1,TP.TMP##]	;S1 IS RETURN AC, INPUT AC IS T1
	XCT	[CALL	GD6.##	;FOR SIXBIT
		 CALL	GD7.##	;ASCII
		 BUG	(BIA)		;8-BIT BYTES?
		 CALL	GD9.##](T2)	;EBCDIC
	POP	PP,CD		;COME BACK HERE
	POP	PP,TB
	POP	PP,VH

;WE HAVE NOW DONE THE CONVERSION, RESULT IS IN S1
	RETT
; DEATH - SET UP THE DEATH NOTICE FOR IPCF
;
; CALL:
;	<NO INPUT ARGS>
;
; RETURN:
;	<NO RETURN VALUES>
;
; NOTES:
; 1.	THIS ROUTINE IS CALLED DURING LCM INITIALIZATION. IT
;	CALLS IPCF AND INFORMS THE MONITOR THAT WHEN THIS
;	PROCESS DIES, TCSCON SHOULD GET A DEATH NOTICE
;
DEATH:
	MOVEI	T1,3		;LENGTH OF BLOCK
	MOVEI	T2,T3		;PTR TO BLOCK
	MOVEI	T3,.MUSKP	;FUNCTION CODE
	MOVE	T4,TP.LPD##	;MY PID
	MOVE	T5,TP.TPD##	;HIS PID
	MUTIL
	  JSYSF			;SHOULD NOT FAIL
	RETT
; FNAREA - LOCATE FORM AREA BY NAME
; TNAREA - LOCATE TRANSACTION CONTEXT AREA BY NAME
;
; CALL:
;	S1 = ADDRESS OF FORM/TRANS NAME TEXT
;
; RETURNS:
;	TRUE:	FORM FOUND IN FORM BIND TABLE
;		S1 = ADDRESS OF FORM/TRANS AREA DESCRIPTOR
;		S2 = ADDRESS OF FORM CONTROL DESCRIPTOR (0 FOR TRANS)
;		NOTE THAT THESE ADDRESSES ARE THE ACTUAL DESCRIPTOR
;		PUT OUT BY THE COMPILER, NOT THE ADDRESS OF THE FORM
;		AREAS.
;	FALSE:	NOT FOUND
;
FNAREA:	TDZA	T3,T3			;FORM MODE
TNAREA:	SETOM	T3		;INDIC TRANS MODE
	MOVE	T1,TP.BTP##	;PTR TO TABLE
	HRRO	T2,S1		;PTR TO NAME
	TBLUK	
	TDNN	T2,[TL%EXM]	;EXACT MATCH FOUND?
	ERR	MSGNNF,STOPR.##	;NO, NOT FOUND
	MOVE	T2,TP.BTP##	;GET START OF TABLE
	SUB	T1,T2		;=OFFSET INTO TOP HALF
	ADD	T2,(T2)		;=MIDDLE OF BLOCK
	ADDI	T1,1(T2)	;=CORRES. ENTRY IN BOTTOM
	LOAD	S1,FT.FRM(T1)	;FORM AREA
	LOAD	S2,FT.CTL(T1)	;FORM CONTROL AREA
	JUMPE	S2,[JUMPL T3,RETT.] ;TRAN-MODE MEANS NO FORM CTL
	JUMPN	S2,[JUMPE T3,RETT.] ;FORM-MODE REQS FORM CTL
	ERR	MSGNNF,STOPR.##	;WRONG TYPE OF NAME FND

; PUTDEC - OUTPUT A DECIMAL NUMBER
;
; CALL:
;	S1 = BYTE POINTER TO DEST
;	S2 = NUMBER TO OUTPUT
;	S3 = SIZE OF FIELD
;
; RETURN:
;	TRUE:
;	S1 = UPDATED BYTE POINTER
;	S2 = <UNCHANGED>
;	S3 = <UNCHANGED>
;
; NOTES:
; 1.	THIS ROUTINE IS A PRIME CANDIDATE FOR OPTIMIZATION
;
PUTDEC:

	CAILE	S3,IS.TIM	;MESSAGE TIME IS MAX LENGTH CURRENTLY
	BUG 	(FTB)		;**BUG HERE
	MOVE	T2,S2		;GET NUMBER
PUT2:	IDIV	T2,DIVTAB(S3)	;DIVIDE CURRENT RESULT
	ADDI	T2,"0"		;CONVERT TO ASCII NUMBER
	IDPB	T2,S1		;STORE IN DESTINATION
	MOVE	T2,T3		;GET REMAINDER
	SOJG	S3,PUT2		;LOOP OVER
	RETT			;GOOD RETURN

;TABLE OF DIVISORS FOR NUMERIC OUTPUT
DIVTAB:	Z			;UNUSED
	^D1
	^D10
	^D100
	^D1000
	^D10000
	^D100000
	^D1000000
	^D10000000
; MOVHID - MOVE HIDDEN DATA TO/FROM THE COMMUNICATION PAGE
;
; CALL:
; RETURN:
;	<NO RETURN VALUES>
;
MOVSHID:
	LOAD	T2,TB.EI(TB)	;GET END INDICATOR
	MOVE	T1,TP.HDS##	;AMT OF TR HID DATA, IF APPLIES
	CAIE	T2,EI%EMI	;COP HID DATA ONLY IF EMI
	SETZM	T1		;NOT COPYING HID DATA
	STOR	T1,TB.WHID(TB)	;INSURE UP TO DATE
	JRST	MOVHID		;MERGE
MOVRHID:
	LOAD	T1,TB.WHID(TB)	;IS THERE HIDDEN DATA?
MOVHID:
	JUMPE	T1,RETT.	;NO
	MOVE	T5,TP.CPP##	;PTR TO COMM PAGE
	LOAD	T1,WH.THO(T5)	;GET ITS OFFSET
	ADD	T5,T1		;=PTR TO TEXT BLOCK
	MOVE	S1,TP.HDP##	;PTR TO HIDDEN DATA STRING PTR
	HRL	T5,0(S1)	;PUT COBOL ADDR OF HID-DATA IN BLT REG
	TSWT	F.SEND		;IS IT SEND (COBOL TO CPP)?
	MOVSS	T5		;NO, FLIP SOURCE AND DEST
	HRRZ	T1,T5		;ISOL DEST
	ADD	T1,TP.HDS##	;COMPUTE 1 PAST END OF DEST
	BLT	T5,-1(T1)	;COPY THE HID DATA
	RETT
SUBTTL	INTERFACE TO LIBOL FUNCTION ROUTINES

; GETPGS - ALLOCATE A VARIABLE NUMBER OF CORE PAGES FROM LIBOL
;
; CALL:
;	S1 = NUMBER OF PAGES TO ALLOCATE
;
; RETURN
;	TRUE:
;	S1 = ADDRESS OF PARTITION
;
GETPGS:
	MOVEI	T1,LF%PAG	;PAGE FUNCTION
	LSH	S1,P2WLSH	;CONVERT INTO WORDS
	MOVE	S2,S1		;USE AS ARG 2
	JRST	DOFUN		;CONTINUE

; GETCOR - ALLOCATE DYNAMIC MEMORY
;	S1 = SIZE TO ALLOCATE
;
; RETURN:
;	S1 = ADDRESS
;	S2 = SIZE (COPY OF S1 ON INPUT)
GETCOR:	MOVE	S2,S1		;MOVE TO ARG 2
	MOVEI	T1,LF%GOT	;GET FUNCTION CODE
	JRST	DOFUN		;CONTINUE...

; RELCOR - RELEASE CORE
;	S1 = ADDRESS
;	S2 = SIZE
RELCOR:	MOVEI	T1,LF%RAD	;FUNCTION CODE

DOFUN:	MOVEM	T1,FUN.A0##	;STORE FUNCTION
	MOVEM	S1,FUN.A1##	;FIRST ARG
	MOVEM	S2,FUN.A2##	;SECOND ARG
	MOVEI	AP,1+[-5,,0
		Z	TP%INT,FUN.A0##
		Z	TP%LIT,[ASCIZ /LCM/]
		Z	TP%INT,FUN.ST##
		Z	TP%INT,FUN.A1##
		Z	TP%INT,FUN.A2##]
	CALL	FUNCT.##	;GET THE PAGES
	SKIPE	FUN.ST##	;DID WE GET THEM?
	RETF			;NO
	MOVE	S1,FUN.A1##	;GET STARTING ADDRESS
	MOVE	S2,FUN.A2##	;GET SECOND ARG
	RETT
SUBTTL	STSKEY - STORE A VALUE IN USER'S CD STATUS KEY

; STSKEY - STORE A VALUE IN THE USER'S CD STATUS KEY FIELD
;
; CALL:
;	S1 = POINTER TO STATUS KEY FIELD
;	S2 = ASCII VALUE TO STORE IN FIELD
;
; RETURN:
;	<NO RETURN VALUE>
;
STSKEY:
	LDB	T1,[POINT 7,S2,28]	;GET FIRST DIGIT
	IDPB	T1,S1		;STORE IT
	LDB	T1,[POINT 7,S2,35]	;GET SECOND DIGIT
	IDPB	T1,S1		;STORE IT
	RETURN
SUBTTL	COMMON EXIT ROUTINES
;
RETT.:	SKIPA	TF,[TRUE]	;RETURN TRUE
RETF.:	MOVE	TF,[FALSE]	;RETURN FALSE
RET.:	RETURN
SUBTTL	MOVTAB - CONVERSION TABLE FOR TEXT MOVES

;THIS TABLE IS USED TO CONTROL THE EXTENDED INSTRUCTION WHICH
; MOVES TEXT FROM THE PAGE TO THE CD, OR VICE VERSA. IT IS
; DEFINED SUCH THAT ALL CHARACTERS ARE MOVED EXCEPT ZERO AND SPACE, WHICH
; CAUSES THE INSTRUCTION TO ABORT.
;
;IT ALSO CONVERTS ALL LOWER CASE TO UPPER CASE.
;
DEFINE TTAB,<
	XLIST		;;TURN OFF LISTING
	CHAR.==0	;;INIT CHAR VALUE
	ABRT.==100000	;;ABORT VALUE
	SIG.==400000	;SIGNIFICANCE BIT IN AC
REPEAT ^D64,<
	LEFT.==CHAR.	;;LEFT HALF
	RIGHT.==CHAR.+1	;;RIGHT HALF
	IFG LEFT.-140,<IFL LEFT.-173,<LEFT.==LEFT.-40>>
	IFG RIGHT.-140,<IFL RIGHT.-173,<RIGHT.==RIGHT.-40>>
	IFE LEFT.-" ",<LEFT.==LEFT.+ABRT.>
	IFE LEFT.,<LEFT.==LEFT.+ABRT.>
	IFE RIGHT.-" ",<RIGHT.==RIGHT.+ABRT.>
	IFE RIGHT.,<RIGHT.==RIGHT.+ABRT.>
	XWD	LEFT.,RIGHT.
	CHAR.==CHAR.+2
	>				;END OF REPEAT
	LIST
>

;DEFINE THE TABLE
MOVTAB:	TTAB
SUBTTL	TCSCON ERROR CODE TRANSLATION TABLE

; THIS TABLE CONTAINS THE TEXT OF ALL ERROR CODES WHICH ARE
; RETURNED BY TCSCON TO LCM. BY INDEXING INTO THIS TABLE
; WITH THE ERROR CODE, ONE CAN GET A PTR TO THE ASCIZ STRING
; OF THE ERROR MESSAGE. SOME OF THE ERROR CODES AREN'T REPRESENTED
; BECAUSE THEY ARE NEVER PRINTED OUT.

;MACRO TO SET THE VALUE OF THE ERROR CODE ENTRY
DEFINE $TCSERR(CODE$,TEXT$),<
	$SET	(TS%'CODE$,<POINT 7,[ASCIZ /TEXT$/]>)
>

;TABLE OF ERROR CODE MESSAGES
ERRTAB:	$INIT	(TS)
	$TCSERR	(ASO,<ALL RUN-UNIT SLOTS ARE OCCUPIED>)
	$TCSERR	(SHT,<SYSTEM SHUTDOWN HAS OCCURRED>)
	$TCSERR	(SYS,<A SOFTWARE ERROR DETECTED IN TCS-20 CONTROLLER>)
	$ENDINIT
; SYSERR - ROUTINE TO ACCESS THIS TCSCON ERROR CODE TABLE
;
; CALL:
;	<S2 = STATUS CODE>
;
; RETURN:
;	<THIS ROUTINE NEVER RETURNS....>
;
SYSERR:
	TMSG	<?LCM - UNEXPECTED ERROR CONDITION RETURNED BY TCS
?ERROR IS:  >
	MOVE	T1,ERRTAB(S2)	;GET ERROR TEXT
	SKIPN	T1		;HAVE WE INCLUDED IT IN TABLE?
	 BUG	(BEC)		;NO
	PSOUT			;PRINT IT
	JRST	STOPR.##	;HALT
SUBTTL	LCM ERROR CODE TRANSLATION TABLE

; THIS TABLE CONTAINS ALL INTERNAL LCM ERROR CODES (UNEXPECTED ONES)
; AND THEIR ASSOCIATED TEXT. IN ORDER TO ACCESS ONE OF THESE MESSAGES,
; ONE SHOULD DO A:
;	
;		ERR	MSGFOO
;
; WHICH WOULD TYPE OUT THE TEXT RELATING TO THE "FOO" CODE.
;
DEFINE $LCMERR(CODE$,TEXT$),<
	MSG'CODE$:	ASCIZ /TEXT$/
>

	$LCMERR (BDT,<THE DISPATCH VARIABLE IN THE "COPY" STATEMENT IS NOT A COMP ITEM>)
	$LCMERR (CGC,<CAN'T GET CORE FOR FORM NAME TABLE>)
	$LCMERR	(CGJ,<CAN'T GET A JFN FOR THE IPC FILE FOR TCS-20>)
	$LCMERR	(COF,<CAN'T OPEN THE IPC FILE FOR TCS-20>)
	$LCMERR (NNF,<NAME RETURNED BY TCS-20 NOT IN "BIND" COPY FILE>)
	$LCMERR (NBF,<NO FORM BINDING WAS DONE AT START OF PROCEDURE DIVISION>)
SUBTTL	INTERNAL ERROR EXITS FOR ALL COBOL VERBS

;COMMON ENTRY POINT FOR ALL BUG MESSAGES
;
; DEFINE THE TABLE OF ERROR ENTRIES AND TEXT STRINGS.
; THE FORMAT OF THIS TABLE IS:
;
;	BG.XXX:	JSP	T1,LCMERR
;		POINT 7,ERROR-TEXT
;
; WHERE XXX IS THE ERROR CODE
;
DEFINE BUGMSG(CODE,TEXT),<
BG.'CODE:	JSP	S1,LCMERR
	POINT	7,[ASCIZ TEXT]
>				;END OF BUGMSG MACRO

;TABLE OF INTERNAL ERROR CODES:
	BUGMSG (BCA,'BAD COMPILER ARGUMENT FOUND')
	BUGMSG (BEC,'BAD ERROR CODE RETURNED BY TCS..OR TEXT NOT IN TABLE')
	BUGMSG (BIA,'BAD INPUT ARGUMENT TO ROUTINE FOUND')
	BUGMSG (EIF,'EXTENDED INSTRUCTION FAILED')
	BUGMSG (EMI,'EMI NOT RECEIVED FROM TCS-20')
	BUGMSG (FTB,'NUMERIC FIELD VALUE TOO BIG')
	BUGMSG (INF,'CANT TALK TO <SYSTEM>INFO')
	BUGMSG (IRF,'AN INTERNAL ROUTINE RETURNED A BAD STATUS VALUE')
	BUGMSG (NCF,'CANNOT FIND OR ACCESS COMMUNICATION FILE')
	BUGMSG (NOC,'NO CORE AVAILABLE FOR PROCESSING TCS DATA')
	BUGMSG (NUM,'NOUT JSYS FAILED')
	BUGMSG (PKT,'BAD FORMAT FOR IPCF PACKET')
	BUGMSG (RCV,'CANNOT RECEIVE MESSAGE FROM TCS-20')
	BUGMSG (SND,'CANNOT SEND MESSAGE TO TCS-20')
	BUGMSG (STS,'BAD STATUS CODE RETURNED FROM TCS-20')
;COMMON EXIT POINT FOR ALL INTERNAL ERRORS
;
LCMERR:	TMSG <
?INTERNAL ERROR DETECTED IN LCM AT LOCATION: >
	POP	P,2		;GET ADDRESS TO PRINT
	SOS	2		;GO BACK TO PLACE OF ERROR
	TLZ	2,-1		;CLEAR JUNK
	OCTAL	(6)		;PRINT NUMBER, SIX COLUMNS
	TMSG	<
?ERROR IS: >
	MOVE	T1,(S1)		;GET BYTE POINTER
	PSOUT			;PRINT IT
	JRST	JERSTR		;PRINT LAST -20 ERROR
SUBTTL	ERROR EXIT FOR JSYS FAILURES

JERROR:
	TMSG	<?LCM - AN UNEXPECTED JSYS ERROR OCCURED IN LCM...
THE JSYS WHICH FAILED IS AT LOCATION:	>
	POP	P,2		;GET ADDRESS OF BAD JSYS + 2
	SUBI	2,2		;FIND LOCATION OF BAD JSYS
	TLZ	2,-1		;CLEAR FLAGS
	OCTAL	(6)		;PRINT OCTAL NUMBER
	MOVE	2,(2)		;GET JSYS CODE
	ANDI	2,777		;ISOLATE ONLY JSYS CODE
	TMSG	<
THE JSYS WHICH FAILED WAS:	104000,,000>
	OCTAL	(3)		;PRINT CODE OF JSYS
JERSTR:	TMSG	<
?LAST TOPS-20 ERROR WAS: >
	MOVEI	1,.PRIOU	;OUTPUT TO TTY
	HRLOI	2,.FHSLF	;LAST ERROR, THIS PROCESS
	SETZ	3,		;NO OUTPUT LIMIT
	ERSTR
	  JFCL
	  JFCL
	TMSG	<
>
	JRST	STOPR.##	;STOP THIS PROCESS


;COME HERE TO PRINT A MESSAGE WHEN [SYSTEM]INFO RETURNED AN ERROR CODE
;
; ENTER:
;	S1 = ERROR CODE
INFOER:
	TMSG	<?LCM - AN UNEXPECTED ERROR WAS RETURNED BY [SYSTEM]INFO
THE ERROR CODE RETURNED IS:	>
	MOVE	2,S1		;GET CODE
	OCTAL	(2)		;ONLY 2 DIGITS
	JRST	JERSTR		;STOP PROCESS

>;END OF IFN TCS (WHICH BEGAN AT M.INIT)
	END