*DECK PEREXEC 
USETEXT TCLFN 
USETEXT TCMMDEF 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TOPTION 
USETEXT TREPORT 
USETEXT TXSTD 
      PROC PEREXEC; 
#----------------------------------------------------------------------#
#                                                                      #
#  THE FOLLOWING PROCS ARE XDEF"D WITHIN THIS DECK:                    #
#                                                                      #
#     PERBEGIN                     BEGIN OR CONTINUE A PERFORM         #
#     PERCKDM                      CHECK IF DUMMY PERFORM              #
#     PEREND                       ERROR - ERASE ALL PERFORM TABLES    #
#     PERINIT                      INITIALIZE PERFORM TABLES           #
#     PERNEXT                      GET NEXT SESSION FOR PERFORM        #
#     TSVETO                       PERFORM - WRITE OUT VETO MSG/REPLIES#
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN 
  
      ITEM CTEMP C(10);                # TEMP CHARACTER ITEM #
      XREF ITEM DUMMY        I;    # SCRATCH TEMPORARY                 #
      ITEM I            I;         # SCRATCH TEMPORARY                 #
      ITEM K            I;         # SCRATCH TEMPORARY                 #
      ITEM RC                I;    # RETURN CODE FROM EXPEVAL          #
      XREF ITEM SESSPTR      I; 
      BASED ARRAY PERFORMLIST [1:15] S(2);
        BEGIN 
        ITEM  PERCOND       I(01,24,18);    # POINTS TO STACK OR COND  #
        ITEM  PERCOUNTR     I(00,00,18);    # NO. TIMES EXECUTED SO FAR#
        ITEM  PERCURRDIR    I(01,06,18);    # XMISSION ID BEING EXEC   #
        ITEM  PERCURRT      I(00,42,18);    # PTR TO CURR. SAVESESS ENT#
        ITEM  PERFIRST      I(00,24,18);    # PTR TO 1ST SAVESESS ENTRY#
        ITEM  PERLAST       I(01,42,18);    # PTR TO LAST SAVESESS ENT #
        ITEM  PERPASS       B(01,03,01);    # TRUE IF -PASS- SPECIFIED #
        ITEM  PERTIMES      B(01,01,01);    # TRUE IF -REPEAT- SPEC    #
        ITEM  PERUNTIL      B(01,02,01);    # TRUE IF -UNTIL- SPECIFIED#
        ITEM  PERVETO       B(01,00,01);    # TRUE IF -VETO- SPECIFIED #
        ITEM  PER1          I(00,00,60);    # WORD 1                   #
        ITEM  PER2          I(01,00,60);    # WORD 2                   #
        END 
  
      BASED ARRAY SAVESESS [1:31]  S(2);
        BEGIN 
        ITEM  SVDIRONE      C(00,42,03);    # 1ST DIRECTIVE TO BE EXEC #
        ITEM  SVDIRTWO      C(01,00,03);    # LAST DIRECTIVE TO BE EXEC#
        ITEM  SVPTR         I(01,42,18);    # PTR TO NEXT ENTRY        #
        ITEM  SVSESSID      C(00,06,06);    # SESSION-ID               #
        END 
  
  
      XREF PROC DIAG;              # ISSUE DIAGNOSTIC MESSAGE TO USER  #
      XREF PROC EXPEVAL;           # EVALUATE AN EXPRESSION STACK      #
      XREF FUNC KEYLQHI B;         # FUNTION TO TELL IF THIS SESSION   #
      XREF PROC READ;              # READ RESPONSE FROM THE USER       #
      XREF PROC RECNO;
      XREF PROC RECYES; 
      XREF PROC SYNIO;             # INITIATE ANOTHER READ OF INPUT    #
      XREF PROC SYNTAX;            # RESTART SYNTAX CRACKING           #
      XREF PROC WRITE;             # WRITE MESSAGE TO THE USER         #
                                   # KEY DENOTES THE END OF THIS SERIES#
  
  
  
  
  
#----------------------------------------------------------------------#
  
  
CONTROL EJECT;
      XDEF PROC PERINIT;
      PROC PERINIT;  BEGIN
