*DECK SORT
USETEXT TCMMDEF 
USETEXT TDESATT 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TFIT
USETEXT TLFNINF 
USETEXT TXSTD 
      PROC SORT;
  
#----------------------------------------------------------------------#
#                                                                      #
#  THE FOLLOWING PROCS ARE XDEF"D WITHIN THIS DECK:                    #
#                                                                      #
#     COLSEQ                       STORE NAME OF COLLATING SEQUENCE    #
#     ENDSORT                      CLEANUP FOR SORT SYNTAX             #
#     LITSEQ                       STORE A COLL. SEQ. LITERAL STRING   #
#     LODSORT                      LOAD THE (3,0) OVERLAY FOR SORTING  #
#     SETUNIQUE                    SET THE FLAG FOR *UNIQUE* PROCESSING#
#     SORTIN                       INITIALIZATION FOR SORT SYNTAX      #
#     SORTKEY                      STORE THE KEY SPECIFICATION         #
#     SORTLFN                      FLAG EXISTENCE OF OUTPUT LFN SPEC.  #
#     SORTORD                      STORE DESCENDING ORDER              #
#     SORTOUT                      STORE THE OUTPUT LFN                #
#     SORTSEQ                      FLAG EXISTENCE OF SEQ. SPEC.        #
#     STARTKEY                     FLAG BEGINNING OF SORT KEYS         #
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN 
  
      XREF ARRAY SEQTBL[0:26] ; 
      ITEM TBL C(0,0,10) ;
      XREF ITEM SORTUNIQUE B;      # TRUE MEANS OUTPUT UNIQUE RECORDS  #
      XREF PROC LFNLOOKUP;
      COMMON SORTBL;
     BEGIN
      ITEM SORTLOC; 
     END
      BASED ARRAY BKEY [0:0]; 
     BEGIN
      ITEM SORTCOM; 
     END
      BASED ARRAY XX;;
      DEF INPUT #0#;
      DEF OUTPUT #INPUT+1#; 
      DEF KEY #OUTPUT+1#; 
      DEF SEQ #KEY+201#;
      DEF SEQCNT #SEQ+8#; 
          XREF ITEM SEQNO;
          ITEM SNO; 
      ITEM EC;     # ENTRY CODE # 
      ITEM RC;       # RETURN CODE #
      ITEM ENDKEY C(10)=" END KEY"; 
      ARRAY CODES [7] ; 
      ITEM CODE(0,0,60)=[5,5,1,2,2,2,2,0] ; 
      ITEM CNT = 0; 
      ITEM HAVEKEYS    B;          # TRUE IF KEY SPECIFIED WITH *ON*   #
      ITEM HAVEOUTLFN  B;          # TRUE IF *UPON LFN*                #
      ITEM HAVESEQ     B;          # TRUE IF *USING SEQUENCE*          #
      XREF PROC CHECKFORLFN;
      XREF PROC LINKNEWLFN; 
      XREF ITEM SAVELFNAME; 
      XREF BASED ARRAY DESPTR;
        ITEM DESCOUNT I (0,0,12),  # NUNBER OF LOCAL FILES REFERENCING #
                                   # THIS LIST OF DESCRIBE ITEMS.      #
             DESSIZE  U (0,24,18), # SIZE OF DESCRIBED LIST IN CHARS   #
             DESADDR  U (0,42,18); # ADDRESS OF LIST OF ITEMS.         #
      XREF ITEM CURRENTLFPTR; 
      XREF ITEM DESLIST;
      XREF ITEM FRMLFN  C(7);      # NAME OF FILE BEING SORTED         #
      XREF ITEM FROMKEYINFIT I;    # FIT ADDR OF FILE BEING SORTED     #
  
      XREF BASED ARRAY HOLDER;     # A FIT *HELD* FOR *SORT*/*COMPILE* #
        BEGIN 
        ITEM HOLDBT       U(11,36,03);  # BLOCK TYPE                   #
        ITEM HOLDCL       U(16,24,06);  # COUNT FIELD LENGTH (RT=D/T)  #
        ITEM HOLDCP       U(17,15,24);  # BCP OF COUNT FIELD (RT=T)    #
        ITEM HOLDC1       B(17,13,01);  # COMP-1 BIT (RT=D/T)          #
        ITEM HOLDHL       U(15,00,24);  # HEADER LENGTH (RT=T)         #
        ITEM HOLDLT       U(10,36,02);  # LABEL TYPE                   #
        ITEM HOLDMRL      U(12,00,24);  # MAXIMUM RECORD LENGTH        #
        ITEM HOLDRT       U(11,32,04);  # RECORD TYPE                  #
        ITEM HOLDSB       B(17,14,01);  # SIGN OVERPUNCH (RT=D/T)      #
        ITEM HOLDTL       U(16,00,24);  # TRAILER LENGTH (RT=T)        #
        END 
  
      ITEM I            I;         # SCRATCH TEMPORARY                 #
      ITEM II           I;         # SCRATCH TEMPORARY                 #
      ITEM III          I;         # SCRATCH TEMPORARY                 #
      ITEM L            I;         # SCRATCH TEMPORARY                 #
      ITEM J            I;         # SCRATCH TEMPORARY                 #
      ITEM K            I;         # SCRATCH TEMPORARY                 #
  
      XREF PROC CMOVE;             # CHARACTER MOVE ROUTINE            #
      XREF PROC EXIT10;            # LOAD OVERLAY TO EXIT (1,0)        #
      XREF FUNC KOMSTR I;          # FUNCTION TO COMPARE STRINGS       #
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC COLSEQ; 
      PROC COLSEQ;
      BEGIN 
      HAVESEQ = TRUE;              # USER SPECIFIED A COLL. SEQ. NAME  #
      IF ICW[0] EQ "COBOL" THEN STDYES ;
          FOR I=0 STEP 9 UNTIL SNO DO 
      BEGIN 
      IF ICW[0] EQ TBL [I] THEN GOTO MOVEM ;
      END 
      HAVESEQ = FALSE;             # COLL SEQ NAME UNKNOWN TO US       #
      STDNO ;                      # RETURN                      #
      MOVEM:  
      IF RECORDFLAG THEN           # IF RECORDING THIS SORT            #
        BEGIN 
        STDYES;                    # GOOD RETURN... NO WORK DONE THO   #
        END 
  
      FOR J=0 STEP 1 UNTIL 8 DO 
      BEGIN 
      SORTCOM[SEQ+J] = TBL[I];
      I=I+1 ; 
      END 
      STDYES ;
      END 
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     E N D S O R T                                                    #
#                                                                      #
# RELEASES MEMORY FOR A SORT THAT WONT BE EXECUTED                     #
  
      XDEF PROC ENDSORT;
      PROC ENDSORT; 
  
      BEGIN 
      FROMKEYINFIT = 0;            # CLEAR -FROM- FILE INFO            #
      FRMLFN = " "; 
  
      IF SORTLOC NQ 0 THEN         # IF CM ALLOCATED FOR SORT TABLES   #
        BEGIN 
        CMM$FRF (SORTLOC);         # FREE THE CM FOR SORT TABLES       #
        SORTLOC = 0;               # CLEAR POINTER TO SORT TABLES      #
        END 
  
      STDYES;                      # SUCCESSFUL RETURN                 #
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC LITSEQ; 
      PROC LITSEQ;
      BEGIN 
      HAVESEQ = TRUE;              # COLLATING SEQUENCE SPECIFIED      #
      IF RECORDFLAG THEN           # IF RECORDING THIS SORT            #
        BEGIN 
        STDYES;                    # GOOD RETURN... NO WORK DONE THO   #
        END 
  
      P<XX>=P<BKEY>+SEQ ; 
      SORTCOM[SEQ]= "DFLTNAM   " ;
  
      II=CURLENG-1 ;
      CMOVE(CURWORD,0,CURLENG,XX,10) ;
      FOR I=0 STEP 1 UNTIL II DO
      BEGIN 
      FOR J=0 STEP 1 UNTIL II DO
      BEGIN 
      IF I EQ J THEN TEST J ; 
      IF KOMSTR(XX,11+I,1,XX,11+J) NQ 0 
      THEN TEST J;
      CMOVE(XX,10+J+1,II-J,XX,10+J) ; 
      II=II-1 ; 
      END 
      END 
      SORTCOM[SEQCNT] = II + 1; 
      STDYES;                      # SUCCESSFUL RETURN                 #
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC LODSORT ; 
      PROC LODSORT ;
      BEGIN 
      CURRENTLFPTR = 0;            # ZERO OUT LFN POINTER SO THAT      #
                                   # FUTURE OPERATIONS WILL BE OK.     #
      FROMKEYINFIT = 0; 
      FRMLFN = " "; 
  
      IF RECORDFLAG THEN           # IF RECORDING THIS DIRECTIVE       #
        BEGIN 
        STDNO;                     # RETURN TO SYNTAX TABLES           #
        END 
  
      PRIMARY=3 ; 
      OLDKEY = KEYAREA[0];                                               FEAT157
      EXIT10; 
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC SETUNIQUE;
      PROC SETUNIQUE;              # SETS UNIQUE PROCESSING FOR SORT   #
      BEGIN 
      IF SORTUNIQUE THEN           # IF USER ALREADY SAID -UNIQUE-     #
        BEGIN 
        STDNO;                     # NON FTL RETURN - REDUNDANT UNIQUE #
        END 
  
      ELSE
        BEGIN 
        SORTUNIQUE = TRUE;         # ELIMINATE DUPLICATE RECORDS       #
        STDYES;                    # GOOD RETURN                       #
        END 
  
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
      XDEF PROC SORTDES;           # GO TO STDYES IF KEY IS DESCRIBED  # QU3A334
      PROC SORTDES;                                                      QU3A334
      BEGIN                                                              QU3A334
      IF DESITM                    # IF KEY IS DESCRIBED ITEM          # QU3A334
        OR RECORDFLAG              # IF RECORDING                      # QU3A334
        THEN                                                             QU3A334
        BEGIN                                                            QU3A334
        STDYES;                                                          QU3A334
        END                                                              QU3A334
      STDNO;                       # ERROR EXIT                        # QU3A334
      END                                                                QU3A334
                                                                         QU3A334
                                                                         QU3A334
