*DECK EXTRACT 
USETEXT TBASCTB 
USETEXT TCMMDEF 
USETEXT TDESATT 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TINDTBL 
USETEXT TLFNINF 
USETEXT TOPTION 
USETEXT TSBASIC 
USETEXT TXSTD 
      PROC EXTRACT; 
  
#----------------------------------------------------------------------#
#                                                                      #
#  THE FOLLOWING PROCS ARE XDEF"D WITHIN THIS DECK:                    #
#                                                                      #
#     BUDEXTR                      BUILD EXTRACT TABLE ENTRY           #
#     BUDFIT                       INITIALIZES INFO FOR EXTRACT LFN    #
#     CHKAS                        CHECK IF -AS- CLAUSE LEGAL          #
#     CHKFIGS                      CHECK FOR LEGAL USE OF FIG SUBSCRIPT#
#     DIROVOFF                     SET DIRECTORY OVERRIDE OFF          #
#     DIROVON                      SET DIRECTORY OVERRIDE ON           #
#     GET15                        ALLOCATE A 15 WORD BLOCK            #
#     NEWLFNLINK                   LINK NEW LFN TABLE INTO LFNLIST     #
#     RLSALL                       RELEASE EXTRACT TABLE SPACE         #
#     RSDESLIST                    RESTORE DESLIST                     #
#     SETDES                       ALLOC AND SET A DESCRIBE ENTRY      #
#     SVDESLIST                    SAVE AND ZERO DESLIST               #
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN 
  
      XREF BASED ARRAY ANAME2[1:4];;   # TO PASS DATANAME TO -SEARCH-  #
      XDEF ITEM ATTR  I;           # LOC OF DESCRIBE ATTRIBUTE ENTRY   #
      ITEM ATTRPTR I;              # PARAMETER TO -SEARCH-             #
      ITEM CMLEFT       I;         # REMAINING CM IN CURRENT BLOCK     #
      ITEM DESLISTHD I;            # SAVE AREA FOR *DESLIST*           #
      XREF ITEM CURFUNC B;         # TRUE IF CURRENT ITEM IS A FUNCTION#
      XREF ITEM CURREG  B;         # TRUE IF CURRENT WORD IS A REGISTER#
      XREF ITEM CURRENTLFPTR I;    # POINTER TO LFNINFO ENTRY FOR LFN  #
      XREF ITEM DESLIST I;         # DESCRIBE LIST PTR FOR CURRENT LF  #
      BASED ARRAY DESTEMP S(3);    # FOR TEMP REF TO ATTRIB TABLE      #
        BEGIN 
        ITEM TEXPICSIZ  U(2,04,11);  # PIC SIZE EXCLUDING INSERTS      #
        ITEM TSIGN      B(2,15,01);  # TRUE IF SIGN OVERPUNCHED        #
        ITEM TDPTPRES   B(2,20,01);  # TRUE IF DECIMAL PT PRESENT      #
        ITEM TDPTLOC    I(2,21,06);  # LOC OF DECIMAL PT               #
        END 
                                   # FLAGS TO TURN DIRECTORY ON/OFF    #
      XREF ARRAY DIRECTFLAG;       # FOR DISPLAY AND EXTRACT COMMANDS  #
        BEGIN 
        ITEM DIROVRIDE U(00,00,02);  # OVERRIDE OF -DISPDIR-/-EXTRDIR- #
        ITEM DISPDIR   B(00,02,01);  # CONTROLS DISPLAY DIRECTORY      #
        ITEM EXTRDIR   B(00,03,01);  # CONTROLS EXTRACT DIRECTORY      #
        ITEM DIRONOFF  B(00,04,01);  # TRUE IF DIRECTORY REQUESTED     #
        END 
                                   # VALUES FOR -DIROVRIDE-            #
      DEF UNSET    # 0 #;          # -DIROVRIDE- NOT USED              #
      DEF TURNON   # 1 #;          # DIRECTORY TURNED ON FOR THIS CMD  #
      DEF TURNOFF  # 2 #;          # DIRECTORY TURNED OFF FOR THIS CMD #
  
      XREF ITEM DUMMY        I;    # DUMMY ITEM                        #
       XREF ITEM FIELDNAMELG; 
       XREF ARRAY FIELDN [0:0] S(4);           #QUALIFIED NAME TABLE   #
           ITEM FN C(0,0,10), 
                FN1 C(1,0,10),
                FN2 C(2,0,10),
                FN3 C(3,0,10),
                FNINDFG  I(3,18,06),
                FNLG     I(3,24,18),
                FNINDICE I(3,42,18);
      ITEM FNAMELG  I;             # INDEX INTO -INDTBL-               #
      ITEM I            I;         # SCRATCH TEMPORARY                 #
      ITEM J            I;         # SCRATCH TEMPORARY                 #
           BASED ARRAY NAME; ITEM DDATNAME C(0,0,10); 
      XREF ITEM NEWNAME B;         # TRUE--THERE IS A RENAME IN EXTRACT#
      XREF ITEM OLDNAMELG;         # HOLDS OLD FIELDNAMELG.            #
      ITEM RC      I;              # RETURN CODE FROM -SEARCH- : 1 IF  #
                                   # DATANAME FOUND, 0 IF NOT          #
          BASED ARRAY REPORTTEMP S(EESIZE); 
           ITEM TENTRYTYPE U(0,0,3),
                TFROMCHAR U(0,4,4), 
                TTOCHAR  U(0,8,4),
                TCHARLENGTH U(0,12,12),  # LENGTH OF FIELD IN CHARS    #
                TFROMADDRESS I(0,24,18),
                TTOADDRESS I(0,42,18),
                TCPSTACK I(1,6,18),  # IF INDEXED, CONTAINS ADDRESS OF #
                                     # INDEX TABLE                     #
                TADDRFROM I(1,24,18), 
                TADDRTO I(1,42,18), 
           TREPORTWORD1 I(1,0,60),
                TPRKEY B(2,0,1),   # TRUE IF PRIMARY KEY               #
                TKEYEXCL B(2,1,1), # TRUE IF PART/ALL OF EXCLUDED KEY  #
                TRECDORDINAL U(2,27,12),  # REC ORD IF CDCS AREA ITEM  #
                                          # 1 IF CRM AREA ITEM, ELSE 0 #
                TITEMORDINAL U(2,39,15),  # ITEM ORD IF CDCS, ELSE 0   #
                TREPORTWORD0 I(0,00,60),
                                          #    OVERFLOW  WORD          #
                TSAVFSIZE    I(0,24,18),  # RECORD LENGTH              #
                TOVERFLOW    I(0,42,18);  # POINTER TO NEXT BLOCK OF   #
                                          # -REPORTTEMP-               #
      XREF ITEM SAVELFNAME C(10);  # LFN OF LATEST FILE MENTIONED      #
      ITEM TOCHAR  I;              # CHAR IN WORD OF DESCRIBE ENTRY    #
      XREF ITEM SM$GROUPID   I;    # GROUP ID OF CURRENT SYNTAX STUFF  #
      BASED ARRAY TEMP;            # SCRATCH BASED ARRAY               #
        BEGIN 
        ITEM TEMPI I(0,0,60);      # ENTIRE WORD                       #
        END 
           BASED ARRAY WSA; 
           BEGIN
           ITEM WSAW I(0,0,60); 
           ITEM WSAC C(0,0,10); 
           END
      XREF ITEM UPONLFN   C(07);   # LFN OF UPON FILE                  #
      XREF PROC CHECKFORLFN;
      XREF PROC DIAG;              # ISSUE DIAGNOSTIC MESSAGE TO USER  #
      XREF PROC LINKNEWLFN;        # LINK NEW ENTRY INTO LFNLIST       #
      XREF PROC MOVE;              # MOVE WHOLE WORDS                  #
      XREF PROC RECNO;
      XREF PROC RECYES; 
      XREF FUNC SAVATTR I;         # CREATE ATTRIBUTE ENTRY            #
      XREF PROC SEARCH;            # SEARCHES GIVEN LIST FOR NAME IN   #
                                   # BASED ARRAY -ANAME2-              #
  
  
