*DECK SYNTAX
USETEXT TAREATB 
USETEXT TCLFN 
USETEXT TCMMDEF 
USETEXT TCRMDEF 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TFIT
USETEXT TLFNINF 
USETEXT TOPTION 
USETEXT TREPORT 
USETEXT TSBASIC 
USETEXT TXSTD 
      PROC SYNTAX;                     # SYNTAX ANALYZER.              #
      BEGIN 
                                                                         SYNTAX 
CONTROL EJECT;                                                           SYNTAX 
          XREF
          BEGIN 
            PROC READ;
            PROC WRITE; 
            PROC DIAG;
            PROC LEXINIT; 
            PROC STD$START; 
            PROC LOADOVL; 
          PROC OPENM;  PROC CLOSEM;  PROC PUT;
            PROC GET; 
            PROC GETN;
            PROC STOPEXEC;
            ITEM SAVELFNAME;
          PROC REQPF; 
          PROC RETURNM; 
            PROC LOADX0;
          END 
      XREF ITEM CDCSCAT  B;        # TRUE IF IN CDCS CATALOG MODE      #
      XREF PROC CATCHK;            # CALL PROPER CATALOG-ACCESSING PROC#
      XREF ITEM RESTRICTPROC B;    # TRUE--RESTRICTS ARE BEING DONE.   #
      XREF ITEM TRANSLG I;         # ITEM TO HOLD TRANSMISSION LENGTH  #
      XREF ITEM MXTRNLG;     # MAX TRANSMISSION IN CHARACTERS # 
      XREF ITEM ABORTED      B;    # TRUE IF ABNORMAL TERMINATION      #
      XREF ITEM MODCAT       B;    # TRUE IF CATALOG FILE WAS MODIFIED #
                                   # SINCE LAST CLOSE                  #
      XREF ITEM SLOPERF      B;    # SLOW *PERFORM* IF TRUE            #
      XREF ITEM CURRENTLFPTR; 
      XREF ITEM AREATBLPTR;        #POINTER TO SUBSCHEMA TABLE         #
      XREF ITEM VERSBSCHPTR I;     # PTR TO SBSCH TBL FOR CATALOG FILE #017400
      XREF PROC RLSBMEM;           # RELEASE BASIC TABLE MEMORY        #
      XREF ITEM TARGETAREA;        #LAST AREA TABLE ACCESSED BY 4X,0   #
      XDEF ITEM PRIMKEY B;         # ON IF PRIMARY KEY USED IN A COND  #
      XDEF ITEM ALTERKEY B;        # ON IF ALTERNATE KEY USED IN A COND#
      XREF ITEM DUMMY;                                                   SYNTAX 
      XREF ITEM PROMTYPE I;        # QU PROMPT/POSITION INDICATOR      #
      XREF PROC EXPEVAL;
      XDEF ITEM DIRAREA B;         # TRUE IF DISPLAY OR IF DIRECTIVE   #
                                   # REFERENCES AREA ITEMS             #
      XDEF ITEM OLDSEARCH B;   #VALUE OF SEARCHFLAG BEFORE THIS COMMAND#
      XREF PROC SETBIT;            # INITIALIZE CREPORT                #
  
      ITEM SECLOADED    B = FALSE;  # TRUE IF A SYNTAX SECONDARY OVLAY #
                                    # HAS BEEN LOADED.                 #
  
      ITEM FNCPARM B;              # TRUE IF DATA-ATTRIB CALLED FOR A  #
                                   # FUNCTION PARAMETER                #
          ITEM I,J,K; 
          ITEM SAVESM$GROUP;       # SAVE SM$GROUPID DURING CUM FUNC   #
      XREF ITEM RA0;
      XDEF ITEM CURFUNC B;         # TRUE IF CURRENT ITEM IS FUNCTION  #
      XDEF ITEM CURREG B;          # TRUE IF CURRENT-REGISTER          # QU3A334
      XDEF ITEM ENDPTR;            # INDEX INTO EVALUATE TABLE         #
      XDEF ITEM EVALFWA;           # FWA OF FIRST EVALUATE TABLE       #
      DEF USID     # O"411" #;     # LEXICAL ID OF USER-ID REGISTER    #
      ITEM RCSAVE;                 # SAVE RETURN CODE FROM 1ST TRYLOCA #
      BASED ARRAY RESULT$FIELD;    # FOR LOOKING AT RESULT FIELD       #
        BEGIN 
        ITEM RESULT U(0,0,60);     # ONE WORD OF RESULT FIELD          #
        END 
      XDEF BASED ARRAY EVALDATA;
        BEGIN 
        ITEM LOGRST B(0,0,1);      # LOGICAL RESULT                    #
        ITEM DATACNVT I(0,6,18);   # POINTER TO CONVERT TABLE          #
        ITEM DATASTACK I(0,24,18); # POINTER TO EXPRESSION STACK       #
        ITEM DATADEFADDR I(0,42,18);  # PTR TO ATTRIBUTE ARRAY         #
        ITEM EVALWD U(0,0,60);     # WHOLE EVALUATE ENTRY              #
        END 
      ITEM TEMPEVALWD;             # TEMP AREA FOR BUILDING EVAL ENTRY #
      BASED ARRAY PTEMP; ITEM ITEMP;                                    000180
          ITEM RC;                 # USED FOR RETURN STATUS CODES.     #
          DEF DFTRPWD #O"40000000000001000000"#;
          DEF DFTRPWD2#O"04010000000000000000"#;                        008150
      XDEF ITEM SESSPTR I;
  
      XDEF ITEM BYINCR B;          # IF TRUE, TRANS-ID BEGINS WITH     #
                                   # THE INCREMENT SIZE NUMBER.        #
  
      XDEF ITEM ASIS B;            # IF TRUE, THE ORIGINAL TRANS-IDS   #
                                   # ARE DUPLICATED AS IS.             #
      XREF
          BASED ARRAY REPORTLIST S(3);
               ITEM REPORTWORD1 I(,,60),
             CNVTCODE U(2,0,6), 
                 HEADPOINTER I(0,42,18),
                 ADDRFROM I(2,24,18), 
                 ADDRTO I(2,42,18), 
                    REPORTWORD2 I(1,0,60);
          ITEM SVTYPALOW; 
           BASED ARRAY NAME; ITEM DDATNAME C(0,0,10); 
      BASED ARRAY BASEKEY;  ITEM BKEY U(0,0,60);
      XREF ITEM SM$GROUPID;        # GROUP ID OF CMM BLOCKS ALLOCATED  #
                                   # FOR THIS DIRECTIVE.               #
          XREF FUNC SAVATTR;
          XREF PROC SAVPTRS; XREF PROC SETPTRS; 
      XDEF ITEM OPNCATL B = FALSE;   # TRUE IF CATALOG OPEN # 
  
      XREF PROC OPNCAT;            # TRIES TO OPEN CATALOG FILE        #
  
      XDEF ITEM RPTFLAG      B = FALSE;  # TRUE IF ACTIVELY BUILDING   #
                                         # REPORT TABLES - IF IN THE   #
                                         # MIDDLE OF *FULLSYNTAX* LOOP #
  
      XDEF ITEM RPTOVL       I = 0;  # INDICATES PRIMARY OVERLAY LEVEL #
                                     # TO BE USED WITH THE RPT TABLES  #
                                     # ABOUT TO BE BUILT.              #
  
      XREF BASED ARRAY SCHEMAFIT;;  # FIT FOR SUBSCHEMA                #
  
      XREF BASED ARRAY DESPTR;
        BEGIN 
        ITEM DESSIZE U(0,24,18);   # SIZE OF DESCRIBED LIST IN CHAR    #
        ITEM DESADDR U(0,42,18);   # DESLIST FOR THIS FILE             #
        END 
      CONTROL EJECT;
