*DECK             PF1SUB
USETEXT   TSOURCE 
USETEXT   TSYMCNS 
USETEXT   TCEXECQ 
USETEXT   TSYMC5Q 
USETEXT   TCOM37Q 
USETEXT   TCEXEC
USETEXT   TSYMC5
PROC PF1SUB;
     BEGIN
  
*CALL COMEX 
  
  
  
#     XREFS                                                            #
  
XREF PROC SYMABT;                                                        PF1SUB 
XREF PROC CODCLR; 
XREF PROC DUMP; 
XREF PROC ABORT;
XREF PROC FLUSH;
XREF PROC POST; 
XREF PROC PNAM; 
XREF PROC SPOST;
XREF PROC SOVER;
XREF PROC FIND; 
XREF PROC SRCH; 
XREF PROC POPN; 
XREF PROC POPR; 
XREF PROC DIAG;                                                          PF1SUB 
XREF PROC DIAG0;                                                         PF1SUB 
XREF PROC XRUSE;
  
  
  
  
#     DEFS                                                             #
  
      DEF D005 #  5#;        #DIAGNOSTIC   5# 
      DEF D007 #  7#;        #DIAGNOSTIC   7# 
      DEF D067 # 67#;        #DIAGNOSTIC  67# 
      DEF D068 # 68#;        #DIAGNOSTIC  68# 
      DEF D069 # 69#;        #DIAGNOSTIC  69# 
      DEF D070 # 70#;        #DIAGNOSTIC  70# 
      DEF D071 # 71#;        #DIAGNOSTIC  71# 
      DEF D087 # 87#;        #DIAGNOSTIC  87# 
      DEF D108 #108#;        #DIAGNOSTIC 108# 
      DEF D146 #146#;        #DIAGNOSTIC 146# 
      DEF D166 #166#;        #DIAGNOSTIC 166# 
      DEF D197 #197#;        #DIAGNOSTIC 197#                            PF1SUBC
      DEF J815 #815#;               # SYMABT DIAGNOSTIC 815            # PF1SUB 
  
      DEF OUTSCP #SCPOUT#;
      DEF LINKFP #FPLINK#;
  
  
  
#     XDEFS                                                            #
  
XDEF PROC B$KT; 
XDEF PROC DEFEXP; 
XDEF PROC ESCOPE; 
XDEF PROC FPLINK; 
XDEF PROC GENLAB; 
XDEF PROC OPERND; 
XDEF PROC PCONS;
XDEF PROC POSTNN; 
XDEF PROC POW;
XDEF PROC SCPIN;
XDEF PROC SCPOUT; 
XDEF PROC S$EMI;
XDEF PROC T$ERM;
XDEF PROC XCHAIN;  # ADD ENTRY TO XTRN CHAIN# 
      CONTROL EJECT;
      PROC XCHAIN((L)); 
      BEGIN 
     ITEM L,XCHTMP;      #L IS THE ENTRY ADDRESS# 
          IF XPLC EQ 0 THEN 
               BEGIN
               PNAM(XTRNAM,XTRNML,XCHTMP);
               POST(XCHTMP,SLCWDS,XPLC);
               CLAS[XPLC]=S"SLC"; 
               ASEQ[ESPLC]=XPLC;
               ESPLC=XPLC;
               ESDC[XPLC]=S"XTRN";
          BABY[XPLC]=L; 
               END
          ELSE ASEQ [LENT[XPLC]]=L; 
          LENT[XPLC]=L; 
      END 
      CONTROL EJECT;
PROC SCPIN; 
      BEGIN 
  NXTBN=NXTBN+1;
  SCPLEV=SCPLEV+1;            #SCOPE LEVEL# 
##       IF NXTBN GR NSCPLV THEN BEGIN
          SYMABT(J815,">100 PROGRAM SCOPES(SCPIN IN PF1SUB)",36);        PF1SUB 
##       END
  SCOPE=NXTBN;
  ENDM[SCOPE]=FALSE;
      END 
      CONTROL EJECT;
PROC SCPOUT;
     BEGIN
  ITEM I; 
  ENDM[SCOPE]=TRUE; 