#                                      #
#        P E R I N I T                 #
#                                      #
 # THIS PROC INITIALIZES THE PERFORMLIST TABLE FOR A PERFORM #
 # REQUEST (IF NECESSARY,GETTING SPACE FOR PERFORMLIST #
 # AND SAVESESS TABLES)                               # 
      IF RECORDFLAG  THEN STDYES; 
      IF APERFORMLIST EQ 0 THEN        # CHECK IF TABLE CM ASSIGNED#
        BEGIN                          # GET TABLE SPACE AND #
        APERFORMLIST = CMM$ALF(30,0,0);  # INITIALIZE                  #
        ASAVESESS = CMM$ALF(62,0,0);
        P<SAVESESS> = ASAVESESS;
        FOR I=1 STEP 1                                                   SYNTAX 
          UNTIL 30                                                       SYNTAX 
        DO                                                               SYNTAX 
          BEGIN                                                          SYNTAX 
          SVPTR[I] = I + 1;                                              SYNTAX 
          END                                                            SYNTAX 
                                                                         SYNTAX 
        SVPTR[31] = 0;
        SESEMPTY = 1; 
        LASTPERF = 0; 
        END 
      P<PERFORMLIST> = APERFORMLIST;
      P<SAVESESS> = ASAVESESS;
      IF PERFLG THEN PERCURRDIR[LASTPERF] = B<42,18>KEYAREA[0];          FEAT157
      IF PERDUMMY 
      THEN                         # IF DUMMY PERFORM                  #
        BEGIN 
        STDYES; 
        END 
  
      IF SECONDARY EQ CP2B[0]      # IF IN *PERFORM* SECONDARY         #
      THEN
        BEGIN 
        LASTPERF = LASTPERF + 1;   # MUST BE A NEW *PERFOMM* JUST      #
                                   # ENCOUNTERED, SO BUMP COUNTER OF   #
                                   # LAST PERFORM.                     #
        IF LASTPERF GR 15          # IF PERFORM TABLE OVERFLOW         #
        THEN
          BEGIN 
          DIAG(76);                # DIAGNOSE PERFORM TABLE OVERFLOW   #
          PEROVER;                 # EXIT COMPLETELY FROM PERFORM MODE #
          READFROM = S"INPUT";     # SET TO READ FROM INPUT, NOT CAT.  #
          STDNO;                   # RETURN TO *NO* SIDE               #
          END 
  
        END 
  
      STDYES;                                                            SYNTAX 
      END 
CONTROL EJECT;
      XDEF PROC PERCKDM;
      PROC      PERCKDM;
#                                                                      #
#        P E R C K D M                                                 #
#                                                                      #
#  THIS PROC RETURNS TO *STDYES* IF DOING A DUMMY PERFORM (AND NOT     #
#  RECORDING), AND GOES TO *STDNO* OTHERWISE.                          #
  
      BEGIN 
      IF PERDUMMY 
        AND NOT RECORDFLAG
      THEN                         # DUMMY PERFORM                     #
        BEGIN 
        STDYES; 
        END 
  
      ELSE
        BEGIN 
        STDNO;
        END 
      END 
      CONTROL EJECT;
      XDEF PROC PERBEGIN; 
      PROC PERBEGIN;
#                                      #
#        P E R B E G I N               #
#                                      #
#  THIS PROC BEGINS (OR CONTINUES) EXECUTION OF A -PERFORM- DIRECTIVE  #
#                                                                      #
      BEGIN 
      IF RECORDFLAG THEN                                                 SYNTAX 
        BEGIN                                                            SYNTAX 
        STDNO;                     #DO NOTHING IF RECORDING            # SYNTAX 
        END                                                              SYNTAX 
                                                                         SYNTAX 
      IF IFFAIL THEN
        BEGIN      #  IGNORE -PERFORM- IF PRECEEDED BY UNTRUE -IF- #
        PEROVER;
        IFFAIL = FALSE; 
        STDNO;                                                           SYNTAX 
        END 
      SESSPTR = PERFIRST [LASTPERF];
      IF PERDUMMY THEN SESSPTR = PERCURRT [LASTPERF]; 
      PERDUMMY = FALSE; 
      PERCURRT [LASTPERF] = SESSPTR;
      PERDO;
      STDYES;                                                            SYNTAX 
      END 
      CONTROL EJECT;
      PROC PERDO;  BEGIN