#  START OF EXECUTABLE CODE    -SYNTAX-  #
#                                        #
      XREF ARRAY AINCREMENT [0:1]; # IN CTL. THESE CONTAIN THE CURRENT #
        ITEM INCREMENT C(0,0,10); # INCREMENT FOR RECORD+DUPLICATE     #
      XDEF ITEM FORWHICHDIR; # AND THIS TELLS WHICH IS BEING PROCESSED #
  
      IF BASE1X EQ 0 THEN BASE1X = OLD65; #BASE FOR (1,X) OVERLAYS#     000120
  
  
  
      FOR I = 0  STEP 1 UNTIL 25  DO BEGIN
         ICW [I] = BLK; 
        INW [I] = BLK;     END
          IF LVL EQ RPTCTR THEN BEGIN 
          CURREPT="          "; #SET FLAG "NO CURRENT REPORT" ON #
        READFROM = S"INPUT";
          PAGENUM = "PAGE 00001"; 
           FULLSYNTX = FALSE; 
          PRESUMFG = FALSE; 
      IF PERFLG  THEN BEGIN     # IF DOING A PERFORM - SET UP #         000420
        PERDU: # #                                                      001280
        PERDUMMY = TRUE;        # DUMMY PERFORM DIRECTIVE     #         000430
      INWORD[0] = " PERFORM  "; 
      QUIRL = 10; 
      WP = 0; 
      STKPOINTER = 20;
      KEYAREA[0] = OLDKEY;                                               FEAT157
        END                                                             000500
          ELSE                                                          001070
          SYNIO;                       # READ SOURCE TO ANALYZE.       #
          FLAGA = FALSE;
         END
         ELSE BEGIN RPTCTR = RPTCTR + 1;
              #SET UP INFORMATIONS TO START PREPARE NEXT                008170
               LEVEL OF REPORT#                                         008180
                 CURREPT = RPTNAME[RPTCTR]; 
                 MAJORKEYLEN = 7; 
                 KEYAREA[0] = RPTNAME[RPTCTR];                           FEAT157
                 HIGHKEY = KEYAREA[0];                                   FEAT157
                 B<42,18>HIGHKEY = O"777777"; 
          IF RPTCTR EQ 0 THEN PAGENUM = "PAGE 00001"; 
               #IF THIS IS THE BEGINNING OF THE WHOLE REPORT,           008200
                RESET PAGE NUMBER#                                      008210
          IF TEXTFG[RPTCTR] THEN
          BEGIN SETBIT; 
                #IF IT IS JUST THE TEXT FROM SOURCE,SET UP              008230
                 REPORT LIST ENTRY TO REFLECT IT#                       008240
                #SKIP ALL THE SYNTAX CRACKING AND JUMP INTO             008250
                 REPORT PRODUCING#                                      008260
          CURRENTLFPTR = FLFNINFO[RPTCTR];
          P<LFNINFO> = CURRENTLFPTR;
          P<DESPTR> = L$DESPTR;                                          SYNTAX 
          DESLIST = DESADDR;
          FSIZE = DESSIZE;
                       DTLFIRST[1] = 1; 
                       DTLLAST[1] = 1;
          REPORTWORD1[1]=DFTRPWD;                                       008120
          REPORTWORD2[1]=DFTRPWD2;                                      008130
          HEADPOINTER[1] = LOC(DTLWORD[1]); 
           ADDRFROM[1] = LOC(CURRENTSOURC); 
         ADDRTO[1] = LOC(FORMDLADDR); 
          CNVTCODE[1] = 0;
          REPORTWORD1[2] = 0;      # TEXT ENTRY IS NOT CONTINUED       #
          REPORTWORD2[2] = 0;      # TEXT ENTRY IS NOT CONTINUED       #
          PSFLG = 1;
          PRIMARY = 2;
      EXIT10; 
          END 
               #IF NOT TEXT, PICK UP NEXT REPORT NAME, FALSE            008280
                PREPARE DIREVTIVE AS SYNTAX INPUT, SO THAT THE          008290
                SYNTAX CRACKING ROUTINES CAN CRACK THE DIRECTIVES       008300
                FOR THIS REPORT#                                        008310
          PSFLG = 0;
           READFROM = S"GET1ST";
           P<BASEKEY> = P<KEYWSA>;                                       FEAT157
           B<0,42>BKEY[0] = RPTNAME[RPTCTR];
           B<42,18>BKEY[0] = O"555555"; 
           BKEY[1] = " PREPARE  ";
           BKEY[2] = BKEY[0]; 
           BKEY[3] = "FROM      ";
           B<0,42>BKEY[4] = FROMLFN[RPTCTR];
           QUIRL = 37;
           WP = 0;
           FLAGA = TRUE;
          FULLSYNTX = TRUE; 
          NONEMPTYRPT = FALSE;                                          004120
      END 
          IF NOT SECLOADED         # IF NO SYNTAX SECONDARY YET        #
          THEN
            BEGIN 
            SECONDARY = SSECONDAR;  # SELECT THE SECONDARY WE HAD LAST #
            LOADOVL(BASE1X, 1, SECONDARY);  # LOAD THE SECONDARY OVLAY #
            SECLOADED = TRUE;      # NOW WE HAVE A SECONDARY OVERLAY   #
            END 
  
          KEYTEST = TRUE;              # NEXT SOURCE SHOULD BE KEY WORD#
      INITSCAN: 
          IF NOT NEXTXMISSN THEN    # IF ANOTHER TRANSMISSION  #
            BEGIN                   # IS NOT EXPECTED, TURN OFF # 
            AKEY = FALSE;           # KEY FLAGS.                # 
            PKEY = FALSE; 
            END 
          DISUPD = 0; 
          LEXINIT;                     # IDENTIFY AND TYPE 1ST SOURCE  #
                                       # WORD.                         #
      INITSTD:  
          STD$START;                   # BEGIN SYNTAX ANALYSIS.        #
      XDEF LABEL INITRTN; 