SCPLEV=SCPLEV-1;         #SCOPE LEVEL#
  FOR I=SCOPE STEP -1 UNTIL 1 DO
    IF NOT ENDM[I] THEN 
      BEGIN 
      SCOPE=I;
      RETURN; 
      END 
      DIAG0(D005);                                                       PF1SUB 
  T$ERM;
         TPYB = FLCHED[SCOPE]  ;    # WOOPS - WE SHOULDNT HAVE           L414 
                                      DESTROYED TPYB      #              L414 
  END 
      CONTROL EJECT;
      PROC POW((NP),(WDS),(CVAL),(CSVAL));
      BEGIN 
               #FANCY POST ROUTINE                # 
          ITEM NP,WDS,CVAL,CSVAL; 
          POST (NP,WDS,DSEC); 
          CLAS[DSEC]=CVAL;
          CSTR[DSEC]=CSVAL; 
          SBEG[DSEC]=SCOPE; 
          CSRF[POZN]=DSEC;
      END 
      CONTROL EJECT;
      PROC PCONS(CON,(LEN),(TYPEVL));   #POST CONSTANTS#
      BEGIN 
     ARRAY CON[0:0]S(1);ITEM CONI(0,0,CMPAR3);    #CONSTANT ITSELF# 
          ITEM
          LEN            #LENGTH#       , 
          TYPEVL         #TYPE#         , 
  
          TLNK,LINK;     #TEMPORARY INTERNAL STORAGE# 
  
ITEM CCLENG;   #CHARACTER CONSTANTS HAVE NBYT=LENGTH,NCHR=K*WORDS#
ITEM CONTEM;        #TEMP FOR PADDING VALUE#
  
  
  
  
          IF PRSFLG NQ 0 THEN #DONT POST# 
               BEGIN
          CONTEM=0;     #TRUE EXCEPT FOR CHARACTERS#
               REPLFAC = CONI[0];   #SAVE INTEGER VALUE  #               L420 
          IF ITMTYP EQ S"EBCD" THEN                                      L420 
            BEGIN                                                        L420 
            CONTEM = BLANKW ;       # PADDING FOR CHARACTERS  #          L420 
            IF TYPEVL NQ QTYPE"EBCD" THEN                                L420 
                  # WHAT DO WE DO WITH INT TO CHAR CONVERSIONS .....#    L420 
              BEGIN                                                      L420 
                  # CONI IS A 60 BIT CONSTANT  #                         L420 
              TLNK = NBYT[ITMLOC];     # LENGTH OF SINK  #               L420 
              LINK = 0;                                                  L420 
              IF TLNK GR 10 THEN                                         L420 
                BEGIN                                                    L420 
                FOR LINK = 0 STEP 1 UNTIL TLNK/10 DO                     L420 
                  PCCON[LINK] = 0;                                       L420 
                TLNK = TLNK - ( TLNK/10 ) *10;                           L420 
                LINK = LINK - 1;                                         L420 
                END                                                      L420 
              IF TLNK EQ 0 THEN                                          L420 
                TLNK = 10;                                               L420 
                B< 0 , TLNK * 6 > PCCON[LINK] = CONI[0];                 L420 
              RETURN;                                                    L420 
              END                                                        L420 
            END                                                          L420 
          FOR LINK=0 STEP 1 UNTIL CMPR13 DO PCCON[LINK]=CONTEM; #PAD# 
               LINK=(LEN+CMPR12-1)/CMPR12-1 ;      #WORD LENGTH#
               FOR TLNK=0 STEP 1 UNTIL LINK DO
                    PCCON[TLNK]=CONI[TLNK]; 
               RETURN;
               END
          IF TYPEVL EQ QTYPE"EBCD" THEN 
               CCLENG=NBYTWD*((LEN+NBYTWD-1)/NBYTWD); 
          ELSE CCLENG=LEN;
          PNAM(CON,CCLENG,TLNK);
          SPOST (TLNK,CNSWDS,FOUND,LINK);         #POST ATTRIBUTE SEC # 
RETRY:    IF NOT FOUND THEN 
               BEGIN                              #NEW SECTION #
               CLAS[LINK]=S"CONS";
               TYPE[LINK]=TYPEVL; 
               IF TYPEVL EQ QTYPE"EBCD" THEN NBYT[LINK]=LEN;
               ELSE IF TYPEVL EQ QTYPE"IGR" THEN  #FANCY NBIT COMPUTATN#
                         BEGIN
                         FOR TLNK=1 STEP 1 UNTIL CMPR17 DO
                              BEGIN 
                              IF CONI[0] LS POWER2[TLNK] THEN 
                                   BEGIN
                                   NBIT[LINK]=TLNK; 
                                   GOTO OUT;
                                   END
                              END 