#                                      #
#        P E R D O                     #
#                                      #
# THIS PROC INITIALIZES FOR PERFORMANCE OF A NEW SESSION #
      ITEM NEXTFLAG B;
      NEXTFLAG = FALSE; 
      HIGHKEY = "0         "; 
      B<6,36> HIGHKEY = SVSESSID [SESSPTR]; 
      LOWKEY = HIGHKEY; 
      B<42,18> HIGHKEY = SVDIRTWO [SESSPTR];
      READFROM = S"GET1ST"; 
      I = PERCURRDIR [LASTPERF];
      IF I EQ 0  THEN  I = SVDIRONE [SESSPTR];
      ELSE NEXTFLAG = TRUE; 
      B<42,18> LOWKEY = I;
      IF C<7,3> LOWKEY EQ "001"   THEN MAJORKEYLEN = 7; 
        ELSE MAJORKEYLEN = 10;
      KEYAREA[0] = LOWKEY;                                               FEAT157
      PERFLG = TRUE;
      CURRSESS = BLK; 
      B<24,36> CURRSESS = B<0,36> SVSESSID [SESSPTR]; 
      IF NEXTFLAG  THEN SYNIO;
      PERVFLAG = 0; 
      IF PERVETO [LASTPERF] THEN PERVFLAG = 1;
      IF PERPASS [LASTPERF] THEN PERVFLAG = 2;
      RETURN; 
      END 
      CONTROL EJECT;
      XDEF PROC PERNEXT;
      PROC PERNEXT;  BEGIN
#                                      #
#        P E R N E X T                 #
#                                      #
# THIS PROC BEGINS EXECUTION OF NEXT SESSION IN PERFORM LIST #
  
      RECNO;                       # RETURN TO STDNO IF RECORDING      #
      SESSPTR = PERCURRT [LASTPERF];
        PERDUMMY = FALSE; 
      IF PROCEXFLAG EQ 2  THEN BEGIN
        SESSPTR = PERLAST [LASTPERF]; 
        GOTO PERNX35;   END 
      IF SESSPTR EQ PERLAST [LASTPERF]  THEN GOTO PERNX20;
      SESSPTR = SVPTR [SESSPTR];
 PERNX03: 
      PERCURRDIR [LASTPERF] = 0;
 PERNX05:  PERCURRT [LASTPERF] = SESSPTR; 
 PERNX10:  PERDO; 
      STDNO;
 PERNX20:  # END OF THIS PERFORM #
      IF CATAFITES NQ 0                                                  SYNTAX 
        OR NOT PERFLG              # IF PERFORM HAS BEEN ABORTED       #
      THEN                                                               SYNTAX 
        BEGIN                                                            SYNTAX 
        GOTO PERNX40;              #IF -GET1ST- ERROR                  # SYNTAX 
        END                                                              SYNTAX 
                                                                         SYNTAX 
                             # EXIT IF -SYNIO- FOUND AN ERROR # 
      # TEST FOR CONDITION TO BE SATISFIED BEFORE COMPLETION #
      IF NOT PERUNTIL [LASTPERF] THEN GOTO PERNX30; 
      B<0,60> PROGSTACKLOC = PERCOND [LASTPERF];
      LOGICALRESLT = TRUE;
      EXPEVAL(RC);                 # EVALUATE EXPRESSION               #
      IF LOGICALRESLT  THEN GOTO PERNX35;  #GO TO NEXT PERFORM# 
 PERNX25:   # RE-START THIS PERFORM # 
      SESSPTR = PERFIRST [LASTPERF];
      GOTO PERNX03; 
 PERNX30:  # TEST FOR NBR TIMES TO BE REPEATED BEFORE COMPLETION #
      IF NOT PERTIMES [LASTPERF]  THEN GOTO PERNX35;
      PERCOUNTR [LASTPERF] = PERCOUNTR [LASTPERF]  + 1; 
      IF PERCOUNTR [LASTPERF] LS PERCOND [LASTPERF]  THEN GOTO PERNX25; 
      ELSE PERCOUNTR[LASTPERF] = 0; 
 PERNX35:   # GO ON TO NEXT PERFORM, OR BACK TO USER IF NO MORE # 
      SVPTR [SESSPTR] = SESEMPTY;   #LINK SAVESESS ENTRIES #
      SESEMPTY = PERFIRST [LASTPERF];  # BACK TO EMPTY CHAIN #
      PER1[LASTPERF] = 0;   PER2[LASTPERF] = 0; 
      LASTPERF = LASTPERF - 1;
      IF LASTPERF EQ 0  THEN GOTO PERNX40;
      IF PROCEXFLAG EQ 2  THEN BEGIN
        SESSPTR = PERLAST [LASTPERF]; 
        GOTO PERNX35;  END
      SESSPTR = PERCURRT [LASTPERF];
      IF SESSPTR EQ 0  THEN 
      SESSPTR = PERFIRST [LASTPERF];
      GOTO PERNX05; 
 PERNX40:   # END OF PERFORM TABLES, RELEASE SPACE AND QUIT#
      PEROVER;
      INPUTSAVED = FALSE;   #GO BACK TO SYNTAX #
      SYNTAX;               #TO GET NEXT DIRECTIVE# 
             END
      CONTROL EJECT;
      XDEF PROC PEROVER;
      PROC PEROVER; 