INITRTN:                           # RETURN FROM EOT PROCESSING        #
      IF NOT NEXTXMISSN            # SET UP DUMMY -PERFORM- TO GET     #
        AND PERFLG                 # BACK INTO -PERFORM- SYNGEN MODE   #
      THEN
        BEGIN 
        PERDUMMY = TRUE;
        INWORD[0] = " PERFORM  "; 
        QUIRL = 10; 
        WP = 0; 
        STKPOINTER = 20;
        KEYAREA[0] = OLDKEY;                                             FEAT157
        KEYTEST = TRUE; 
        END 
      ELSE
        BEGIN 
        SYNIO;                                                           SYNTAX 
        END 
      GOTO INITSCAN;
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C H K N A M E                                                    #
#                                                                      #
# THIS PROC PERFORMS THE SAME FUNCTION AS +NAME WITHOUT ADVANCING      #
# NXTWORD TO CURWORD.                                                  #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC CHKNAME;
      PROC      CHKNAME;
      BEGIN 
      IF NEXTYPE EQ 101 THEN       # IF TYPE CODE IS THAT FOR NAME...  #
        BEGIN 
        STDYES;                    # NEXWORD IS A NAME                 #
        END 
  
      IF NLXNUM[0] EQ USID         # IF USER-ID REGISTER               #
      THEN
        BEGIN 
        STDYES;                    # ALSO CONSIDERED A DATANAME        #
        END 
  
      STDNO;                       # NEXWORD IS NOT A NAME AS YOU MIGHT#
                                   # HAVE GUESSED AT THIS POINT        #
      END  # CHKNAME #
      CONTROL EJECT;
 FUNC KEYLQHI B;
 # THIS FUNCTION RETURNS THE VALUE TRUE IF KEYAREA
   IS LQ HIGHKEY, ELSE IT IS FALSE.  BEFORE THE 
   COMPARISON, BLANK (55B) CHARACTERS ARE 
   CONVERTED TO BINARY ZEROES.  # 
 # ONLY 7 CHARACTERS ARE COMPARED IF IN REPORT GENERATION # 
 BEGIN
      ITEM HILOC C(10), LOLOC C(10);                                    000130
      I = 7;
      IF PERFLG  THEN I = 10; 
      LOLOC = C<0,I>KEYAREA[0];                                          FEAT157
      HILOC = C<0,I>HIGHKEY;
      KEYLQHI = FALSE;
      IF LOLOC LQ HILOC  THEN KEYLQHI = TRUE; 
      RETURN; 
 END
      CONTROL EJECT;
      XDEF PROC RECNO;
#                                                                      #
      PROC RECNO;                  # RETURN TO STDNO IF RECORDING      #
      BEGIN 
      IF RECORDFLAG                # IF RECORDING                      #
      THEN
        BEGIN 
        STDNO;
        END 
      RETURN; 
      END 
      CONTROL EJECT;
      XDEF PROC RECYES; 
#                                                                      #
      PROC RECYES;                 # RETURN TO STDYES IF RECORDING     #
      BEGIN 
      IF RECORDFLAG                # IF RECORDING                      #
      THEN
        BEGIN 
        STDYES; 
        END 
      RETURN; 
      END 
  
      CONTROL EJECT;
      XDEF PROC SYNIO;
      PROC SYNIO;                      # SOURCE INPUT INTERFACE ROUTINE#
      BEGIN 
      SWITCH READIN   INPUT, GET1ST, GETNEXT; 
          SVTYPALOW = 0;
          GOTO READIN[READFROM];
INPUT:  
      XREF PROC DIAGFLU;                                                 QY40174
      DIAGFLU;                     #FLUSH OUT ANY DIAGNOSTICS          # SYNTAX 
      IF PROMPDIR NQ 0  THEN BEGIN                                      000880
*IF DEF,NOS 
                                   # PROMTYPE IS USED TO INSERT LINE   #
                                   # CONTROL CHAR AFTER THE QU PROMPT, #
                                   # SO NOS WILL ACCEPT INPUT ON THE   #
                                   # SAME LINE. PROMTYPE SETS THE POS  #
                                   # FOR THE CONTROL CHAR.             #
      IF B<6,12>PROMPDIR EQ "--"
      THEN
        BEGIN 
        PROMTYPE = 30;             # POSITION FOR QU PROMPT --         #
        END 
      ELSE
        BEGIN 
        PROMTYPE = 54;             # POSITION FOR SESSION PROMPT 001 --#
        END 
*ENDIF
      P<PTEMP> = LOC(PROMPDIR);                                         000150
      WRITE (PTEMP,10,0);                                               000160
      END                                                               000900
      ELSE PROMPDIR = NEXTDIR;                                          000910
           IF IFFLAG AND IFFROMFLAG THEN IFFROMFLAG = TRUE; ELSE
           IFFROMFLAG = FALSE;
      READ (QUIWSA, QUIRL, MXTRNLG, XRETURN);  # GET NEXT TRANSMISSION #
          IF XRETURN GR 0 OR
             QUIRL EQ 0 THEN           # IF EOI, STOP.                 #
               STOPEXEC;
          #************************************************************#
          # THE FOLLOWING CODE IS A KLUGE SO LEXSCAN WILL HAVE FEWER   #
          # OCCASIONS ON WHICH TO MESS UP FORMALT-S CALCULATION OF     #
          # REPORT SPECIFICATION LENGTH FOR WRITING TO THE CATALOG FILE#
          # THIS MAKES SURE ALL TRAILING BLANKS ARE REMOVED FROM THE   #
          # TRANSMISSION, AND THEN ADDS ONE SO THE INCONSISTENCY IN    #
          # THE VALUE OF -OLDLEX- AT -PUT- TIME (LENGTH CALCULATION)   #
          # IS HARMLESS. QUIRL IS CHECKED TO INSURE IT IS THE LENGTH   #
          # WITHOUT THE ONE TRAILING BLANK.                            #
          #************************************************************#
  
          J = (QUIRL - 1) / 10;    # INDEX OF LAST WORD IN QUIWSA      #
          I = (QUIRL - 1 ) - J * 10; # CHAR POS OF LAST CHAR IN WORD J #
          FOR J = J STEP -1 UNTIL 0 DO     # FOR EACH WORD             #
            BEGIN 
            FOR I = I STEP -1 UNTIL 0 DO   # FOR EACH CHAR OF EACH WORD#
              BEGIN 
              IF C<I>INWORD[J] NQ " " THEN   # IF LAST NON-BLANK CHAR  #
                BEGIN 
                QUIRL = J * 10 + I + 1;  # REFLECT LENGTH TO LAS NON   #
                                         # NON-BLANK CHARACTER.        #
                IF I EQ 9 THEN     # TAKE IF LAST CHAR IS IN CHAR POS 9#
                  BEGIN 
                  I = 0;           # FIRST CHAR POS OF...              #
                  J = J + 1;       # ...THE NEXT WORD.                 #
                  END 
                ELSE               # NOT LAST CHAR IN THIS WORD        #
                  BEGIN 
                  I = I + 1;       # NEXT CHAR POS IN THIS WORD        #
                  END 
                C<I>INWORD[J] = " "; # MAKE SURE ONE TRAILING BLANK    #
                J = 0;           # TO CAUSE TERMINATION OF -J- LOOP    #
                TEST J;            # FORCE -J- TO BE TESTED NOW        #
                END 
              END                  # END OF -I- LOOP                   #
            I = 9;               # RESET -I- FOR NEXT WORD             #
            END 
  
          #************************************************************#
          #                                                            #
          #  E N D   O F   K L U G E   F O R   L E X S C A N           #
          #                                                            #
          #************************************************************#
  
  
  
                                   # SET STKPOINTER TO RECORD LENGTH   #
                                   # PLUS ONE WORD PLUS ONE TO BE      #
                                   # SURE TO PICK UP SPACE AT END OF   #
                                   # TRANSMISSION                      #
          STKPOINTER = QUIRL + 11;
      TRANSLG = QUIRL;             # SAVE THE TRANSMISSION LENGTH      # FEAT157
      GOTO SYNRETURN; 