*CALL DEFMURL 
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC BUDEXTR;
      PROC BUDEXTR; 
      BEGIN 
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
      P<BASICTABLE> = BASCPTR;     # LCURRENT BLOCK OF BASIC TABLE     #
      IF FALL                      # IF SUBSCRIPTED BY -ALL-           #
        AND NOT INDICED            # BUT NOT AN ARRAY                  #
      THEN
        BEGIN 
        DIAG (042);                # ERROR IN SUBSCRIPT DIMENSIONING   #
        STDNO;                     # ERROR EXIT                        #
        END 
  
      IF (EXTRDIR                  # IF EXTRACT DIRECTORY REQUESTED    #
        AND DIROVRIDE NQ TURNOFF)  # AND NOT TURNED OFF BY OVERRIDE... #
        OR DIROVRIDE EQ TURNON     # OR IF TURNED ON BY OVERRIDE       #
      THEN
        BEGIN 
        SETDES;                    # ALLOC AND SET A DESCRIBE ENTRY    #
        END 
  
      TFROMCHAR[0] = DATACHARPOS;  # STARTING CHAR POSN OF FROM FIELD  #
      TTOCHAR[0] = TOCHAR;         # START CHAR OF DESTINATION         #
      TCHARLENGTH[0] = DECLSLG[0]; # LENGTH OF ONE ITEM                #
      TTOADDRESS[0] = DEWPOS[0];   # START WORD POSN OF DESTINATION    #
      TADDRTO[0] = LOC(TORECORDLOC);  # ACTUAL WORD ADDR OF DESTINATION#
      TPRKEY[0] = AKEYITEM;        # TRUE IF PRIMARY KEY               #
      TKEYEXCL[0] = EXCLKEYITEM;   # TRUE IF EXCLUDED KEY              #
      TRECDORDINAL[0] = DATARECDORD;  # CDCS RECORD ORDINAL            #
      TITEMORDINAL[0] = DATAITEMORD;  # CDCS ITEM ORDINAL              #
  
      IF PROGSTACKLEN LS 0         # IF A SINGLE ITEM                  #
      THEN
        BEGIN 
        TENTRYTYPE[0] = 1;         # SIGNAL STRAIGHT MOVE              #
        TFROMADDRESS[0] = DATAWORDADDR;  # WORD ADDR OF FROM FIELD     #
        IF NOT ABSADDRESS          # IF DATAWORDADDR IS RELATIVE       #
        THEN
          BEGIN 
          TADDRFROM[0] = DATANAMEBASE;  # SAVE ITS BASE OF REFERENCE   #
          END 
  
        IF INDICED                 # IF SUBSCRIPTED                    #
        THEN
          BEGIN 
          TENTRYTYPE[0] = 4;       # SIGNAL TO CALL -FIGSUB-           #
          TFROMADDRESS[0] = SAVATTR;  # ATTRIB TABLE OF FROM FIELD     #
          TCPSTACK[0] = INDCTBLOC;    # ADDRESS OF INDEX TABLE         #
          END 
        END                        # END SINGLE ITEM                   #
  
      ELSE                         # IF OTHER THAN SINGLE ITEM         #
        BEGIN 
        IF PROGSTACKLEN GR 0       # IF EXPRESSION                     #
        THEN
          BEGIN 
          TENTRYTYPE[0] = 3;       # SIGNAL TO CALL -EXPEVAL-          #
          TFROMADDRESS[0] = RESULTSLOC;  # ADDR OF -EXPEVAL- RESULT    #
          TCPSTACK[0] = PROGSTACKLOC;    # ADDR OF PROGRAM STACK       #
          END 
  
        ELSE                       # PROGSTACKLEN MUST BE 0            #
          BEGIN 
          DIAG (200);              # INVALID DATA TYPE                 #
          STDNO;                   # ERROR EXIT                        #
          END 
        END                        # END NOT SINGLE ITEM               #
                                   # TOTAL LENGTH OF EXTRACTED RECORD  #
      FSIZE = TTOADDRESS[0] * 10 + TTOCHAR[0] + TCHARLENGTH[0]; 
      IF FALL                      # IF SUBSCRIPT -ALL-                #
      THEN
        BEGIN                      # ADD LENGTH OF REMAINING ITEMS     #
        FSIZE = FSIZE + TCHARLENGTH[0] * (UPBND[FNAMELG] - 1);
        END 
  
      IF AREAITM                   # IF AREA ITEM REFERENCED           #
      THEN
        BEGIN 
        FILEPASS = TRUE;           # PASS THE DATABASE FILE            #
        IF REFERFILE NQ O"77"      # IF NOT ALREADY UPDATING DATABASE  #
        THEN
          BEGIN 
          REFERFILE = 1;           # FLAG TO READ THE DATABASE         #
          END 
        END                        # END AREA ITEM                     #
  
      P<REPORTTEMP> = P<REPORTTEMP> + EESIZE;  # INCR TO NEXT ENTRY    #
      CMLEFT = CMLEFT - EESIZE;    # DECR WDS LEFT IN REPORTTEMP BLOCK #
      IF CMLEFT EQ 1               # IF ONLY OVERFLOW PTR LEFT         #
      THEN
        BEGIN 
        GET15CM;                   # ALLOC NEXT BLOCK AND POINT TO IT  #
        END 
  
      STDYES;                      # SUCCESSFUL EXIT                   #
      END                          # END PROC *BUDEXTR*                #
      CONTROL EJECT;
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC BUDFIT; 
      PROC BUDFIT;
      BEGIN 
      IF NOT RECORDFLAG            # IF NOT RECORDING                  #
      THEN
        BEGIN 
        UPONLFN = SAVELFNAME;      # SAVE -UPON- LFN FOR FUTURE USE    #
        P<BASICTABLE> = BASCPTR;
        BASCUPON[BASTABIND] = TRUE;  # FLAG -UPON- LFN IN USE          #
        END 
  
      ATTR = 0;                    # LOC OF DESCRIBE ENTRY             #
      CMLEFT = 31;                 # COUNTER FOR EXTRACT TABLE         #
      DESLIST = 0;                 # PTR TO DESCRIBE DIRECTORY FOR LFN #
      FSIZE = 0;                   # LENGTH OF DIS/EXTR OUTPUT         #
      I = 0;                       # START OF NEXT WORD IN OUTPUT      #
      TYPETWD[0] = 0; 
      DIROVRIDE = UNSET;           # CLEAR OUT DIRECTORY OVERRIDE FLAG #
  
      STDNO;
      END                          # PROC *BUDFIT*                     #
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC CHKAS;
      PROC CHKAS; 
      BEGIN 
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
      P<BASICTABLE> = BASCPTR;
      IF BASCUPON[BASTABIND]       # IF -UPON- FILE BEING CREATED      #
      THEN
        BEGIN 
        STDYES;                    # OK - NORMAL EXIT                  #
        END 
  
      ELSE                         # -AS- NOT ALLOWED W/OUT -UPON-     #
        BEGIN 
        STDNO;                     # ERROR EXIT                        #
        END 
      END                          # PROC *CHKAS*                      #
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC CHKFIGS;
      PROC CHKFIGS; 
      BEGIN 
      RECYES;                      # STDYES IF RECORDING               #
      IF FNEXT                     # IF SUBSCRIPT IS NEXT OR ANY       #
        OR FANY 
      THEN
        BEGIN 
        STDNO;                     # ERROR EXIT                        #
        END 
  
      ELSE
        BEGIN 
        NEWNAME = FALSE;           # NO RENAME YET                     #
        STDYES;                    # SUCCESSFUL EXIT                   #
        END 
      END                          # PROC *CHKFIGS*                    #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     D I R O V O F F                                                  #