#                                      #
#        P E R O V E R                 #
#                                      #
#  THIS PROC RETURNS CM ASSIGNED BY -PERFORMLIST- AND -SAVESESS- AND  # 
#  EXITS OUT OF -PERFORM- MODE  # 
      BEGIN 
      FOR I=1 STEP 1                                                     SYNTAX 
        UNTIL 15                                                         SYNTAX 
      DO                                                                 SYNTAX 
        BEGIN 
        IF PERUNTIL[I] AND PER1[I] NQ 0 THEN
                                             CMM$FRF(PERCOND[I]); 
        END 
  
      CMM$FRF(APERFORMLIST);
      CMM$FRF(ASAVESESS); 
      APERFORMLIST = 0; 
      ASAVESESS = 0;
      PERFLG = FALSE; 
      PERVFLAG = 0; 
      PROCEXFLAG = 0; 
      RETURN; 
      END 
      CONTROL EJECT;
      XDEF PROC PEREND; 
      PROC PEREND;
#                                      #
#        P E R E N D                   #
#                                      #
#  THIS PROC IS CALLED TO ERASE ALL SESSIONS SETUP FOR THE LAST  #
#  -PERFORM- IN CASE OF A SYNTAX ERROR  # 
      BEGIN 
      IF RECORDFLAG THEN                                                 SYNTAX 
        BEGIN                                                            SYNTAX 
        STDNO;                     #EXIT EARLY IF RECORDING            # SYNTAX 
        END                                                              SYNTAX 
                                                                         SYNTAX 
      IF PERLAST [LASTPERF] NQ 0 THEN 
        BEGIN 
        SVPTR [PERLAST[LASTPERF]] = SESEMPTY; 
        SESEMPTY = PERFIRST [LASTPERF]; 
        END 
         #  BACKUP ONE ENTRY IN PERFORM LIST  # 
      LASTPERF = LASTPERF - 1;
      IF LASTPERF EQ 0                                                   SYNTAX 
      THEN                                                               SYNTAX 
        BEGIN                                                            SYNTAX 
        PEROVER;                                                         SYNTAX 
        END                                                              SYNTAX 
      STDNO;                                                             SYNTAX 
      END 
      CONTROL EJECT;
      XDEF PROC TSVETO; 
      PROC TSVETO;