GET1ST:               #  GET NEXT RECORD USING KEY ONE  # 
      OPNCAT(CATAFIT, PD$INPUT, I);  # OPEN CATALOG FOR INPUT          #
      IF I NQ 0                    # IF CATALOG NOT OPENED             #
      THEN
        BEGIN 
        IF PERFLG                  # IF TRYING TO PERFORM              #
        THEN
          BEGIN 
          DIAG(39, C<1,6>KEYAREA);  # DIAGNOSE UNKNOWN SESSION         #
          PERFLG = FALSE;          # NO LONGER DOING A PERFORM         #
          GOTO SYNEOF;             # RETURN TO USER INPUT              #
          END 
  
        ELSE
          BEGIN 
          ICW[0] = CURREPT;        # CURWORD GETS REPORT NAME FOR DIAG #
          CURLENG = 7;             # CURLENG GETS MX REPORT NAME LNGTH #
          DIAG(103);               # DIAGNOSE UNKNOWN REPORT           #
          GOTO SYNEOF;             # RETURN TO USER INPUT              #
          END 
        END 
  
      CATAFITWSA = P<KEYWSA>; 
      CATAFITKA = CATAFITWSA; 
      CATAFITKP = 0;
      CATAFITMKL = MAJORKEYLEN; 
      CATCHK (CGET, LOC(CATAFIT), CDCSCAT); 
      IF NOT PRESUMFG THEN
        BEGIN 
        IF CATAFITES NQ 0          #CHECK IF -GET- ERROR               # SYNTAX 
        THEN                                                             SYNTAX 
          BEGIN                        # ERROR FROM -GET- # 
          IF PERFLG THEN
            BEGIN                      # DOING A PERFORM  # 
            DIAG(39, C<1,6>KEYAREA[0]);  #UNKNOWN SESSION              # SYNTAX 
            PERFLG = FALSE;        # NO LONGER DOING A PERFORM         #
            END 
          ELSE
            BEGIN                      # DOING A REPORT  #
            ICW[0] = CURREPT; 
            DIAG(103);             #UNKNOWN REPORT NAME                # SYNTAX 
            END 
          GOTO SYNEOF;                 # GO BACK TO USER INPUT #
          END 
        ELSE
          BEGIN                        # NO ERROR FROM -GET- #
          READFROM = S"GETNEXT";
          IF NOT PERFLG THEN FULLSYNTX = TRUE;
          NONEMPTYRPT = FALSE;
          END 
        END 
SYNLENG:  
          P<FIT> = LOC(CATAFIT);                                         SYNTAX 
          STKPOINTER = FITRL;                                            SYNTAX 
          QUIRL = STKPOINTER - 10;                                      005120
          TRANSLG = QUIRL;         # SAVE THE TRANSMISSION LENGTH      # FEAT157
 SYNRETURN:   # RETURN FROM SYNIO WITH NEW DATA # 
      IF NOT NEXTXMISSN  THEN SEARCHFLAG = FALSE; 
         CT100 = - 100; 
         LXBEGIN = 0; 
      PLACEFLAG = 0;                                                    002100
          WP = 0;                      # FLAG TO TELL LEXSCAN OF NEW   #
          RETURN;                      # INPUT IN QUIWSA.              #
GETNEXT:              #  GET NEXT RECORD WITH THIS KEY  # 
      OPNCAT(CATAFIT, PD$INPUT, I);  # OPEN CATALOG FOR INPUT          #
      IF I NQ 0                    # IF CATALOG NOT OPENED             #
      THEN
        BEGIN 
        IF PERFLG                  # IF TRYING TO PERFORM              #
        THEN
          BEGIN 
          DIAG(39, C<0,7>KEYAREA);  # DIAGNOSE UNKNOWN SESSION         #
          PERFLG = FALSE;          # NO LONGER DOING A PERFORM         #
          GOTO SYNEOF;             # RETURN TO USER INPUT              #
          END 
  
        ELSE
          BEGIN 
          ICW[0] = CURREPT;        # CURWORD GETS REPORT NAME FOR DIAG #
          CURLENG = 7;             # CURLENG GETS MX REPORT NAME LNGTH #
          DIAG(103);               # DIAGNOSE UNKNOWN REPORT           #
          GOTO SYNEOF;             # RETURN TO USER INPUT              #
          END 
        END 
  
      CATCHK (CGETN, LOC(CATAFIT), CDCSCAT);
      IF KEYLQHI THEN 
          # WE HAVE A RECORD WITHIN THE RANGE IMPLIED BY THE DIRECTIVE #
      GOTO SYNLENG; 
 SYNEOF:     # RETURN WITH EOF FLAGS FLYING # 
      QUIRL = 0;   #  FLAG FOR END OF DATA  # 
      READFROM = S"INPUT";
      GOTO SYNRETURN; 
      END 
      CONTROL EJECT;
      XDEF PROC LOAD1X; 
      PROC LOAD1X;
      BEGIN 
          IF NOT RPTFLAG           # IF NOT IN THE MIDDLE OF REPORT    #
                                   # TABLE BUILDING                    #
          THEN
            BEGIN 
            KEYTEST = FALSE;       # SWAP OF OVERLAYS OCCURRED TO GET  #
                                   # TO THE PROPER OVERLAY FOR THE     #
                                   # DIRECTIVE KEYWORD ALREADY TESTED. #
                                   # THIS FLAG TELLS SYNTAX CRACKING   #
                                   # THAT IT ALREADY HAS THE KEYWORD,  #
                                   # AND ALL IT HAS TO DO IS A +SUBS   #
            END 
  
          SECONDARY = CP2B[0];         # FLAG FOR SECONDARY OVERLAY TO # XEQREP 
                                       # BE LOADED.                    #
          IF PERFLG                # IF DOING A PERFORM                #
            AND NOT RPTFLAG        # AND NOT IN MIDDLE OF REPORT PREP  #
          THEN
            BEGIN 
            OLDKEY = KEYAREA[0];   # SAVE MOST RECENT *PERFORM* KEY    #
            END 
  
          SSECONDAR = SECONDARY;
          LOADOVL(BASE1X,1,SECONDARY);
          SECLOADED = TRUE;        # THERE IS A SECONDARY SYNTAX OVLAY #
                 # LOAD AND TRANSFER TO OVERLAY 1,X # 
          GOTO INITSTD; 
      END 
          XDEF PROC SETDIRX;
          PROC SETDIRX; 
          BEGIN                                                          XEQREP 
          TYPEALOW = NP1C[0];                                            XEQREP 
          DIRLEXID = NLXNUM[0];                                          XEQREP 
          STDNO;                                                         XEQREP 
          END 
      XDEF PROC SAMEOVL;
      PROC SAMEOVL; 
      BEGIN 
          IF KEYTEST THEN              # IF NO CHANGE IN OVERLAYS OC-  #
           BEGIN
          TYPEALOW = NP1C[0];                                            XEQREP 
            STDYES;                    # CURRED, MUST CHECK FOR A      #
                                       # DIRECTIVE AS NEXT SOURCE WORD.#
          END 
          KEYTEST = TRUE;              # IF CHANGE IN OVERLAYS OCCURRED#
                                       # MUST CHECK FOR KEY WORD NEXT  #
          STDNO;
      END 
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     R P T S Y N                                                      #
#                                                                      #
# RETURNS STDYES IF *RPTFLAG* IS TRUE (ACTIVELY BUILDING REPORT TABLES)#
# OTHERWISE, RETURN IS TO STDNO.                                       #
  
      XDEF PROC RPTSYN; 
      PROC RPTSYN;
      BEGIN 
      IF RPTFLAG                   # IF ACTIVELY BUILDING TABLES       #
      THEN
        BEGIN 
        STDYES;                    # YES, ACTIVELY BUILDING TABLES     #
        END 
  
      ELSE
        BEGIN 
        STDNO;                     # NO, NOT BUILDING TABLES           #
        END 
      END 
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C H K I F L G                                                    #
#                                                                      #
# THIS PROC CHECKS TO SEE IF THE PRECEDING DIRECTIVE WAS A STAND-ALONE #
# *IF* WITH A FALSE CONDITION (USING TEMPORARY ITEMS ONLY). IF SO,     #
# RETURN VIA STDYES, ELSE RETURN VIA STDNO.                            #
  
      XDEF PROC CHKIFLG;
      PROC CHKIFLG; 
      BEGIN 
      IF IFFAIL                    # IF PREVIOUS *IF* UNTRUE           #
        AND NEXTXMISSN             # AND TRANSMISSION IS CONTINUED     #
      THEN
        BEGIN 
        STDYES; 
        END 
      STDNO;
      END 
  
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     C L R N E X T                                                    #
#                                                                      #
# CLEAR FLAGS THAT SIGNAL A CONTINUING TRANSMISSION FOR AN UNTRUE *IF* #
# CONDITION SO THAT THE NEXT DIRECTIVE WILL BE PROCESSED.              #
  
      XDEF PROC CLRNEXT;
      PROC CLRNEXT; 
      BEGIN 
      IFFAIL = FALSE; 
      IF NOT PERFLG                # IF PERFORMING A SESSION, GO BACK  #
                                   # AND GET NEXT TRANSMISSION.        #
      THEN
        BEGIN 
        NEXTXMISSN = FALSE; 
        END 
      STDYES; 
      END 
      CONTROL EJECT;
      XDEF PROC CALLIO; 
      PROC CALLIO;  BEGIN 
              RECYES;              # RETURN TO STDYES IF RECORDING     #
                        SYNIO;  #GET NEXT DIRECTIVE FROM CATALOG# 
                        STDYES; 
                    END 
  
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     C H K L F N                                                      #
#                                                                      #
# THIS PROC CHECKS FOR A LEGAL LFN. THE CANDIDATE IS IN THE CURWORD    #
# ARRAY. RETURN TO STDYES IF LEGAL, ELSE RETURN THROUGH STDNO.         #
#  A TEST IS MADE TO MAKE CERTAIN THE LFN IS NOT                       #
#  THE SAME AS PF NAMES.                                               #
  
  
      XDEF PROC CHKLFN; 
      PROC CHKLFN;                 BEGIN  #CHKLFN#
      IF CURLENG GR 7 THEN         # IF LFN TOO LONG                   #
        BEGIN 
        STDNO;                     # BAD RETURN                        #
        END 
  
      IF C<0,1>ICW[0] GR "Z" THEN  # IF FIRST CHAR NOT ALPHABETIC      #
        BEGIN 
        STDNO;                     # BAD RETURN                        #
        END 
  
      FOR DUMMY = 0 STEP 1 UNTIL CURLENG - 1 DO   # TEST FOR ILLEGAL CH#
        BEGIN 
        IF C<DUMMY,1>ICW[0] LS "A"  OR     # IF SMALLER THAN SMALLEST  #
           C<DUMMY,1>ICW[0] GR "9" THEN    # OR BIGGER THAN BIGGEST    #
          BEGIN 
          STDNO;                   # BAD RETURN                        #
          END 
        END 
  
          ILFN[LFNINDEX] = ICW[0]; #SAVE FILE NAME IN CLFN #
          ILFNLG[LFNINDEX]=CURLENG;  # SAVE LENGTH OF FILE NAME        #
          SAVELFNAME = 0; 
          B<0,CURLENG * 6>SAVELFNAME = B<0,CURLENG * 6>ICW[0];
      CHKFNAMES;                   # CHECK FILE NAMES                  #
      STDYES; 
      END #CHKLFN#
  
  
  