WSIZE:                   NBIT[LINK]=IGRLEN;       #TARGET WORD SIZE#
                         END
                    ELSE NBIT[LINK]=LEN*BYTSIZ; 
OUT:           CSRF[POZN]=LINK; 
               RETURN;
               END
          IF CLAS[LINK] NQ S"CONS" OR 
             TYPE[LINK] NQ TYPEVL THEN GOTO REJECT; 
          #CONSTANTS OF THE SAME VALUE AND TYPE AS THE CURRENT ONE
           WILL DO---EXCEPT FOR CHARACTER CONSTANTS, WHOSE LENGTH 
           MUST ALSO MATCH# 
          #CHECK FOR NON-CHARACTER CONSTANTS# 
          IF TYPEVL NQ QTYPE"EBCD" THEN GOTO OUT;   # OLD ONE OK# 
          #FOR CHARACTER CONSTANTS--CHECK LENGTH# 
          IF NBYT[LINK] EQ LEN THEN GOTO OUT;    # OK IF LENGTH MATCHES#
REJECT:   # THIS ENTRY UNSUITABLE--FIND ANOTHER#
          SOVER (LINK); 
          GOTO RETRY; 
      END 
      CONTROL EJECT;
      PROC FPLINK(FPAR,(NEW));
#THIS PROCEDURE LINKS AN OLD FORMAL PARAMETER ENTRY FOR WHICH 
A FORMAL DECLARATION HAS JUST BEEN DISCOVERED TO THE ENTRY FOR
THE ENTITY DECLARED.  SINCE MORE THAN ONE FORMAL PARAMTEER MAY BE 
INVOLVED, THE ENTIRE CHAIN (THROUGH FDFP) OF WAITING FORMAL 
PARAMETERS MUST BE SO SET                         # 
     BEGIN
          ITEM FPAR,NEW,T;
          FPRI[NEW] = FPRI [FPAR] ; #COPY NAME OR VALUE CALL #           NEWFEAT
F1:       T=FDFP[FPAR];                           #MAYBE LINK TO ANOTHR#
          FDFP[FPAR]=NEW; 
          IF T EQ 0 THEN RETURN;                  #NO MORE FPARS# 
          FPAR=T;                                 #GO DO NEXT#
          GOTO F1;
          END 
      CONTROL EJECT;
      PROC POSTNN((PNNL),PNNA); 
      BEGIN 
     ITEM PNNL,PNNA;
     POST(NONAM,PNNL,PNNA); 
     RETURN;
      END 
      CONTROL EJECT;