#----------------------------------------------------------------------# QU3A334
  
  
      XDEF PROC SORTIN; 
      PROC SORTIN;
      BEGIN 
      K=0 ; 
      L=0 ; 
      SORTUNIQUE = FALSE;          # ASSUME DONT WANT ONLY UNIQUE RCDS #
          SNO = SEQNO*9-1;
      HAVEKEYS = FALSE;            # NO KEYS SPECIFIED YET             #
      HAVEOUTLFN = FALSE;          # NO OUTPUT LFN SPECIFIED YET       #
      HAVESEQ = FALSE;             # NO COLL. SEQ. SPECIFIED YET       #
      IF RECORDFLAG THEN           # IF RECORDING THIS SORT            #
        BEGIN 
        STDYES;                    # GOOD RETURN... NO WORK DONE THO   #
        END 
  
      SORTLOC = CMM$ALF(212,0,0); 
      P<BKEY> = SORTLOC;
      RC = 0; 
      LFNLOOKUP (RC);        # FIND LFN IN LIST OF LFNS.  # 
      IF RC EQ 0 THEN 
        BEGIN 
        P<LFNINFO> = CURRENTLFPTR;
        SORTCOM[INPUT] = LOC(L$FITLOC);   #SET FIT ADDR FOR USE IN     # SORTSEM
        SORTCOM[OUTPUT] = SORTCOM[INPUT];  # DEFAULT IS OUTPUT=INPUT   #
        END                                 # QUSORT.                  #
      ELSE
        BEGIN 
        STDNO;                     # BAD RETURN                        #
        END 
  
                                   # NOW CREATE AN ENTRY IN THE TBL    #
                                   # DESCRIBING THE WHOLE RECORD AS A  #
                                   # KEY. *SORTKEY* WILL OVERWRITE THIS#
                                   # KEY ENTRY IF ANY KEYS ARE         #
                                   # SPECIFIED WITH *ON*.              #
      SORTCOM[KEY]   = 1;            # START WITH FIRST CHAR           #
      SORTCOM[KEY+1] = 1;            # START WITH FIRST BIT OF CHAR 1  #
      P<FIT> = LOC(L$FITLOC);                                            SORTSEM
  
                                   # IF THE ON OPTION IS OMITTED, THE  #
                                   # SORT KEY IS THE WHOLE RECORD      #
                                   # TREATED AS AN ALPHANUMERIC STRING #
                                   # OR THE FIRST 255 CHARACTERS OF THE#
                                   # RECORD IF THE RECORD IS LONGER    #
                                   # THAN 255 CHARACTERS.              #
                                   #                                   #
      IF FITMRL GR 255
      THEN
        BEGIN 
        SORTCOM[KEY + 2] = 255; 
        END 
      ELSE
        BEGIN 
        SORTCOM[KEY + 2] = FITMRL;   #MRL IS NUMBER OF CHARS           #
        END 
  
      SORTCOM[KEY+3] = 0;            # ZERO BITS LEFT OVER             #
      SORTCOM[KEY+4] = 5;            # 5 IS CODE FOR DISPLAY CODE KEY  #
      SORTCOM[KEY+5] = 0;            # NO SPECIFIC COLSEQ FOR THIS KEY #
      SORTCOM[KEY+6] = 0;            # 0 FOR ASCENDING ORDER           #
      SORTCOM[KEY+7] = 0;            # 0 FOR NO SIGN OVERPUNCH         #
      SORTCOM[KEY+8] = ENDKEY;       # MARKER FOR END OF SORT KEYS     #
      SORTCOM[SEQ] = "COBOL"; 
      FOR I = 1 STEP 1 UNTIL 7 DO SORTCOM[SEQ+I] = TBL[I];
      SORTCOM[SEQCNT] = TBL[8]; 
                                   # SAVE FILE INFO FOR USE BY DATANAM #
      FROMKEYINFIT = LOC(L$FITLOC); 
      FRMLFN = L$FITLFNC; 
      STDYES;                      # GOOD RETURN                       #
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC SORTKEY;
      PROC SORTKEY; 
      BEGIN 
      CNT=CNT+1;
      IF CNT GR 25 THEN            # THIS KEY WOULD EXCEED LIMIT OF 25 #
        BEGIN 
        STDNO;                     # BAD RETURN - MORE THAN 25 KEYS    #
        END 
  
      IF RECORDFLAG THEN           # IF RECORDING THIS SORT            #
        BEGIN 
        STDYES;                    # GOOD RETURN... NO WORK DONE THO   #
        END 
  
      SORTCOM[KEY+K] = DATAWORDADDR *10 +DATACHARPOS +1;
      SORTCOM[KEY+K+1] = 1; 
      SORTCOM[KEY+K+2] = DATALENG;
      SORTCOM[KEY+K+4] = CODE[DATATYPE];
          P<DESATT1> =DATANAMEPTR;
      IF DATATYPE EQ 1                                                   SORTSEM
        AND DOVERPUN               #CHECK FOR SIGN OVERPUNCH           # SORTSEM
      THEN                                                               SORTSEM
        BEGIN                                                            SORTSEM
        SORTCOM[KEY + K + 7] = 1;  #NUMERIC KEY                        # SORTSEM
        END                                                              SORTSEM
      K=K+8 ; 
      SORTCOM[KEY+K] = ENDKEY;
      STDYES ;
      END 
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     S O R T L F N                                                    #
#                                                                      #
# THIS PROC DOES INITIALIZATION PRIOR TO STORING AN OUTPUT LFN FOR SORT#
  
      XDEF PROC SORTLFN;
      PROC SORTLFN; 
  
      BEGIN 
      IF HAVEOUTLFN THEN           # IF HAVE AN OUTPUT LFN SPECIFIED   #
        BEGIN 
        STDNO;                     # BAD RETURN - ALREADY HAVE AN LFN  #
        END 
  
      ELSE
        BEGIN 
        STDYES;                    # GOOD RETURN - NO LFN YET          #
        END 
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC SORTORD;
      PROC SORTORD; 
      BEGIN 
      IF CNT GR 25 THEN            # IF HAVE NO MORE ROOM FOR KEYS     #
        BEGIN 
        STDNO;                     # NON FATAL BAD RETURN              #
        END 
  
      ELSE
        BEGIN 
        IF RECORDFLAG THEN         # IF RECORDING THIS SORT            #
          BEGIN 
          STDYES;                  # GOOD RETURN... NO WORK DONE THO   #
          END 
  
        SORTCOM[KEY+K-2] = 1;      # 1 FOR DESCENDING ORDER ON THIS KEY#
        STDYES;                    # SUCCESSFUL RETURN                 #
        END 
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
  
  
      XDEF PROC SORTOUT;
      PROC SORTOUT; 
      BEGIN 
      HAVEOUTLFN = TRUE;           # USER SPECIFIED OUTPUT LFN         #
      IF RECORDFLAG THEN           # IF RECORDING THIS SORT            #
        BEGIN 
        STDYES;                    # GOOD RETURN... NO WORK DONE THO   #
        END 
  
      LFNLOOKUP (RC);       # SEARCH FOR LFN IN LIST OF LFNS.          #
      IF RC EQ 0 THEN       # FOUND THE LFN.                           #
        BEGIN 
        P<LFNINFO> = CURRENTLFPTR;
        IF SORTCOM[INPUT] EQ LOC(L$FITLOC) THEN  #INPUT LFN IS THE     # SORTSEM
          BEGIN                                   # SAME AS OUTPUT LFN.#
          SORTCOM[OUTPUT] = SORTCOM[INPUT];       # FIT ADDR, ETC. IS  #
          STDYES;                  # SUCCESSFUL RETURN                 #
          END 
        ELSE            # LFNS ARE DIFFERENT.  CHECK IF OUTPUT LFN AL- #
          BEGIN         # READY EXISTS. IF SO, -CHECKFORLFN- WILL REL- #
          SAVELFNAME = 0; 
          B<0,CURLENG * 6>SAVELFNAME = B<0,CURLENG * 6>ICW[0];
          CHECKFORLFN;  # EASE CM ASSOCIATED WITH IT AND RELINK LIST.  #
          END 
        END 
  
  