CONTROL EJECT;
  
      #----------------------------------------------------------------#
      #                PROC CHKFNAMES                                  #
      #                                                                #
      #  THIS PROCEDURE COMPARES THE LFN WITH THE NAMES                #
      #  IN THE AREA TABLE, IF THERE IS ONE.  A MATCH CAUSES           #
      #  A DIAGNOSTIC TO BE ISSUED AND THE DIRECTIVE TO BE             #
      #  IGNORED BY A RETURN TO STDNO.  FILE NAMES CHECKED             #
      #  ARE AREA, LOG, INDEX, DBPROC LIBRARY AND CATALOG              #
      #                                                                #
      #----------------------------------------------------------------#
  
      PROC CHKFNAMES; 
      BEGIN 
      ITEM FINIS     B;            # FINISH FLAG                       #
  
      XREF ITEM CATBLPTR;          # POINTER TO CATABLE                #
  
  
      IF AREATBLPTR NQ 0           # FIRST MAKE SURE THERE ARE         #
      THEN                         # AREA TABLES                       #
        BEGIN 
        FINIS = FALSE;
        P<AREA$TABLE> = AREATBLPTR;  # SET POINTER TO TABLE            #
        FOR I = 0 
          WHILE NOT FINIS 
        DO
          BEGIN 
          P<FIT> = LOC(AT$AFITPOS);# POINT TO AREA FIT                 #
          IF FITLFN EQ B<0,42>SAVELFNAME
          THEN
            BEGIN 
            DIAG(424,"AREA");      # MATCH IS A NO-NO                  #
            STDNO;
            END 
          IF AT$INDFDB GR 0        # CHECK INDEX FILE                  #
          THEN
            BEGIN 
            P<FIT> = LOC(AREA$TABLE) + AT$INDFDB; 
            IF FITLFN EQ B<0,42>SAVELFNAME
            THEN
              BEGIN 
              DIAG(424,"INDEX");
              STDNO;
              END 
            END 
          IF AT$LOGFDB GR 0        # CHECK LOG FILE                    #
          THEN
            BEGIN 
            P<FIT> = LOC(AREA$TABLE) + AT$LOGFDB; 
            IF FITLFN EQ B<0,42>SAVELFNAME
            THEN
              BEGIN 
              DIAG(424,"LOG");
              STDNO;
              END 
            END 
          IF AT$DBPROC GR 0        # CHECK LIBRARY                     #
          THEN
            BEGIN 
            P<FIT> = LOC (AREA$TABLE) + AT$DBPROC;
            IF FITLFN EQ B<0,42>SAVELFNAME
            THEN
              BEGIN 
              DIAG(424,"DBPROC LIB"); 
              STDNO;
              END 
            END 
          IF CATBLPTR GR 0         # CHECK CATALOG                     #
          THEN
            BEGIN 
            P<CATABLE> = CATBLPTR;
            IF CAT$NAM EQ SAVELFNAME
            THEN
              BEGIN 
              DIAG(424,"CATALOG");
              STDNO;
              END 
            END 
  
          IF AT$FORWARD NQ 0       # SEE IF MORE BLOCKS                #
          THEN
            BEGIN 
            P<AREA$TABLE> = AT$FORWARD;  # POINT TO NEXT ENTRY         #
            END 
          ELSE
            BEGIN 
            FINIS = TRUE; 
            END 
          END 
        END 
  
      RETURN;                      # ALL OK, NO MATCH                  #
      END                          # END PROC CHKFNAMES                #
  