#                                      #
#        P E R V E T O                 #
#                                      #
 # THIS PROC TESTS THE VETO FLAGS. IF VETO MODE, THE CURRENT# 
 # DIRECTIVE IS WRITTEN TO THE TERMINAL.  IT WILL BE #
 # EXECUTED OR NOT, DEPENDING ON THE USER RESPONSE. # 
      BEGIN 
      ARRAY RDIN [1:3]; 
        ITEM RDWORD;
      ARRAY RESPOND [1:3];
      ITEM RSP = [" VALID -VE", "TO- RESPON", "SES ARE - "];
      ITEM PROCEED C(10) = VETOGO,
           EXIT    C(10) = VETOSTOP,
           YES     C(10) = VETOYES, 
           NO      C(10) = VETONO,
           ANSWER  C(10) = VETOANSW;
 # CHECK IF TRANSMISSION MUST BE SENT TO USER # 
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
      IF PROCEXFLAG EQ 1                                                 SYNTAX 
      THEN                                                               SYNTAX 
        BEGIN                                                            SYNTAX 
        STDYES;                    #RETURN IF PROCEED                  # SYNTAX 
        END                                                              SYNTAX 
                                                                         SYNTAX 
      IF PROCEXFLAG EQ 2                                                 SYNTAX 
      THEN                                                               SYNTAX 
        BEGIN                                                            SYNTAX 
        STDNO;                     #RETURN IF EXIT                     # SYNTAX 
        END                                                              SYNTAX 
                                                                         SYNTAX 
      IF (PERVFLAG EQ 2)           # IF *PASS*                         #
        OR (PERVFLAG EQ 0          # NEITHER PASS NOR VETO             #
          AND NOT VETOFLAG)        # AND VETO OFF                      #
      THEN                                                               SYNTAX 
        BEGIN                                                            SYNTAX 
        STDYES;                                                          SYNTAX 
        END                                                              SYNTAX 
                                                                         SYNTAX 
                                       # RETURN IF GLOBAL AND PERFORM # 
                                       # VETO ARE OFF # 
      CTEMP = KEYAREA[0];                                                FEAT157
      KEYAREA[0] = BLK;   # SAVE KAEYAREA - SETUP BLANK CARRIAGE CTL #   FEAT157
      WRITE(KEYWSA, QUIRL + 11, I);  #DISPLAY DIRECTIVE                # SYNTAX 
      KEYAREA[0] = CTEMP; # RESTORE KEYAREA #                            FEAT157
      FOR DUMMY=DUMMY              #LOOP UNTIL EXPLICIT EXIT OUT       # SYNTAX 
        WHILE TRUE                                                       SYNTAX 
      DO                                                                 SYNTAX 
        BEGIN 
        WRITE(ANSWER, 6, I);       #REQUEST RESPONSE FROM USER         # SYNTAX 
        READ(RDIN, I, 40, K);      #GET USER RESPONSE                  # SYNTAX 
        IF I GR 10 THEN I = 10;         # ONLY WANT UP TO TEN CHARS    # FEAT157
        I = I * 6;                      # CONVERT FROM CHARS BITS      # FEAT157
        K = B<0,I>RDWORD[1];           # USER RESPONSE IS IN -K- #
        IF K EQ B<0,I>YES                                                SYNTAX 
        THEN                                                             SYNTAX 
          BEGIN                                                          SYNTAX 
          STDYES;                                                        SYNTAX 
          END                                                            SYNTAX 
                                                                         SYNTAX 
        IF K EQ B<0,I>NO                                                 SYNTAX 
        THEN                                                             SYNTAX 
          BEGIN                                                          SYNTAX 
          STDNO;                                                         SYNTAX 
          END                                                            SYNTAX 
                                                                         SYNTAX 
        IF K EQ B<0,I>PROCEED THEN
          BEGIN 
          PROCEXFLAG = 1;              # USER HAS TYPED -PROCEED- # 
          STDYES;                                                        SYNTAX 
          END 
        IF K EQ B<0,I>EXIT THEN 
          BEGIN                        # USER HAS TYPED -EXIT- #
          PROCEXFLAG = 2; 
          STDNO;                                                         SYNTAX 
          END 
        WRITE(RESPOND, 70, I);         #TELL USER WHAT TO RESPOND      # SYNTAX 
        END 
      END 
  
  
  
  
  
  
      END 
      TERM