PROC ESCOPE;
      BEGIN 
  
     #THIS SECTION PERFORMS END-OF-SCOPE PROCESSING.  IN ADDITION TO
     MOVING THE SCOPE MARKER BACK TO THE LAST OPEN SCOPE AND CLOSING THE
     NEWLY DEFUNCT ONE, THE ROUTINE MUST PROCESS THE FLCH CHAIN FOR 
     THE OLD SCOPE.  THIS CHAIN CONTAINS THREE KINDS OF ENTRIES:  
          1.   FORWARD-REFERENCED LABELS AND PROCS.  WHEN THESE WERE PUT
                    ON THE CHAIN, ITEM DECL WAS SET TO S"NONE".  IF THEY
                    HAVE BEEN SUBSEQUENTLY DECLARED, DECL WILL BE NOW AT
                    VALUE S"REAL", AND THEY WILL NOT BE PROCESSED.  IF
                    DECL IS STILL S"NONE", THE LABELS OR PROCS MUST NOW 
                    BE BROUGHT OUT TO THE NEW SCOPE FOR LATER RESOLUTION
                    AND WILL THUS HAVE SBEG RESET AND WILL BE CHAINED IN
                    THE FLCH CHAIN OF THE OUTER SCOPE.  IT IS POSSIBLE
                    THAT AT THIS TIME THEY OFFER RESOLUTION TO PREVIOUSL
                    ENCOUNTERED NAMES IN THE OUTER SCOPE WHOSE TYPE WAS 
                    ABBIGUOUS, OR TO FORMAL PARAMETERS OF THE OUTER 
                    SCOPE.       THESE FORWARD REFERENCES SOMETIMES 
                    OCCUR AL LABEL OR PROC ENTRIES, AND SOMETIMES AS
                    DUMMY ENTRIES, REPRESENTING OCCURENCES OF A SORT
                    WHOSE TYPE COULD NOT BE DETERMINED.  THE DUMMIES
                    POINT WITH RLNK TO ANY SUBSEQUENT BETTER DEFINITION 
                    OR RESOLUTION OF TYPE, AND IF THEY SO POINT THEY ARE
                    NOT PROCESSED.    SOME DUMMIES, LABELS, AND PROCS 
                    ACT TO SATISFY PARAMETERS IN THE INNERSCOPE  ---
                    THESE MUST NOT BE BROUGHT OUT, SINCE NO DECLARATION 
                    WILL BE MADE FOR THEM.  IN THE CASE OF DUMMIES OF 
                    THIS TYPE, A LABEL ENTRY IS POSTED AND THE DUMMY IS 
                    LINKED TO IT. 
          2.   FORMAL DECLARATIONS OF A PROTECTIVE NATURE ARE CHAINED IN
                    THE FLCH CHAIN OF THE SCOPE IN WHICH THEY OCCUR.  AT
                    THE END OF THE CCOPE, THEY MUST HAVE BEEN FURTHER 
                    DECLARED OR A DIAGNOSTIC IS ISSUED. 
                    ALSO, XDEF PROCS AND FUNCS ARE PLACED ON THE CHAIN
                    TO BE CHECKED AT SCOPE END. 
          3.   FORMAL PARAMETERS TO A SCOPE ARE ON ITS FLCH CHAIN.    AT
                    THE END OF SCOPE A DIAGNOSTIC OF LOW SEVERITY IS
                    ISSUED FOR THOSE FORMAL PARAMETERS WHICH WERE NEITHE
                    USED NOR DECLARED IN THE SCOPE. 
# 
  
          #CLOSE SCOPE AND FIND OUTER OPEN ONE# 
ESCO10:   TPYB=FLCHED[SCOPE]; 
          OUTSCP; 
          #PROCESS FLCH CHAIN FOR OLD SCOPE#
ESCO15:   TPYC=FLCH[TPYB];
          IF TPYB EQ 1 THEN                       #DONE#
               BEGIN
               IF SCOPE EQ 1 THEN                 #LAST SCOPE-DIAGNOSE
                                                   STRAGGLERS#
                    BEGIN 
                    ITEM I,J,K;                                          L420 
                    # WE MAY HAVE A LOOPY FLCHED CHAIN WHICH WILL CAUSE  L420 
                      A LOOP ON DIAG 67              #                   L420 
                    TPYB = FLCHED[SCOPE];                                L420 
                    I =1;                                                L420 
                    IF TPYB EQ 1 THEN RETURN;                            L420 
                    DIAG(D067,TPYB);
                    UNDEC[TPYB] = TRUE;                                  L420 
NEXTL:                                                                   L420 
                    K = FLCHED[SCOPE];                                   L420 
                    TPYB = FLCH[TPYB];                                   L420 
                    IF TPYB EQ 1 THEN                                    L420 
                      RETURN;                                            L420 
                    DIAG(D067,TPYB);
                    UNDEC[TPYB] = TRUE;                                  L420 
                    FOR J =1 STEP 1 UNTIL I DO                           L420 
                      BEGIN                                              L420 
                     IF K EQ TPYB THEN                                   L420 
                        BEGIN   # ITS A LOOP   #                         L420 
                        DIAG(D166,K); 
                        FLCH [TPYB] = 1;                                 L420 
                        RETURN;                                          L420 
                        END                                              L420 
                      K = FLCH[K] ;                                      L420 
                      END                                                L420 
                    I = I + 1;                                           L420 
                    GOTO NEXTL;                                          L420 
                    END 
               RETURN;
               END
          IF CLAS[TPYB] EQ S"LABL" OR 
             CLAS[TPYB] EQ S"PROC"      THEN
               BEGIN
               IF DECL[TPYB] EQ S"NONE" THEN
                    BEGIN 
                    IF CLAS[TPYB] EQ S"LABL"                             PF1SUBC
                    THEN                                                 PF1SUBC
                      BEGIN                                              PF1SUBC
                      DIAG(D197, TPYB); 
                      END                                                PF1SUBC
                    IF FPRI[TPYB]EQ S"NAMC" THEN GOTO ESCO80; 