CONTROL EJECT;
  
  
      XDEF PROC SAVCP1A;
      PROC SAVCP1A; #SAVES PART OF THE CURRENT P1 VALUE INTO LFNINDEX#
      BEGIN 
          LFNINDEX=CP1A[0]; 
          ILFN[LFNINDEX]="          ";
          ILFNLG[LFNINDEX]=1;  #SET ARBRITARY LG OF 1 TO BLANK LFN# 
          STDNO;
      END 
  
        XDEF PROC INCREM; 
        PROC INCREM;
          BEGIN 
          IF CURLENG GR 3 OR ICWI[5] LQ 0 THEN STDNO; # IS IT IN RANGE #
  
          IF NOT ASIS              # TID3 IS GIVEN. DO NOT START NEW   #
                                   # SESSION WITH INCREMENT NUMBER.    #
          THEN
            BEGIN 
            BYINCR = FALSE; 
            END 
  
          ELSE                     # TID3 IS NOT GIVEN, START NEW      #
                                   # SESSION WITH INCREMENT NUMBER.    #
            BEGIN 
            BYINCR = TRUE;
            ASIS = FALSE; 
            END 
  
          C<10-CURLENG,CURLENG>INCREMENT[FORWHICHDIR] = 
                                       C<0,CURLENG>ICW[0];
          STDYES;          #SINCE IT IS, TUCK IT AWAY WHERE IT BELONGS# 
          END 
       #ROUTINE TO PRINT OUT THE DIRECTIVE IN ERROR WHEN IN FULL        008740
        SYNTAX MODE#                                                    008750
      XDEF PROC WRDIRT; 
      PROC WRDIRT;
      BEGIN 
      ITEM KEY C(10); 
      RECNO;                       # RETURN TO STDNO  IF RECORDING     #
      KEY = KEYAREA[0];                                                  FEAT157
      KEYAREA[0] = BLK;                                                  FEAT157
      WRITE(KEYWSA, STKPOINTER, DUMMY);                                  SYNTAX 
      KEYAREA[0] = KEY;                                                  FEAT157
      FLAGA = FALSE;               # CLEAR FLAG TO INDICATE THAT QU IS #
                                   # NOT IN THE MIDDLE OF PREPARING A  #
                                   # MULTI-REPORT REPORT               #
      RPTCTR = 0; 
      LVL = 0;
        READFROM = S"INPUT";
        PRESUMFG = FALSE; 
        FULLSYNTX = FALSE;
        IF SM$GROUPID NQ 0 THEN    # IF CMM GROUP ID ALLOCATED...      #
          BEGIN 
          CMM$FGR(SM$GROUPID);     # FREE ANY BLOCKS WITH THIS GROUP ID#
          SM$GROUPID = 0;          # INDICATE NO CMM GROUP ID ALLOCATED#
          END 
      STDNO;                                                             SYNTAX 
      END 
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     P R O C   C H K N O T E                                          #
#                                                                      #
#     CHKNOTE CHECKS NEXWORD FOR THE DIRECTIVE NOTE.  IF FOUND RETURN  #
#     IS VIA STDNO, OTHERWISE STDYES.  CURWORD AND NEXWORD ARE NOT     #
#     ADVANCED.                                                        #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC CHKNOTE;
      PROC CHKNOTE; 
      BEGIN 
       IF  NEXLENG NQ 4            # IF NEXWORD ITEM NOT 4 CHARS. LONG #
        OR C<0,4>INW[0] NQ "NOTE"  # OR NEXWORD ITEM NOT NOTE          #
      THEN
        BEGIN 
        STDNO;                     # STDNO MEANS NEXWORD ISNT NOTE     #
        END 
      ELSE
        BEGIN 
        STDYES;                    # STDYES MEANS NEXWORD IS NOTE      #
        END 
      END  # CHKNOTE #
  
  
  
  
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C L R F L G S                                                    #
#                                                                      #
#     *CLRFLGS* IS CALLED FIRST THING IN *DATA-ATTRIB* TO CLEAR THE    #
#     FLAGS THAT INDICATE IF THE CURRENT ITEM IS A REGISTER OR         #
#     FUNCTION.                                                        #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC CLRFLGS;
      PROC CLRFLGS; 
      BEGIN 
      CURREG = FALSE;              # NOT A REGISTER                    #
  
      IF NOT FNCPARM               # IF NOT WORKING ON FUNCTION PARAM  #
      THEN
        BEGIN 
        CURFUNC = FALSE;           # NOT A FUNCTION                    #
        END 
  
      STDYES; 
      END                          # PROC *CLRFLGS*                    #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C L R P A R M                                                    #
#                                                                      #
#     *CLRPARM* IS CALLED AFTER *DATA-ATTRIB* HAS PROCESSED A FUNCTION #
#     PARAMETER TO CLEAR THE FLAG *FNCPARM*. (SEE *SETPARM*)           #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC CLRPARM;
      PROC CLRPARM; 
      BEGIN 
      FNCPARM = FALSE;
      STDNO;
      END                          # PROC *CLRPARM*                    #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     I F R P T D                                                      #
#                                                                      #
#     THIS PROC RETURNS VIA STDYES IF THE MOST RECENT DIRECTIVE WAS A  #
# REPORT DIRECTIVE. THIS IS DONE BY CHECKING *STKFLAG*, WHICH IS SET   #
# IN *STKINIT*.                                                        #
  
      XDEF PROC IFRPTD; 
      PROC IFRPTD;
      BEGIN 
      SETLXBEGIN;                  # SET LXBEGIN                       #
      IF STKFLAG                   # IF WAS A REPORT DIRECTIVE         #
      THEN
        BEGIN 
        STDYES;                    # STDYES MEANS IT WAS A REPORT DIR. #
        END 
  
      ELSE
        BEGIN 
        STDNO;                     # STDNO - IT WASNT A REPORT DIR.    #
        END 
      END 
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     SETLXBEGIN                                                       #
#                                                                      #
#     IF NOT A REPORT DIRECTIVE, SET LXBEGIN TO CHARACTER POSITION     #
#     OF NEXT DIRECTIVE.  IF REPORT DIRECTIVE, STKOUT WILL SET LXBEGIN.#
#     STKOUT USES LXBEGIN TO RECORD REPORT DIRECTIVES.                 #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC SETLXBEGIN;
      BEGIN 
      IF NOT STKFLAG               # IF NOT A REPORT DIRECTIVE         #
      THEN
        BEGIN 
        LXBEGIN = CT100 + LEXPTR - NEXLENG - 1; 
        END 
      RETURN; 
      END 
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S E T P A R M                                                    #
#                                                                      #
#     *SETPARM* IS CALLED BEFORE ENTERING *DATA-ATTRIB* FOR A FUNCTION #
#     PARAMETER.  IT SETS A FLAG TO TELL *CLRFLGS* NOT TO CLEAR THE    #
#     FLAG *CURFUNC*.                                                  #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC SETPARM;
      PROC SETPARM; 
      BEGIN 
      FNCPARM = TRUE;              # THIS ITEM IS A FUNCTION PARAMETER #
      STDYES; 
      END                          # PROC *SETPARM*                    #
