Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/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