# POSITION THE ARRAY TO THE LOCATION OF THE CONTAINING LFNINFO TABLE   #
  
      P<LFNINFO> = SORTCOM[INPUT] - L$FITOFFSET;
  
  
      P<DESPTR> = L$DESPTR;                                              SORTSEM
      DESLIST = DESADDR[0]; 
      FSIZE = DESSIZE[0];          # SET FSIZE OF OUTPUT FILE TO FSIZE #
                                   # OF INPUT FILE                     #
      DESCOUNT[0] = DESCOUNT[0] + 1;    # INCREMENT COUNTER--SORT FILES#
      EC = 1;               # ENTRY CODE OF 1 MEANS A CALL FROM SORT.  #
  
  
# POSITION THE ARRAY TO THE LOCATION OF THE CONTAINING LFNINFO TABLE   #
  
       P<HOLDER> = SORTCOM[INPUT];  # POINT TO FIT FOR LINKNEWLFN      #
  
  
      LINKNEWLFN (EC);      # LINK OUTPUT LFN ONTO LIST OF LFNS.       #
      P<LFNINFO> = CURRENTLFPTR;
      SORTCOM[OUTPUT] = LOC(L$FITLOC);                                   SORTSEM
      STDYES;                      # SUCCESSFUL RETURN                 #
      END 
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     S O R T S E Q                                                    #
#                                                                      #
# DOES INITIALIZATION PRIOR TO STORING A COLLATING SEQUENCE FOR SORT   #
  
      XDEF PROC SORTSEQ;
      PROC SORTSEQ; 
  
      BEGIN 
      IF HAVESEQ THEN              # IF ALREADY SPECIFIED A COLL. SEQ. #
        BEGIN 
        STDNO;                     # BAD RETURN - ALREADY HAVE A SEQ.  #
        END 
  
      ELSE
        BEGIN 
        STDYES;                    # GOOD RETURN - NO SEQUENCE YET     #
        END 
      END 
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     S T A R T K E Y                                                  #
#                                                                      #
# THIS PROC IS CALLED TO START OFF THE PROCESSING OF KEYS. IT CHECKS   #
# THAT KEYS HAVE NOT YET BEEN SPECIFIED, AND INITIALIZES SOME LOCAL    #
# ITEMS FOR *SORTKEY*.                                                 #
  
      XDEF PROC STARTKEY; 
      PROC STARTKEY;
  
      BEGIN 
      IF HAVEKEYS THEN             # IF HAVE ALREADY PROCESSED KEYS    #
        BEGIN 
        STDNO;                     # BAD RETURN - NOT 1ST *ON* KEYWORD #
        END 
  
      HAVEKEYS = TRUE;             # NOW WE ARE PROCESSING KEYS        #
      K = 0;                       # INDEX OF NEXT WORD FOR KEY TABLES #
      CNT = 0;                     # COUNT OF KEYS PROCESSED SO FAR    #
      STDYES;                      # SUCCESSFUL RETURN                 #
      END 
  
  
  
  
#----------------------------------------------------------------------#
  
  
      END 
      TERM