#                                                                      #
#     -DIROVOFF- IS CALLED FROM THE SYNTAX FOR THE -WITH DIRECTORY-    #
#     CLAUSE OF THE -DISPLAY-/-EXTRACT- COMMANDS.  IT SETS THE         #
#     TEMPORARY -DIRECTORY- OVERRIDE FLAG TO OFF.                      #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC DIROVOFF; 
      PROC DIROVOFF;
      BEGIN 
      RECYES;                      # RETURN TO -YES- IF RECORDING      #
  
      DIROVRIDE = TURNOFF;         # TURN DIRECTORY OVERRIDE FLAG OFF  #
  
      STDYES; 
      END                          # PROC -DIROVOFF-                   #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     D I R O V O N                                                    #
#                                                                      #
#     -DIROVON- IS CALLED FROM THE SYNTAX FOR THE -WITH DIRECTORY-     #
#     CLAUSE OF THE -DISPLAY-/-EXTRACT- COMMANDS.  IT SETS THE         #
#     TEMPORARY -DIRECTORY- OVERRIDE FLAG TO ON.                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC DIROVON;
      PROC DIROVON; 
      BEGIN 
      RECYES;                      # RETURN TO -YES- IF RECORDING      #
  
      DIROVRIDE = TURNON;          # TURN DIRECTORY OVERRIDE FLAG ON   #
  
      STDYES; 
      END                          # PROC -DIROVON-                    #
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC GET15;
       PROC GET15;    BEGIN 
              RECNO;               # RETURN TO STDNO IF RECORDING      #
           GET15CM; 
           STDNO; 
           END
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
       PROC GET15CM;    BEGIN 
      ITEM KK  I;                  # TEMP LOC OF -REPORTTEMP-          #
        KK = CMM$ALF(31, 0, SM$GROUPID);
      IF CMLEFT NQ 31              # IF NOT 1ST BLOCK TO BE ALLOCATED  #
      THEN
        BEGIN 
        TOVERFLOW[0] = KK;         # SET OVERFLOW PTR IN PREVIOUS BLOCK#
        END 
            P<REPORTTEMP>=KK; 
      P<BASICTABLE> = BASCPTR;     # LCURRENT BLOCK OF BASIC TABLE     #
           IF NOT RECORDFLAG THEN 
      IF CMLEFT EQ 31 THEN BASCADDR[BASTABIND] = KK;
      CMLEFT = 31;
           RETURN;
           END
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC NEWLFNLINK; 
      PROC NEWLFNLINK;
      BEGIN 
      ITEM EC;
      RECNO;                       # *STDNO* IF RECORDING              #
                                   # POSN TO FIRST BLOCK OF EXTR TABLE #
      P<REPORTTEMP> = BASCADDR[BASTABIND];
      TSAVFSIZE[10] = FSIZE;       # SAVE FINAL SIZE OF EXTRACTED      #
                                   # RECORD IN OVERFLOW WORD           #
      SAVELFNAME = UPONLFN;        # RESTORE VALUE OF -UPON- LFN IN    #
                                   # CASE CHANGED BY -FROM- OR -KEY IN-#
      CHECKFORLFN;       # CHECK IF LFN ALREADY EXISTS.          #
      EC = 0;            # ENTRY CODE OF 0--NOT A CALL FROM SORT.#
      LINKNEWLFN (EC);   # LINK NEW LFN INTO LFN LIST.           #
      P<LFNINFO> = CURRENTLFPTR;
      P<BASICTABLE> = BASCPTR;
      BASFITUPON[BASTABIND] = LOC(L$FITLOC);                             BUDEXTR
      SM$GROUPID = 0;              # DONE ALLOCATING WITH THIS GROUP ID#
      STDNO;
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC RLSALL; 
       PROC RLSALL;   BEGIN 
           RECNO;                  # *NO* IF RECORDING                 #
           P<BASICTABLE> = BASCPTR;  # CURRENT BLOCK OF BASIC TABLE    #
           IF DESLIST NQ 0         # IF ATTRIB TABLE EXISTS            #
             AND BASCUPON[BASTABIND]   # IF FILE BEING CREATED         #
           THEN 
             BEGIN
             P<DESATT1> = DESLIST; # POSITION TO ATTRIB TABLE          #
             DESLIST = 0;          # CLEAR LIST POINTER                #
             FOR DUMMY=DUMMY       #EXIT VIA STDNO                     # BUDEXTR
               WHILE TRUE                                                BUDEXTR
             DO                                                          BUDEXTR
               BEGIN
               CMM$FRF(P<DESATT1>);  # FREE ATTRIBUTE TABLE            #
               P<DESATT1> = DABSPTR[0];  # POSITION TO NEXT ATTRIBUTE  #
               IF P<DESATT1> EQ 0  # IF NO MORE ATTRIBUTE TABLES       #
               THEN 
                 BEGIN
                 STDNO; 
                 END
               END
             END
           STDNO; 
           END
  
  
  
  