ESCO20:             SBEG[TPYB]=SCOPE; 
                    FIND(TPYB,TPYA);
                    SRCH(TPYA,FOUND,DSEC);
ESCO22: 
                    IF FOUND THEN 
                         BEGIN
                         IF ENDM[SBEG[DSEC]] OR 
                            DSEC EQ TPYB THEN 
                              BEGIN 
                              SOVER(DSEC);
                              GOTO ESCO22;
                              END 
                         ELSE 
                              BEGIN 
                              IF SBEG[DSEC]NQ SCOPE THEN GOTO ESCO25; 
                              IF CLAS[DSEC] EQ S"FPAR" THEN 
                                   BEGIN
                                   LINKFP(DSEC,TPYB); 
                                   GOTO ESCO80; 
                                   END
                              IF CLAS[DSEC] EQ S"DUMY" THEN 
                                   BEGIN
                                   RLNK[DSEC]=TPYB; 
                                   LREF[DSEC] = LREF[DSEC] + LREF[TPYB];
                                   GOTO ESCO25;   #FLCH#
                                   END
                                   DIAG(D071,TPYB);                      PF1SUB 
                              END 
                         END
ESCO25:             FLCH[TPYB]=FLCHED[SCOPE]; 
                    FLCHED[SCOPE]=TPYB; 
                    GOTO ESCO80;
                    END 
      FLCH[TPYB]=0; #CLEAR LOCN FIELD IN CASE IT IS AN XREF#
               IF DECL[TPYB]EQ S"FORMAL" THEN 
                    BEGIN 
                    IF XTRN[TPYB]NQ S"ENT" THEN GOTO ESC68; 
ESC108: 
      DIAG(D108,TPYB);
          GOTO ESCO80;                                                   NEWFEAT
ESC68:    IF FPRI[TPYB] NQ S"NAMC" THEN 
            BEGIN 
            UNDEC[TPYB] = TRUE; 
          DIAG(D068,TPYB);
            END 
                    END 
               GOTO ESCO80; 
               END
          IF CLAS[TPYB] EQ S"DUMY" THEN 
               BEGIN
               IF SBEG [TPYB] EQ 0
               AND FPRI[TPYB] NQ S"NAMC"
               THEN 
                 GOTO ESCO80;   # DO NOT PROCESS FORWARD LINKS
                                  TO ACTUAL LABELS# 
               IF RLNK[TPYB] EQ 0 THEN
                    BEGIN 
                    IF FPRI[TPYB]EQ S"NAMC" THEN
                         BEGIN
                         FIND (TPYB,NSEC);
                     POW( NSEC, LABWDS ,QCLAS"LABL" , CLIST"LABNAM"); 
                         RLNK[TPYB]=DSEC; 
            APNM[DSEC] = SCPN[SCOPE]; 
                         LREF[DSEC] = LREF[TPYB]; 
                         FPRI[DSEC]=S"NAMC";
                         SBEG[DSEC]=SBEG[TPYB]; 
                             ASEQ[LENT[DPLC]] =DSEC;
                             LENT[DPLC] = DSEC; 
                             #FORMAL LABELS MUST BE ON DATA ALOC CHAIN# 
                         TPYA = FLCH[TPYB];    # LOOK DOWN FLCH # 
FLESCHD:  
                         IF TPYA GR 1 THEN
                           BEGIN
                           IF CLAS[TPYA] EQ S"FPAR" 
                           AND FDFP[TPYA] EQ TPYB 
                           THEN    # FPAR STILL RESOLVED TO DUMY# 
                             FDFP[TPYA] = DSEC;#RESOLVE TO LABL#
                           TPYA = FLCH[TPYA]; 
                           GOTO FLESCHD;
                           END
                         GOTO ESCO80; 
                         END
                    GOTO ESCO20;
                    END 
               ELSE 
                    GOTO ESCO80;
               END
          IF CLAS[TPYB]EQ S"FUNC" THEN
               BEGIN
               IF DECL[TPYB]EQ S"REAL"THEN GOTO ESCO80; 
               GOTO ESC108; 
               END
          #FPAR#
      IF FDFP[TPYB] EQ 0
      THEN
          DIAG(D069,TPYB);
