*DECK PERFORM 
USETEXT TCMMDEF 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TREPORT 
USETEXT TXSTD 
      PROC PERFORM; 
  
#----------------------------------------------------------------------#
#                                                                      #
#  THE FOLLOWING PROCS ARE XDEF"D WITHIN THIS DECK:                    #
#                                                                      #
#     SESINIT                      INITIALIZES A NEW SAVESESS ENTRY    #
#     SIDCHK                       CHECKS THAT DIR. ID IS LE 3 CHARS   #
#     STCOND                       SAVES STACK POINTERS FOR CONDITIONS #
#     STD1                         STORES FIRST DIRECTIVE ID           #
#     STD2                         STORES SECOND DIRECTIVE ID          #
#     STEXPR                       STORES VALUE FOR *REPEAT* EXPRESSION#
#     STPASS                       SETS *PASS* FLAG IN PERFORMLIST     #
#     STSESS                       STORES SESSION INFO FOR PERFORM     #
#     STVETO                       SETS *VETO* FLAG IN PERFORMLIST     #
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN 
  
      ARRAY CVTPARAM [1:1] S(2);    #FOR CONVERT PARAMETERS # 
        ITEM FROMCHAR   U(0,4,4), 
            ETYPE      U(0,0,3),
             NMCHAR     U(0,12,12), 
             FROMPTR    U(0,24,18), 
             TOWD       U(0,42,18), 
             CVTCODE    U(1,0,6), 
            STACKADD   U(1,6,18), 
             FROMWD     U(1,24,18), 
             MVWD1  I(0,0,60),     MVWD2   I(1,0,60); 
      ARRAY ATTR S(2);             # ATTRIBUTES OF INTEGER REPEAT      #
                                   # COUNT USED FOR CONVERT            #
        BEGIN 
        ITEM AWPOS I(0,18,18);     # ADDRESS OF VALUE                  #
        END 
      ARRAY ATTR2 S(2);            # ATTRIBUTES USED FOR CONVERT       #
        BEGIN 
        ITEM AWPOS2 I(0,18,18);    # ADDRESS OF VALUE                  #
        END 
      ITEM DATACODE     I;
      ITEM I            I;         # SCRATCH TEMPORARY                 #
      ITEM INTEGERESULT I;         # FINAL RESULT FROM CONVERT         #
      BASED ARRAY PERFORMLIST [1:15]  S(2); 
        ITEM PERFIRST  I(0,24,18),
             PERCURRT  I(0,42,18),
             PERCOUNTR I(0,0,18), 
             PERLAST   I(1,42,18),
             PERCURRDIR I (1,6,18), 
             PERVETO   B(1,0,1),
             PERTIMES  B(1,1,1),
             PERUNTIL  B(1,2,1),
             PERPASS   B(1,3,1),
             PERCOND   I(1,24,18),
             PER1  I(0,0,60),   PER2   I(1,0,60); 
      ITEM RC           I;         # RETURN CODE FROM EXPEVAL          #
      ITEM RETCD        I;         # RETURN CODE                       #
      BASED ARRAY SAVESESS [1:31]  S(2);   # USED FOR PERFORM # 
        ITEM SVSESSID  C(0,6,6),
             SVDIRONE  C(0,42,3), 
             SVDIRTWO  C(1,0,3),
             SVPTR     I(1,42,18);
      ITEM SESSPTR      I;
  
      XREF PROC CONVERT;           # DATA TYPE CONVERSION              #
      XREF PROC DIAG;              # ISSUE DIAGNOSTIC MESSAGE TO USER  #
      XREF PROC EXPEVAL;           # EXPRESSION EVALUATION             #
      XREF PROC FIGSUB;            # PROCESS FIGURATIVE SUBSCRIPT      #
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
 # THIS PROC INITIALIZES A NEW SAVESESS ENTRY # 
 # INSESS # 
      PROC INSESS;       BEGIN
      IF RECORDFLAG  THEN STDYES; 
      IF SESEMPTY EQ 0  THEN BEGIN DIAG (76);  STDNO;  END
      SESSPTR = SESEMPTY; 
      I = PERLAST [LASTPERF]; 
      IF I NQ 0  THEN SVPTR[I] = SESSPTR; 
        ELSE PERFIRST [LASTPERF] = SESSPTR; 
      PERLAST [LASTPERF] = SESSPTR; 
      SVDIRONE [SESSPTR] = "001"; 
      SVDIRTWO [SESSPTR] = "999"; 
      SESEMPTY = SVPTR [SESSPTR]; 
      SVPTR [SESSPTR] = 0;
      RETURN;               END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC SESINIT;
 # THIS PROC SETS UP A NEW SAVESESS ENTRY FOR THE CURRENT SESSION # 
 # SESINIT #
      PROC SESINIT;      BEGIN
      INSESS; 
      IF I NQ 0  THEN  SVSESSID [SESSPTR] = SVSESSID [I]; 
      STDYES;            END
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC SIDCHK; 
 # THIS PROC CHECKS THAT A DIRECTIVE ID IS LE 3 CHARACTERS LONG # 
      PROC SIDCHK; BEGIN
      IF CURLENG GR 3  THEN  STDNO; 
      STDYES;   END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
 # THIS PROC SAVES STACK POINTERS FOR CONDITIONS #
 # STCOND  #
      XDEF PROC STCOND; 
 PROC STCOND;  BEGIN
      IF RECORDFLAG  THEN STDNO;
      PERCOND [LASTPERF] = PROGSTACKLOC;
      PERUNTIL [LASTPERF] = TRUE; 
      STDNO;   END
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC STD1; 
 # THIS PROC STORES THE FIRST DIRECTIVE ID #
      PROC STD1;  BEGIN 
      IF RECORDFLAG  THEN STDNO;
      C<3-CURLENG,CURLENG>SVDIRONE[SESSPTR] = C<0,CURLENG>ICW[0]; 
      SVDIRTWO[SESSPTR] = SVDIRONE[SESSPTR];
      STDNO;
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC STD2; 
 # THIS PROC STORES DIRECTIVE TWO # 
      PROC STD2;  BEGIN 
      IF RECORDFLAG  THEN STDYES; 
      C<3-CURLENG,CURLENG>SVDIRTWO[SESSPTR] = C<0,CURLENG>ICW[0]; 
      IF SVDIRTWO[SESSPTR] LS SVDIRONE[SESSPTR] THEN STDNO; 
      # NORMAL RETURN IF DIR. 2 GR DIR 1# 
      STDYES; 
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
 # THIS PROC DETERMINES THE VALUE OF AN ARITHMETIC EXPRESSION USED #
 # IN THE -REPEAT- PHRASE AND SAVES THE VALUE IN PERCOND            # 
      XDEF PROC STEXPR; 
 PROC STEXPR;   BEGIN 
      IF RECORDFLAG  THEN STDYES; 
      MVWD1[1] = 0;     MVWD2[1] = 0; 
      AWPOS[0] = LOC(INTEGERESULT); 
      TOWD[1] = LOC(ATTR) - 1;
      IF PROGSTACKLEN LS 0  THEN BEGIN
   # PROCESS EXPRESSION WHICH IS SINGLE ITEM #
        DATACODE = DATATYPE;
        FROMPTR [1] = DATAWORDADDR; 
        IF FIGLITDATA EQ S"DATANAME"  THEN BEGIN
          #SET UP LINKED POINTER FOR DESCRIBED ITEMS# 
          FROMWD [1] = DATANAMEBASE;     END
        NMCHAR [1] = DATALENG;
        FROMCHAR [1] = DATACHARPOS; 
        IF DATACODE GQ 1           # IF NUMERIC, INTEGER, OR UNNORM    #
          AND DATACODE LQ 3 
        THEN
          #SET UP ATTRIBUTE POINTER IF REQUIRED # 
          BEGIN 
          IF DATANAMEPTR NQ 0      # IF ATTRIB TABLE EXISTS            #
          THEN
            BEGIN 
            FROMPTR[1] = DATANAMEPTR; 
            END 
          ELSE
            BEGIN 
            AWPOS2[0] = DATAWORDADDR;  # BUILD ATTRIB TABLE            #
            FROMPTR[1] = LOC(ATTR2) - 1;
            END 
          END 
        IF INDICED  THEN BEGIN
          STACKADD [1] = INDCTBLOC; 
          ETYPE [1] = 4;   END
        END 
      ELSE BEGIN    # PROCESS FULL EXPRESSION # 
      EXPEVAL(RC);                 # EVALUATE EXPRESSION               #
        DATACODE = RESULTUSAGE; 
        FROMPTR [1] = RESULTSLOC; 
        NMCHAR [1] = RESULTSIZE;
        END 
      CVTCODE [1] = (DATACODE - 1) * 6  + 10; 
   #SEND DIAGNOSTIC IF WRONG DATA TYPE #
      IF DATACODE LQ 0  OR  DATACODE GR 5  OR 
        FIGLITDATA EQ S"CONDEXPR"   THEN STDNO; 
      IF ETYPE[1] EQ 4
      THEN
        BEGIN 
        FIGSUB(CVTPARAM, RETCD);
        END 
  
      ELSE
        BEGIN 
        CONVERT(CVTPARAM, RETCD); 
        END 
  
      IF RETCD NQ 0  THEN STDNO;
      PERCOND [LASTPERF] = INTEGERESULT;
      PERTIMES [LASTPERF] = TRUE; 
   # RELEASE MEMORY FOR EXPRESSION #
      IF PROGSTACKLEN GR 0 THEN 
        BEGIN 
        CMM$FRF(PROGSTACKLOC);
        END 
      IF INDICED THEN 
        BEGIN 
        CMM$FRF(INDCTBLOC); 
        END 
      STDYES; 
  END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
 # THIS PROC SETS THE PASS FLAG IN  PERFORMLIST # 
      XDEF PROC STPASS; 
 PROC STPASS;  BEGIN
      IF RECORDFLAG  THEN STDNO;
      PERPASS [LASTPERF] = TRUE;
      STDNO;  END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC STSESS; 
#THIS PROC STORES INITIAL INFORMATION FOR A SESSION 
 SPECIFIED IN PERFORM DIRECTIVE # 
      PROC STSESS;  BEGIN 
      P<PERFORMLIST> = APERFORMLIST;
      P<SAVESESS> = ASAVESESS;
      IF RECORDFLAG  THEN BEGIN 
        IF C<0,CURLENG>ICW [0]  EQ  C<4,6>CURRSESS  THEN
          BEGIN DIAG (214);  STDNO;  END
        END 
      INSESS; 
      SVSESSID [SESSPTR] = BLK; 
      C<0,CURLENG>SVSESSID[SESSPTR] = C<0,CURLENG>ICW[0]; 
      CURRSESS = BLK; 
      B<24,36>CURRSESS = B<0,36> SVSESSID [SESSPTR];
      STDYES; 
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
 # THIS PROC SETS THE VETO FLAG IN PERFORMLIST #
      XDEF PROC STVETO; 
 PROC STVETO;   BEGIN 
      IF RECORDFLAG  THEN STDNO;
     # IF BATCH MODE, IGNORE VETO # 
      IF TERMINAL NQ 0  THEN
      PERVETO [LASTPERF] = TRUE;
      STDNO;  END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
      END 
      TERM