CONTROL EJECT;
          XDEF PROC STKINIT;
          PROC STKINIT; 
          BEGIN 
          CONDIT = FALSE;                                               005180
          STKFLAG = NLXREPT[0]; 
          DIRLEXID = NLXNUM[0]; 
          TYPEALOW = NP1C[0];                                            XEQREP 
  
# THIS NEXT STATEMENT ATTEMPTS TO AVOID BUILDING KEYS FOR REPORT DIREC # QY40172
# TIVES WHILE DOING A -PERFORM-. THIS INCLUDES -MOVE- AND -EVALUATE-.  # QY40172
# IF KEYS WERE BUILT FOR EITHER OF THEM, IT WOULD CLOBBER INFORMATION  # QY40172
# NEEDED TO CONTINUE THE -PERFORM-.                                    # QY40172
  
      IF NOT PERFLG                # IF NOT IN THE MIDDLE OF A PERFORM #
        AND STKFLAG                # AND THIS IS A REPORT DIRECTIVE    #
      THEN
        BEGIN                      # INITIALIZE REPORT DIRECTIVE KEY   #
        KEYAREA[0] = CURREPT;      # REPORT NAME                       #
        B<42,6>KEYAREA[0] = B<54,6>NLX[0];  # MINOR KEY FOR REPORT DIR #
        B<48,12>KEYAREA[0] = "00";          # PRESET TO LEVEL 00       #
        END 
  
 # CHECK IF TRANSMISSN HAS DIRECTIVES OF MIXED TYPE WHILE RECORDING #   002120
      IF RECORDFLAG  THEN BEGIN                                         002130
        IF PLACEFLAG EQ 1  THEN                                         002140
          IF (NOT WDIRFLAG AND NP1REC[0])  OR                           002150
             (WDIRFLAG AND NOT NP1REC[0])  THEN BEGIN                   002160
            PLACEFLAG = 77;                                             002170
            STDNO;    END                                               002180
        IF PLACEFLAG EQ 0  THEN PLACEFLAG = 1;                          002190
      END                                                               002200
          WDIRFLAG = NP1REC[0]; 
      STDYES; 
          END 
#THIS PROC WRITES DIRECTIVES TO CATALOG TO FORM SESSIONS #
#  WRTSESS #
      XDEF PROC WRTSESS;
      PROC WRTSESS; 
  BEGIN 
      XREF FUNC INCRDIS;
      IF PLACEFLAG NQ 77   THEN                                         002310
      IF RECORDFLAG AND NOT WDIRFLAG  THEN    BEGIN 
      OPNCAT(CATAFIT, PD$IO, I);   # OPEN CATALOG FILE FOR I/O         #
      IF I NQ 0                    # IF CATALOG NOT OPENED             #
      THEN
        BEGIN 
        STDNO;                     # BAD RETURN                        #
        END 
  
           IF NOTRMX NQ 2000 THEN NOTRMX = NOTRMX - 1;
      KEYAREA[0] = "0";            # LEFT JUSTIFIED. BLANK FILLED.     # FEAT157
      B<6,36>KEYAREA[0] = B<24,36>CURRSESS;                              FEAT157
      B<42,18>KEYAREA[0] = B<42,18>CURRDIR;                              FEAT157
      P<FIT> = LOC(CATAFIT);                                             SYNTAX 
      FITES = 0;                                                         SYNTAX 
      FITWSA = P<KEYWSA>; 
      FITRL = STKPOINTER; 
      FITKA = FITWSA; 
      CATCHK (CPUT, P<FIT>, CDCSCAT); 
      IF FITES EQ DUPLICATEKEY                                           SYNTAX 
      THEN                                                               SYNTAX 
        BEGIN                                                            SYNTAX 
        DIAG(121);                                                       SYNTAX 
        END                                                              SYNTAX 
                                                                         SYNTAX 
      ELSE                                                               SYNTAX 
        BEGIN                                                            SYNTAX 
        IF FITES NQ 0                                                    SYNTAX 
        THEN                                                             SYNTAX 
          BEGIN                                                          SYNTAX 
          DIAG(105, FITES, C<0,7>FITLFN);                                SYNTAX 
          END                                                            SYNTAX 
        MODCAT = TRUE;             # CATALOG FILE WAS MODIFIED         #
        END                                                              SYNTAX 
                                                                         SYNTAX 
      CURRDIR = INCRDIS(INCREMENT[0],CURRDIR);
      B<6,18>PROMPDIR = B<42,18>CURRDIR;
           IF NOTRMX EQ 0 THEN BEGIN
      DIAG(1000); 
           RECORDFLAG = FALSE;
               SEARCHFLAG=FALSE;
           PROMPDIR = NEXTDIR;
         C<0,6>I = C<4,6>CURRSESS;
      DIAG(1001,I); 
           STDNO; 
                               END
         IF B<0,42>CURRDIR NQ O"33333333333333" THEN
                            #MUST BE ALL ZEROS FIRST 7 DIGITS#
          BEGIN 
          DIAG (50);               # TOO MANY DIRECTIVES IN SESSION#
          RECORDFLAG = FALSE; 
          PROMPDIR = NEXTDIR; 
          C<0,6>I = C<4,6>CURRSESS; 
          DIAG (1001,I);            # END OF SESSION MESSAGE #
          STDNO;
          END 
                                              END 
      STDNO;                       # RETURN TO SYNTAX DRIVER           #
  END 
  
  # --------------------------------------------- # 
      XDEF PROC EXIT10; 
 PROC EXIT10;   BEGIN 
 # THIS PROC CLOSES CATALOG BEFORE LOADING NEW OVERLAY #
      AUTOPSY;  # CLOSE ANY OPEN FILES BEFORE EXITING (1,0) # 
      SECONDARY = 0;
      LOADX0; 
 END
  # --------------------------------------------- # 
        #THIS PROC RETURNS TO STDYES IF RECORDFLAG IS FALSE#            001830
#   CRECFLG  #
      XDEF PROC CRECFLG;
      PROC CRECFLG; 
  BEGIN 
          IF NOT RECORDFLAG THEN STDYES;                                001810
      STDNO;
  END 
  
  
  
  
  
                        #PROC TO CHECK IF IT IS AT END OF A DIRECTIVE#
           XDEF PROC CHKNXID; 
           PROC CHKNXID;
           BEGIN IF NLXDIRV[0] THEN STDYES; 
                         #NEXT WORD IS A DIRECTIVE KEY WORD#
                   IF NLX[0] EQ 0 AND NEXTYPE EQ 12 THEN STDYES;
                         #END OF TRANSMITION# 
                   STDNO; 
           END
  
  
  
  
          XDEF PROC SPLACFG;
          PROC SPLACFG; 
          BEGIN IF RECORDFLAG THEN PLACEFLAG = 77;
          SETLXBEGIN;              # SET LXBEGIN                       #
                STDNO;
          END 
#----------------------------------------------------------------------#
#                                                                      #
#     I S I T 7 7                                                      #
#                                                                      #
#     THIS PROCEDURE DETERMINES IF WE ARE PROCESSING AN INTERNAL       #
#     *WHERE* DIRECTIVE OR IF THE USER HAS ENTERED ONE.                #
#----------------------------------------------------------------------#
      XDEF PROC ISIT77; 
      PROC ISIT77;
      BEGIN 
      IF RESTRICTPROC              # IF WE ARE PROCESSING RESTRICTS    #
      THEN
        BEGIN 
        STDYES;                    # RETURN TO CONTINUE PROCESSING     #
        END 
      ELSE
        BEGIN 
        STDNO;                     # RETURN TO ISSUE ERROR             #
        END 
      END 
          XDEF ITEM SAVEDESC; 