ESCO80:   TPYB=TPYC;
          GOTO ESCO15;
      END 
      CONTROL EJECT;
PROC T$ERM; 
      BEGIN 
          #GET RID OF DUMMIES IN ALLOCATION CHAINS# 
          BABY[CPLC]=ASEQ[BABY[CPLC]];
          BABY[DPLC]=ASEQ[BABY[DPLC]];
CHGNAM(APLC,SCPN[0],"=A");
CHGNAM(CPLC,SCPN[0],"=C");
CHGNAM(DPLC,SCPN[0],"=D");
CSLC=CPLC;  ASLC=APLC;  DSLC=DPLC;  XSLC=XPLC;
  
          CODCLR; 
          STERF=0;
          POPR(QILOP"PTRM");
           POPR(0);     #OUTPUT LAST WORD +1# 
          FLUSH;
      END 
      CONTROL EJECT;
#    FIX UP SECTION SOCATION COUNTER NAMES# 
PROC CHGNAM(PLC,PRGNAM,STR);
     BEGIN
     ITEM PLC,PRGNAM,STR C(2),I,J;
     IF PRGNAM EQ 0 THEN RETURN;
     IF NNAM[PRGNAM] THEN RETURN; 
     FIND(PRGNAM,NSEC); 
     NAMARR[0]=NAME[NSEC];
     I=NCHR[NSEC];
     IF I GR CMPR12 THEN NAMARR[1]=NAME[NSEC+1];
          ELSE NAMARR[1]=" "; 
     IF I GR CMPR15 THEN I=CMPR15;
      C<I,2>NAMARR[0]=STR;
     PNAM(ZNAMR,I+2,J); 
     FIND(PLC,NSEC);
NL: 
     IF NLNK[NSEC] NQ PLC THEN               #FIND PLC TO LINK OUT# 
          BEGIN 
          NSEC=NLNK[NSEC];
          GOTO NL;
          END 
     #LINK PLC OUT OF OLD AAME CHAIN AND INTO NEW ONE#
     NLNK[NSEC]=NLNK[PLC];
     NLNK[PLC]=NLNK[J]; 
     NLNK[J]=PLC; 
     END
      CONTROL EJECT;
PROC S$EMI; 
      BEGIN 
          CODCLR;             #KILL BAD CODE BUFFERS# 
          NPARLS=0;                     #MASTER FAILSAFE GOODY TABLE# 
          PSTCS=0;                 #PRESTATEMENT CODE STACKER#
          STERF=DEBBRK;       #INHIBIT DEBUG CODE IF 1-ELSE CLEAR#
          LEVLOP=0;                #BOOLEAN OPERATOR THINGS#
          NTEMPU[SCOPE]=0;                   #TEMP RE-USE CONTROL#
          BLABL[0]=0; 
          PRSFLG=0;       #"IN PRESET" FLAG#
      IF BRKLEV EQ 0 THEN RETURN; 
          DIAG0(D007);                                                   PF1SUB 
BRKLEV=0; 
      END 
      CONTROL EJECT;
PROC B$KT;
      BEGIN 
          IF BRKLEV EQ 0 THEN RETURN; 
          DIAG0(D007);                                                   PF1SUB 
          BRKLEV=0; 
      END 
      CONTROL EJECT;                                                     DEFEXP 
      PROC DEFEXP;                                                       DEFEXP 
      BEGIN  # DEFEXP #                                                  DEFEXP 