#----------------------------------------------------------------------#
#     R S D E S L I S T                                                #
#                                                                      #
# THIS RESTORES THE POINTER TO THE LIST OF *DESCRIBE* AND *EXTRACT*    #
# TABLE ENTRIES.                                                       #
  
      XDEF PROC RSDESLIST;
      PROC RSDESLIST; 
      BEGIN 
      P<BASICTABLE> = BASCPTR;
      IF BASCUPON[BASTABIND]       # IF CREATING DIRECTORY FOR UPON LFN#
      THEN
        BEGIN 
        DESLIST = DESLISTHD;       # RESTORE PTR TO ITS DESCRIBE LIST  #
        END 
      STDNO;
      END 
  
  
  
  
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S A V M U R L                                                    #
#                                                                      #
#     *SAVMURL* ALLOCATES A NEW ATTRIBUTE ENTRY FOR THE DESCRIBE LIST  #
#     AND MOVES THE MURAL, IF IT EXISTS, FROM ITS TEMPORARY LOCATION   #
#     TO A NEW BLOCK RELATIVE TO THE ATTRIBUTE ENTRY.                  #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC SAVMURL; 
      BEGIN 
      ATTR = CMM$ALF (7, 0, 0);    # ALLOC ATTRIB LIST ENTRY           #
      IF PTRMURAL[0] NQ 0          # IF MURAL EXISTS                   #
      THEN
        BEGIN 
        P<WSA> = PTRMURAL[0];      # FWA OF TEMP BLOCK WITH MURAL      #
        J = B<55,5>WSAW[0];        # LENGTH OF MURAL                   #
        P<TEMP> = CMM$ALF (J, 0, 0);  # ALLOC NEW SPACE FOR MURAL      #
        MOVE (WSA, J, TEMP);       # MOVE MURAL INTO NEW BLOCK         #
        PTRMURAL[0] = P<TEMP>;     # SET PTR TO NEW MURAL              #
        END 
      END                          # PROC *SAVMURL*                    #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S E T D E S                                                      #