CONTROL EJECT;
     # THIS IS THE PLACE TO DO ANY CLEAN UP FOR THE OVERLAY IF AN       000730
       ABORT HAS OCCURRED - NO ASSURANCE OF HOW FAR THE OVERLAY WAS IN  000740
       EXECUTION #                                                      000750
      XDEF PROC AUTOPSY;                                                000760
      PROC AUTOPSY;                                                     000770
      BEGIN 
      IF ABORTED                   # IF QU WAS REPRIEVED               #
      THEN
        BEGIN 
        RLSBMEM;                   # RELEASE BASIC TABLE MEMORY        #
        END 
      IF NOT CDCSCAT               # DON"T BOTHER WITH CDCS FILES      #
      THEN
        BEGIN 
        CLCAT;                     # MAY CLOSE CAT. TO ENSURE INTEGRITY#
        END 
      MODCAT = FALSE;              # CATALOG NOT MODIFIED SINCE CLOSE  #
      IF AREATBLPTR NQ 0           # IF A SUBSCHEMA EXISTS             #
        OR VERSBSCHPTR NQ 0                                             017600
      THEN
        BEGIN 
        P<FIT> = LOC(SCHEMAFIT);   # POSITION TO SUBSCHEMA FIT         #
        IF FITOC EQ OC$OPEN        # IF SUBSCHEMA OPEN                 #
        THEN
          BEGIN 
          CLOSEM(FIT, $DET$, RA0);  # CLOSE FILE, RELEASE BUFFER SPACE #
          END 
        END 
  
      RETURN;                                                           000780
      END 
*CALL CLCAT                                                             017800
  
*IF DEF,DEBUG 
          XDEF PROC Q;
      PROC Q;  BEGIN
      #  SEMANTIC ROUTINES TO PROCESS THE TEMPORARY DEBUG DIRECTIVE *Q*#
      CONTROL NOLIST;     # *CALL XSTD FOLLOWS #
*CALL XSTD
      CONTROL LIST; 
      XDEF BEGIN
          PROC DECTOBIN;  PROC OCTTOBIN;  PROC DUMP1;  PROC STOREABS; 
          PROC SHOW1VAR;  PROC SHOWVARS;  PROC REPLACE;  PROC DUMPRANGE;
           END    # END OF XDEF # 
      ITEM I, J;
      ARRAY [49];  ITEM VARLOC=[50(0)]; 
      ARRAY [1]; ITEM OCTAL C(,,10);
      ARRAY DISPLAY[09]; ITEM DIS C(,,10);
      ITEM ITEMP,K; 
      BASED ARRAY RA [0];  ITEM R, CR C(,,10);
      BASED ARRAY SHOWLOC[0]; ITEM SHOW;
      PROC DECTOBIN;
      BEGIN 
        ITEMP = ICWI[5];
        STDNO;
      END 
      PROC OCTTOBIN;
      BEGIN 
        ITEMP = ICWI[5];
        STDNO;
      END 
      PROC BINTODEC(IN);
      BEGIN 
        ITEM I,II,T,IN; 
        I = IN; IN = "         0";
        FOR T=54 STEP -6 WHILE I GR 0 DO BEGIN
          II = I/10; B<T,6>IN = I - II*10 + O"33"; I = II; END
        RETURN; 
      END 
      PROC BINTOOCT(IN);
      BEGIN 
        ITEM I,T,IN;
        FOR T=0 STEP 3 UNTIL 27 DO
          B<T*2,6>OCTAL[0] = B<T,3>IN + O"33";
        FOR T=30 STEP 3 UNTIL 57 DO 
          B<(T-30)*2,6>OCTAL[1] = B<T,3>IN + O"33"; 
        RETURN; 
      END 
      PROC DUMP1; 
      BEGIN 
        P<RA> = ITEMP; BINTOOCT(R[0]); DIS[0] = " "; DIS[1] = OCTAL[0]; 
        DIS[2] = OCTAL[1]; DIS[3] = " "; DIS[4] = CR[0];
        WRITE(DISPLAY,50,0);
        STDNO;
      END 
      PROC STOREABS;
      BEGIN 
        P<RA> = ITEMP;
        R[0] = ICWI[5];         STDNO;
      END 
      PROC DUMPRANGE; 
      BEGIN 
        P<RA> = ITEMP;
        ITEMP = ICWI[5];
          J = 0;
      NEXTSCREEN: 
        FOR I=0 STEP 5 UNTIL 5   DO BEGIN 
          BINTOOCT(P<RA>+J);
          DIS[I] = " "; 
          B<6,30>DIS[I] = B<30,30>OCTAL[1]; 
          BINTOOCT(R[J]); 
          DIS[I+1] = OCTAL[0]; DIS[I+2] = OCTAL[1]; 
          DIS[I+3] = " "; DIS[I+4] = CR[J]; 
          IF LOC(R[J]) EQ ITEMP THEN GOTO ENDDUMP;
          J=J+1;
        END 
        WRITE(DISPLAY,100,0); 
        GOTO NEXTSCREEN;
      ENDDUMP:  
        WRITE(DISPLAY,(I*10+50),0); 
        STDNO;
      END 
      PROC SHOW1VAR;
      BEGIN 
          VARLOC[5]=LOC(RECORDFLAG); #FOR TURNING THE RECORDING OFF#
          VARLOC[49] = LOC(PROGSTACKLOC); 
        P<SHOWLOC> = VARLOC[ITEMP]; DIS[0] = " VAR[  ]= ";
        BINTODEC(ITEMP); B<30,12>DIS[0] = ITEMP; DIS[3] = " ";
        B<0,60>DIS[4] = SHOW[0];
        BINTOOCT(SHOW[0]); DIS[1] = OCTAL[0]; DIS[2] = OCTAL[1];
        WRITE(DISPLAY,50,0); STDNO; 
      END 
      PROC REPLACE; 
      BEGIN 
        P<SHOWLOC> = VARLOC[ITEMP]; SHOW[0] = ICWI[5];         STDNO; 
      END 
      PROC SHOWVARS;
      BEGIN 
        J = ITEMP; ITEMP = ICWI[5]; 
      NEXTSCREEN: 
        FOR I=0 STEP 5 UNTIL 5   DO BEGIN 
          K = J;
          BINTODEC(K); DIS[I] = " VAR[  ]= "; 
          B<30,12>DIS[I] = K; 
          P<SHOWLOC> = VARLOC[J];    B<0,60>DIS[I+4] = SHOW[0]; 
          BINTOOCT(SHOW[0]);
          DIS[I+1] = OCTAL[0]; DIS[I+2] = OCTAL[1]; DIS[I+3] = " "; 
          IF J EQ ITEMP THEN GOTO ENDSHOW;
          J = J + 1;
        END 
        WRITE(DISPLAY,100,0); GOTO NEXTSCREEN;
      ENDSHOW:  
       WRITE(DISPLAY,(I*10+50),0);   STDNO; 
      END 
      END 
*ENDIF
      END 
      TERM; 