#----------------------------------------------------------------------# DEFEXP 
#                                                                      # DEFEXP 
#     P R O C   D E F E X P                                            # DEFEXP 
#                                                                      # DEFEXP 
#     DESCRIPTION:                                                     # DEFEXP 
#                  EXPANDS THE INDICATED DEF INTO THE PRECOGNITION     # DEFEXP 
#                  ARRAY CSTAK AND INCREMENTS THE CONTROL WORD CSTAKP  # DEFEXP 
#                  OF THAT ARRAY TO REFLECT THE EXPANSION.             # DEFEXP 
#                                                                      # DEFEXP 
#     CALLED BY:                                                       # DEFEXP 
#                  PF11, PF12                                          # DEFEXP 
#                                                                      # DEFEXP 
#     CALLS:                                                           # DEFEXP 
#                  DIAG:     (EXT) TO ISSUE ERROR DIAGNOSTICS          # DEFEXP 
#                  XRUSE:    (EXT) TO WRITE ON THE CROSS-REFERENCE FILE# DEFEXP 
#                  PRINT, LIST, ENDL:  FOR DEBUG CODE VIA *=6          # DEFEXP 
#                                                                      # DEFEXP 
#     PARAMETERS:                                                      # DEFEXP 
#                  NONE                                                # DEFEXP 
#                                                                      # DEFEXP 
#     VARIABLES:                                                       # DEFEXP 
#                  CARD:     CURRENT SOURCE CARD NUMBER                # DEFEXP 
#                  DEFXCT:   DEF EXPANSIONS DONE FOR THIS CARD         # DEFEXP 
#                  II:       LOCAL TEMPORARY                           # DEFEXP 
#                                                                      # DEFEXP 
#     COMMENTS:                                                        # DEFEXP 
#                  ON ENTRY, TPYA MUST CONTAIN THE CHARACTER WHICH     # DEFEXP 
#                  IMMEDIATELY FOLLOWED THE DEF-NAME.  TPYB MUST POINT # DEFEXP 
#                  TO THE SYMBOL TABLE ENTRY OF CLAS"DEF" FOR WHICH    # DEFEXP 
#                  EXPANSION IS TO BE PERFORMED.                       # DEFEXP 
#                                                                      # DEFEXP 
#----------------------------------------------------------------------# DEFEXP 
                                                                         DEFEXP 
      DEF EXPANDTH #150#;          # MAXIMUM EXPANSIONS PER CARD       # DEFEXP 
                                                                         DEFEXP 
      ITEM CARD          I = 0;    # LOCAL CRDNO                       # DEFEXP 
      ITEM DEFXCT        I = 0;    # DEF EXPANSIONS DONE FOR THIS CARD # DEFEXP 
      ITEM II            I;        # LOCAL TEMPORARY                   # DEFEXP 
                                                                         DEFEXP 
      IF SPTR [TPYB] EQ 0          # DEFINE STRING POINTER IS ZERO     # DEFEXP 
      THEN                                                               DEFEXP 
        BEGIN                                                            DEFEXP 
        DIAG (D070, TPYB);         # ILL DEF ID-NO EXPANSION           # DEFEXP 
        END                                                              DEFEXP 
                                                                         DEFEXP 
      ELSE                                                               DEFEXP 
        BEGIN                                                            DEFEXP 
        IF SPTR [TPYB] EQ 1        # NULL PARAMETER FROM MACRO         # DEFEXP 
        THEN                                                             DEFEXP 
          BEGIN                                                          DEFEXP 
          GOTO ODNLD1;                                                   DEFEXP 
          END                                                            DEFEXP 
                                                                         DEFEXP 
        II = NCHR [SPTR [TPYB]] + CSTAKP;                                DEFEXP 
        IF II + 1 GR CSTKCP                                              DEFEXP 
        THEN                                                             DEFEXP 
          BEGIN                                                          DEFEXP 
          DIAG (D087, TPYB);       # DEF ID EXPANSION NEST TOO DEEP    # DEFEXP 
          RETURN;                                                        DEFEXP 
          END                                                            DEFEXP 
                                                                         DEFEXP 
        IF CARD EQ CRDNO                                                 DEFEXP 
        THEN                                                             DEFEXP 
          BEGIN                                                          DEFEXP 
          DEFXCT = DEFXCT + 1;                                           DEFEXP 
          IF DEFXCT GR EXPANDTH                                          DEFEXP 
          THEN                                                           DEFEXP 
            BEGIN                                                        DEFEXP 
            DIAG (D146, TPYB);     # CIRCULAR DEF NAME EXPANSION       # DEFEXP 
            DEFXCT = 0;                                                  DEFEXP 
            RETURN;                                                      DEFEXP 
            END                                                          DEFEXP 
          END                                                            DEFEXP 
                                                                         DEFEXP 
        ELSE                                                             DEFEXP 
          BEGIN                                                          DEFEXP 
          CARD = CRDNO;                                                  DEFEXP 
          DEFXCT = 0;                                                    DEFEXP 
          END                                                            DEFEXP 
                                                                         DEFEXP 
        TLD1 = 0;                  # NEXT BIT POSITION                 # DEFEXP 
        TLD2 = 0;                  # NEXT WORD POSITION                # DEFEXP 
        TLD3 = 0;                  # DEF CHARACTERS SEEN THUS FAR      # DEFEXP 
                                                                         DEFEXP 