#                                                                      #
#     *SETDES* MAKES SURE AN ATTRIBUTE ENTRY (DESATT1) IS ALLOCATED,   #
#     AND SETS ALL FIELDS IN IT NEEDED BY BOTH *DISPLAY* AND *EXTRACT*.#
#     THIS ENTRY IS LINKED INTO THE DESCRIBE LIST POINTED TO BY        #
#     *DESLIST*.                                                       #
#                                                                      #
#     ON EXIT:                                                         #
#                                                                      #
#     ATTR = POINTER TO NEW -DESATT1- ENTRY                            #
#     I = CHARACTER POSITION OF DESCRIBE ENTRY                         #
#     TOCHAR = CHAR IN WORD OF DESCRIBE ENTRY                          #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC SETDES; 
      PROC SETDES;
      BEGIN 
      IF NOT NEWNAME               # IF NOT RENAMED BY -AS- CLAUSE     #
        AND (FIGLITDATA EQ S"LITERAL"  # AND ITEM IS A LITERAL         #
        OR PROGSTACKLEN GR 0       # OR EXPRESSION                     #
        OR CURFUNC                 # OR FUNCTION                       #
        OR CURREG)                 # OR REGISTER                       #
      THEN
        BEGIN 
        FN[0] = "FILLER";          # GIVE IT DEFAULT NAME OF -FILLER-  #
        FN1[0] = " "; 
        FN2[0] = " "; 
        FNINDFG[0] = 0;            # SET FLAGS FOR NO INDEX            #
        FNINDICE[0] = 0;
        FNLG[0] = 6;               # LENGTH OF NAME -FILLER-           #
        FIELDNAMELG = 1;
        END 
  
      P<ANAME2> = LOC(FN[0]);      # PASS DATANAME TO -SEARCH-         #
                                   # SEARCH NEW DESLIST FOR DUPLICATE  #
      SEARCH (DESLIST, RC, ATTRPTR);
      IF RC NQ 0
      THEN
        BEGIN 
        DIAG (045);                # DATANAME ALREADY IN USE           #
        STDNO;
        END 
  
      SAVMURL;                     # ALLOC ATTRIB ENTRY AND SAVE MURAL #
  
      IF NEWNAME                   # IF ITEM RENAMED BY -AS- CLAUSE    #
      THEN
        BEGIN 
        FNAMELG = OLDNAMELG - 1;   # USE ORIGINAL INDTBL INDEX         #
        END 
  
      ELSE                         # IF NOT RENAMED                    #
        BEGIN 
        FNAMELG = FIELDNAMELG - 1; # IDX IS CURRENT LEVEL OF QUALS     #
        END 
      P<INDTBL> = INDCTBLOC;       # POSN TO INDEX TABLE               #
  
      IF DESLIST EQ 0              # IF NO DESCRIBE LIST YET           #
      THEN
        BEGIN 
        DESLIST = ATTR;            # THIS ENTRY IS HEAD OF LIST        #
        END 
      ELSE                         # IF DESCRIBE LIST ALREADY EXISTS   #
        BEGIN 
        DABSPTR[0] = ATTR;         # PUT THIS ENTRY ON THE END OF IT   #
        END 
      P<DESATT1> = ATTR;           # POSN -DESATT1- TO THIS ENTRY      #
  
      DECNLG[0] = FNLG[0];         # NAME LENGTH IN CHARS              #
      DEWNLG[0] = (DECNLG[0] + 9) / 10;  # WORD LENGTH OF NAME         #
      DECLASS[0] = DATATYPE;       # TYPE OF DATA                      #
                                   # IF INT, FIX, FLOAT, DOUBLE,       #
      IF DATATYPE GQ DT$INTEGER    # COMPLEX, OR LOGICAL               #
        AND DATATYPE LQ DT$LOGICAL
        AND BASCODE[BASTABIND] EQ EXTRCODE  # IF EXTRACT, NOT DISPLAY  #
      THEN
        BEGIN 
        I = (I+9) / 10 * 10;       # START OF NEXT ENTRY IS ON WD BND  #
        END 
      J = I / 10;                  # WORD COUNT TO NEXT WORD           #
      DEWPOS[0] = J;               # WORD POSN OF DESCRIBE ENTRY       #
      TOCHAR = I - J * 10;         # CHAR POSITION                     #
      DBITPOS[0] = TOCHAR * 6;     # BIT POSITION                      #
  
      P<DESTEMP> = DATANAMEPTR;    # LOC OF ITEM-S OLD ATTRIB ENTRY    #
  
      IF BASCODE[BASTABIND] EQ DISPCODE  # IF -DISPLAY- DIRECTIVE      #
      THEN
        BEGIN 
        IF FIGLITDATA EQ S"LITERAL"   # IF ITEM IS A LITERAL           #
          AND DATATYPE GQ DT$INTEGER  # OF NON-CHARACTER TYPE          #
        THEN
          BEGIN 
          DECLSLG[0] = PICSIZ[DATATYPE];  # INT SIZE IS DEFAULT PIC SIZ#
          END 
        ELSE                       # NON-LITERAL OR CHAR LIT           #
          BEGIN 
          DECLSLG[0] = RESULTSIZE; # INTERNAL SIZE ON FILE             #
          END 
        END                        # END IF -DISPLAY-                  #
  
      ELSE                         # IF -EXTRACT- DIRECTIVE            #
        BEGIN 
        DECLSLG[0] = DATALENG;     # SIZE ON FILE SAME AS IN CORE      #
        IF FIGLITDATA NQ S"LITERAL"  # IF NON-LIT EXTRACTED ITEM       #
        THEN
          BEGIN 
          DOVERPUN[0] = TSIGN[0];  # TRUE IF SIGN OVERPUNCHED          #
          END 
        END                        # END IF -EXTRACT-                  #
  
      P<NAME> = P<DESATT1> + 3;    # LOC OF DATANAME                   #
      IF FALL                      # IF ITEM SUBSCRIPTED BY -ALL-      #
      THEN
        BEGIN 
        IF UPBND[FNAMELG] EQ 0     # IF NOT MATRIX                     #
        THEN
          BEGIN 
          DIAG (040);              # INVALID SUBSCRIPT                 #
          STDNO;                   # ERROR EXIT                        #
          END 
  
        DFORMAT[0] = ET$VECTOR;    # ENTRY TYPE VECTOR                 #
        WITHOCC[0] = TRUE;         # -OCCUR- WORD IS PRESENT           #
        DIMOCC[0] = TRUE; 
        DMAXOCR[0] = UPBND[FNAMELG];  # NUM OF ARRAY ENTRIES           #
        P<NAME> = P<NAME> + 1;     # DATANAME STARTS AFTER -OCCUR- WD  #
                                   # ADD MATRIX LENGTH TO NEXT WORD LOC#
        I = I + DECLSLG[0] * DMAXOCR[0];
        END 
  
      ELSE                         # IF SINGLE ITEM                    #
        BEGIN 
        DFORMAT[0] = ET$ITEM;      # ENTRY TYPE ITEM                   #
        I = I + DECLSLG[0];        # ADD INTERNAL SIZE TO NEXT WORD LOC#
        END 
  
      IF FIGLITDATA EQ S"LITERAL"  # IF ITEM IS A LITERAL              #
      THEN
        BEGIN 
        IF DATATYPE EQ DT$CHAR     # IF TYPE CHARACTER                 #
          OR DATATYPE EQ DT$NUM    # OR TYPE DISPLAY NUMERIC           #
        THEN
          BEGIN 
          DISPLAYSIZE[0] = RESULTSIZE;  # PIC SIZE LESS INSERTS        #
          DPICSIZ[0] = RESULTSIZE; # PIC SIZE INCL INSERTS             #
          END 
        ELSE                       # NUMERIC TYPE                      #
          BEGIN 
          DISPLAYSIZE[0] = DISPSIZ[DATATYPE];  # USE DEFAULT VALUES    #
          DPICSIZ[0] = PICSIZ[DATATYPE];
          END 
  
        IF DATATYPE GQ DT$FLOAT    # IF FLOAT, DOUBLE, OR COMPLEX      #
          AND DATATYPE LQ DT$COMPLEX
        THEN
          BEGIN 
          DPOINT[0] = TRUE;        # DEC POINT WILL BE PRESENT         #
          DPTLOC[0] = DECPT[DATATYPE];  # DEFAULT LOC OF DEC PT        #
          END 
        END                        # END ITEM A LITERAL                #
  
      ELSE                         # IF AREA OR TEMP ITEM              #
        BEGIN 
        DISPLAYSIZE[0] = TEXPICSIZ[0];  # PIC SIZE LESS INSERTS        #
        DPICSIZ[0] = RESULTSIZE;   # PIC SIZE INCL INSERTS             #
        DPOINT[0] = TDPTPRES[0];   # TRUE IF DEC PT PRESENT            #
        DPTLOC[0] = TDPTLOC[0];    # LOC OF DEC PT                     #
        IF PTRMURAL[0] NQ 0        # IF MURAL PRESENT                  #
        THEN
          BEGIN 
          MURALPTR[0] = PTRMURAL[0] - ATTR;  # PTR TO IT REL TO DESATT #
          END 
        END                        # END AREA OR TEMP ITEM             #
  
      J = DEWNLG[0];               # WORD LENGTH OF NAME               #
      IF J GQ 1                    # GET NEWNAME ONE WORD AT A TIME    #
      THEN
        BEGIN 
        DDATNAME[0] = FN[0];
        END 
      IF J GQ 2 
      THEN
        BEGIN 
        DDATNAME[1] = FN1[0]; 
        END 
      IF J GQ 3 
      THEN
        BEGIN 
        DDATNAME[2] = FN2[0]; 
        END 
      IF J GQ 4                    # ONLY 2 CHARS ALLOWED IN 4TH WORD  #
      THEN
        BEGIN 
        C<0,2>DDATNAME[3] = C<0,2>FN3[0];  # COPY THE 2 CHARS        #
        C<2,8>DDATNAME[3] = "        ";    # BLANK FILL              #
        END 
  
      RETURN; 
      END                          # PROC *SETDES*                     #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#     S V D E S L I S T                                                #
#                                                                      #
# THIS SAVES THE POINTER TO THE *DESCRIBE* (*EXTRACT*) TABLE AND THEN  #
# SETS IT TO ZERO, SO AS TO PREVENT ANY HITS FROM THIS TABLE WHILE IN  #
# *SEARCHFORDUP*.                                                      #
  
      XDEF PROC SVDESLIST;
      PROC SVDESLIST; 
      BEGIN 
      P<BASICTABLE> = BASCPTR;
      IF BASCUPON[BASTABIND]       # IF CREATING DIRECTORY FOR UPON LFN#
      THEN
        BEGIN 
        DESLISTHD = DESLIST;       # SAVE PTR TO DESCRIBE LIST         #
        DESLIST = 0;               # AND THEN ZERO IT                  #
        END 
      STDNO;
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
      END 
      TERM
