*DECK SET40 
USETEXT TBASCTB 
USETEXT TCMMDEF 
USETEXT TENVIRN 
USETEXT TSBASIC 
USETEXT TXSTD 
      PROC SET40; 
  
#----------------------------------------------------------------------#
#                                                                      #
#  THE FOLLOWING PROCS ARE XDEF"D WITHIN THIS DECK:                    #
#                                                                      #
#     ALGRPID                      ALLOCATE A GROUP ID FOR BASIC TABLE #
#     SETSRCH                      SET SEARCHFLG + BUILD BASICTBL ENTRY#
#     SET40                        INITIALIZE FOR A FILE ACCESS COMMAND#
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN 
  
      XREF ITEM CURRENTLFPTR I;    # POINTER TO ENTRY FOR CURRENT LF   #
      XREF ITEM DIRAREA B;         # TRUE IF DISPLAY OR IF DIRECTIVE   #
                                   # REFERENCES AREA ITEMS             #
      XDEF ITEM DTP          I = 0; 
      ITEM I            I;         # SCRATCH TEMPORARY                 #
      ITEM J  I;                   # SCRATCH TEMPORARY                 #
      XREF ITEM OLDSEARCH B;   #VALUE OF SEARCHFLAG BEFORE THIS COMMAND#
      XREF ITEM SM$GROUPID   I;    # GROUP ID FOR CURRENT SYNTAX STUFF #
      XREF PROC RECYES; 
      XREF PROC RECNO;
      ITEM TEMP         I;
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     PROC ALGRPID                                                     #
#                                                                      #
#     ALLOCATE GROUP ID                                                #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC ALGRPID;
      PROC ALGRPID; 
      BEGIN 
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
      SM$GROUPID = CMM$AGR(0);     # SAVE GROUP ID IN SM$GROUPID       #
      P<BASICTABLE> = BASCPTR;     # POSITION TO BASIC TABLE           #
      BASC$GROUPID[BASTABIND] = SM$GROUPID;  # SAVE GROUP ID IN BASIC  #
                                             # TABLE                   #
      STDYES; 
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC SETSRCH;
 # THIS PROC SETS SEARCHFLAG, OBTAINS THE NEXT ENTRY IN BASICTABLE #
 # AND SETS BASTABIND TO POINT TO THIS NEXT ENTRY                  #
 PROC SETSRCH;   BEGIN
      NEXTXMISSN = FALSE; 
      SEARCHFLAG = TRUE;           #THIS IS A 4X,0 OVERLAY COMMAND     #
      DIRAREA = FALSE;             # INITIAL ASSUMTPION                #
      IF RECORDFLAG THEN
        BEGIN 
        RETURN;                    #DO NOT ASSIGN BASIC TBL IF RECORD  #
        END 
  
      P<BASICTABLE> = BASCPTR;     # POSITION TO CURRENT BASICTABLE LOC#
  
 # GET MORE MEMORY IF NEEDED #
      IF BASTABIND EQ 6  OR  BASTABLOC EQ 0  THEN BEGIN 
        TEMP = CMM$ALF(15,0,0); 
  # ADD ON TO EXISTING TABLE #
        IF BASTABIND EQ 6  THEN BEGIN 
          BASCODE [7] = CONTCODE; 
          BASCLAST [7] = TEMP;    END 
  # START NEW TABLE   # 
          ELSE
          BEGIN BASTABLOC = TEMP; 
                CURRENTLFPTR = 0; 
                DIRCODE = " ";
         END
        P<BASICTABLE> = TEMP; 
      BASCPTR = TEMP;                                                   006270
        BASTABIND = 0;
        END 
      ELSE BASTABIND = BASTABIND + 1; 
      TEMP = CLXWRD [0];                                                005080
      I = 0;                                                            005090
      J = 0;                       # WILL HOLD *DIRCODE* FOR S/M/R DIRS#
      IF TEMP EQ O"1112"  THEN I = IFCODE;
      IF TEMP EQ O"1104"  THEN I = DISPCODE;                            005110
      IF TEMP EQ O"1113"  THEN I = INSTCODE;                            005120
      IF TEMP EQ O"1126"  THEN I = UPDCODE;                             005130
      IF TEMP EQ O"1102"  THEN I = DELTCODE;                            005140
      IF TEMP EQ O"1125"  THEN I = STOPCODE;                            005150
      IF TEMP EQ O"3032"  THEN I = MOVECODE;                            005160
          IF TEMP EQ O"3133" THEN I = EVALCODE; 
      IF TEMP EQ O"1110"  THEN I = EXTRCODE;                            005180
                                   # S/M/R DIRECTIVES HAVE DIFFERENT   #
                                   # *BASCODE* BUT SAME *DIRCODE* AS   #
                                   # D/I/U DIRECTIVES                  #
      IF TEMP EQ O"1116"
      THEN
        BEGIN 
        I = MODCODE;
        J = UPDCODE;
        END 
      IF TEMP EQ O"1121"
      THEN
        BEGIN 
        I = REMCODE;
        J = DELTCODE; 
        END 
      IF TEMP EQ O"1143"
      THEN
        BEGIN 
        I = STORCODE; 
        J = INSTCODE; 
        END 
  
      BASCODE [ BASTABIND ] = I;                                        005190
      IF J NQ 0                    # IF *DIRCODE* DIFF THAN *BASCODE*  #
      THEN
        BEGIN 
        I = J;
        END 
      IF DIRCODE EQ " "            # IF THIS IS NEW TABLE              #
      THEN
        BEGIN 
        DIRCODE = I + O"33";       # SET DIRECTIVE CODE                #
        END 
      ELSE                         # IF THIS IS ADDITION TO OLD TABLE  #
        BEGIN 
        DIRCODE = "Z";
        END 
      RETURN; 
  END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
# BEGINNING OF EXECUTABLE CODE FOR   S E T 4 0                         #
      BEGIN 
          DTP = 0;
      OLDSEARCH = SEARCHFLAG;      #SAVE OLD SEARCHFLAG                #
      IF NOT OLDSEARCH THEN        #IF FIRST 4X CMD IN XMISSN          #
        BEGIN 
        DESPASS = FALSE;
        FILEPASS = FALSE; 
        END 
      SETSRCH;  STDNO;
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
      END 
      TERM