ODNLD:                                                                   DEFEXP 
        CSTAK [II - TLD3] = B<TLD1, TPYC> INAM [SPTR [TPYB] + TLD2];     DEFEXP 
        CSTAKD [II - TLD3] = TRUE;  # SET DEF BIT                      # DEFEXP 
        TLD3 = TLD3 + 1;                                                 DEFEXP 
        IF TLD3 LS II - CSTAKP                                           DEFEXP 
        THEN                                                             DEFEXP 
          BEGIN                                                          DEFEXP 
          TLD1 = TLD1 + TPYC;      # INCREMENT BY SIZE OF MACRO CHAR.  # DEFEXP 
          IF TLD1 GQ CMPAR3        # FINISHED WITH CURRENT WORD        # DEFEXP 
          THEN                                                           DEFEXP 
            BEGIN                                                        DEFEXP 
            TLD1 = 0;              # NEXT BIT POSITION                 # DEFEXP 
            TLD2 = TLD2 + 1;       # NEXT WORD POSITION                # DEFEXP 
            END                                                          DEFEXP 
                                                                         DEFEXP 
          GOTO ODNLD;                                                    DEFEXP 
          END                                                            DEFEXP 
                                                                         DEFEXP 
        CSTAK [ CSTAKP] = TPYA;                                          DEFEXP 
        CSTAKP = II + 1;                                                 DEFEXP 
        END                                                              DEFEXP 
                                                                         DEFEXP 
ODNLD1:                                                                  DEFEXP 
      XRUSE (TPYB, CRDN);          # "USE" ENTRY TO XREF FILE          # DEFEXP 
      LNAME [BRKLEV] = PLNAM;      # RESTORE PREVIOUS NAME             # DEFEXP 
                                                                         DEFEXP 
      DCXFLG = DXFTP;              # FIX SEARCH ENVIRONMENT            # DEFEXP 
      DESFLG = DSFTP;                                                    DEFEXP 
      SCXFLG = SCFTP;                                                    DEFEXP 
                                                                         DEFEXP 
      $BEGIN                       # ACTIVATED BY *=6 DEBUG OPTION     # DEFEXP 
      IF DEBFLG EQ 1                                                     DEFEXP 
      THEN                                                               DEFEXP 
        BEGIN                                                            DEFEXP 
        CDUMP (LOC (CSTAK [0]), CSTAKP, " CSTAKP ------------" );        DEFEXP 
        PRINT ("( 10H CRUDDY ST , (O20) )");                             DEFEXP 
        LIST (TPYA);                                                     DEFEXP 
        LIST (TPYB);                                                     DEFEXP 
        LIST (TLD1);                                                     DEFEXP 
        ENDL;                                                            DEFEXP 
        END                                                              DEFEXP 
      $END                                                               DEFEXP 
                                                                         DEFEXP 
      END  # DEFEXP #                                                    DEFEXP 
      CONTROL EJECT;
      PROC OPERND((N)); 
      BEGIN 
     ITEM N;
     POPN(N); 
          IF FPRI[N] EQ S"NAMC" THEN POPR(QILOP"PARM"); 
      END 
      CONTROL EJECT;
PROC GENLAB(GENL);
      BEGIN 
          ITEM GENL;
          POST(NONAM,LABWDS,GENL);      #POST LABEL ENTRY#
          CLAS[GENL]=S"LABL"; 
          ASEQ[LENT[CPLC]]=GENL;        #CHAIN INTO CODE CHAIN# 
          LENT[CPLC]=GENL;
     APNM[GENL]=SCPN[SCOPE];       #SCOPE NAME FOR LABEL# 
     LREF[GENL]=1;#ALL GEN LABS REFERENCED ONCE AT LEAST--MORE FOR SOME#
      END 
END 
TERM
