*DECK             CODE
USETEXT   TSOURCE 
USETEXT   TSYMCNS 
USETEXT   TCEXECQ 
USETEXT   TSYMC5Q 
USETEXT   TCEXEC
USETEXT   TSYMC5
USETEXT   TCOM37Q 
      PROC CODE;
  
#     CODE - A COLLECTION OF SUBROUTINES WHICH MANIPULATE CODE BUFFERS #
  
#     CONTAINS-                                                        #
#         POPR - PUT OUT IL OPERATOR                                   #
#         POPN - PUT OUT IL OPERAND                                    #
#         OPRNDV - SET OPERAND FIELD IN LAST SET IL WORD               #
#         CSAV - DEFINE CODE BUFFER AND START SAVING CODE              #
#         ENDSAV - CLOSE CURRENT CODE BUFFER                           #
#         RESTR - RETRIEVE CODE BUFFER                                 #
#         OSAV - REOPEN OLD CODE BUFFER AND START SAVING CODE          #
#         VALID - VALIDATE CODE BUFFER                                 #
#         CODCLR - CODE BUFFER HOUSEKEEPING                            #
#         CODINT - INITIALIZE DATA USED BY SUBROUTINES IN CODE         #
#         FLUSH - FLUSH IL BUFFER TO FILE                              #
  
  
  
  
      ENTRY PROC POPR (OP$);
           BEGIN
  
# ABORT CONDITIONS  # 
  
#  4  SPURIOUS ENDSAV REQUESTED. NO SAVE REQUEST IS STILL CURRENT. #
  
#  5  RESTR(FORGET) CALLED FOR A SAVE LIST WHICH DOES NOT EXIST. #
  
#  6  SYMBOL TABLE OVERFLOW. MAYBE IN SYMBOL TABLE PROPER OR TRANSIENT
       AREA.# 
  
#  7  OVERFLOW IN SAVE CONTROL TABLE(SAVTAB).    #
  
#  8  OVERFLOW IN WHAT"S DOING TABLE(WDT).  # 
  
# 10  RESTR(FORGET) CALLED FOR A SAVE LIST WHICH IS STILL CURRENT, #
#      THAT IS, NO ENDSAV WAS PROCESSED FOR THIS LIST.# 
#    11   RESTORE,OSAV,OR FORGET A NONEXISTENT SAVE BUFFER# 
  
  
  
  
  
*CALL COMEX 
      CONTROL OVERLAP;
  
  
  
*CALL DMPCM6
  
*CALL COM19B
  
      XREF  ITEM  EXCODE     B;    # INDICATES PRESENCE OF EXECUTABLE  #
                                   # CODE ON IL.  FROM  PHASE10        #
  
  
  
  
  
#     DEFS                                                             #
  
      DEF J806 #806#;              # SYMABT DIAGNOSTIC 806             # CODE 
      DEF J807 #807#;              # SYMABT DIAGNOSTIC 807             # CODE 
      DEF J808 #808#;              # SYMABT DIAGNOSTIC 808             # CODE 
      DEF J809 #809#;              # SYMABT DIAGNOSTIC 809             # CODE 
      DEF J810 #810#;              # SYMABT DAAGNOSTIC 810             # CODE 
      DEF J811 #811#;              # SYMABT DIAGNOSTIC 811             # CODE 
      DEF J812 #812#;              # SYMABT DIAGNOSTIC 812             # CODE 
      DEF J813 #813#;              # SYMABT DIAGNOSTIC 813             # CODE 
     DEF BYTE #CMPAR5#; 
     DEF WDL #CMPAR3#;
     DEF HWD #CMPAR4#;
          DEF ILUP #40#;
           DEF LMAX #150#;
DEF COM37I#9#;
 DEF OUTIL # $BEGIN P<$>=P<PUTIL>+1; T=WDSS[0]; IF DUMPIL THEN
  ILDUMP($,T); $END PTILN(PUTIL)# ; 
  
#     WHEN THE SYMTAB IS IN LCM THE CODE BUFFERS STILL RESIDE IN SCM   #
#     TSPACE RETURNS THE APPROPRIATE PTR AND THE FOLLOWING DEF PROVIDES#
#     THE APPROPRIATE ADDRESSABILITY FOR EITHER CASE                   #
  
#SCM# CONTROL IFEQ SYMTBLV,0; 
      DEF CODEBUF #ZSYM#;              #CODE BUFFER RESIDENCE FOR SCM  #
#SCM# CONTROL ENDIF;
#LCM# CONTROL IFNQ SYMTBLV,0; 
      DEF CODEBUF #FREESPACE#;         #CODE BUFFER RESIDENCE FOR LCM  #
#LCM# CONTROL ENDIF;
  
  
  
  
#     XREFS                                                            #
  
 XREF BEGIN PROC TSPACE; PROC RSPACE; PROC ABORT; END 
XREF PROC PTILN;
      XREF PROC SYMABT;                                                  CODE 
  
  
  
  
#     LOCAL DATA                                                       #
  
ARRAY IL[ILUP];  ITEM IL$=[ILUP(0)];
  
          #  * * * THIS-ID PLUS 1 IS *CALL COMCODE  * * * #              CODE/D 
*CALL COMCODE                                                            CODE/D 
          #  * * *  RESUME "CODE"  * * * #                               CODE/D 
  
  
      ITEM I,                #TEMP                                     #
           OP$,              #CURRENT OPERATOR OR OPERAND              #
           PTR,              #POINTER TO CODE BUFFER SPACE             #
           POP B,            #TRUE IFF OP$ IS AN OPERATOR              #
           TMAX,             #MAX NO ENTRIES TO BE PUT IN PUTIL ARRAY  #
           ILPTR,            #INDEX INTO PUTIL ARRAY                   #
           SAVPTR,           #CURRENT CODE BUFFER NUMBER               #
           NAVL,             #NEXT AVAILABLE CODE BUFFER NUMBER        #
           TEMP;             #TEMP                                     #
  
##  $BEGIN
               BASED ARRAY $;;
          ITEM T; 
##  $END
      CONTROL EJECT;
#     CODE FOR POPR BEGINS HERE                                        #
  
#     POPR - PUT OUT IL OPERATOR                                       #
  
  
      $BEGIN
      IF DEBFLG NQ 0 THEN 
          BEGIN 
          PRINT ("(14H    POPR OP$= A5)");
          LIST (LSTOP[OP$]);
          ENDL; 
          END 
      $END
  
      POP = TRUE;            #SET OPERATOR FLAG TRUE                   #
  
      IF  NOT OKOP[ OP$ ] 
      THEN                         # IL CAUSES GENERATED CODE          #
        BEGIN 
        EXCODE = TRUE;
        END 
  
  
POP3:                              # POPN COMES HERE                   #
  
      IF  STERF  NQ 0              # ERRORS IN STATEMENT               #
      THEN                         # DONT PUT OUT IL                   #
        BEGIN 
        RETURN; 
        END 
  
  
      IF  ILPTR + 1 GQ TMAX        # THIS BLOCK FULL                   #
      THEN
        BEGIN 
        WDSS[0] = ILPTR;           # SAVE BLOCK LENGTH IN THE BLOCK    #
        ILPTR = 0;                 # RESET BLOCK COUNT WORD            #
        IF WDPTR EQ 0 
        THEN                       # FLUSH THE BUFFER                  #
          BEGIN 
  
          $BEGIN
          IF  DUMPIL
          THEN
            BEGIN 
            P<$> = P< PUTIL > + 1;
            T = WDSS[0];
            ILDUMP( $, T ); 
            END 
          $END
  
          PTILN( PUTIL ); 
          END 
        ELSE                       # GET NEW BLOCK                     #
          BEGIN 
          TSPACE( PTR );           # GET SPACE FOR NEW BLOCK           #
          SLINK[0] = PTR;          # LINK CURRENT BLOCK TO NEW ONE     #
          LSTR[ WD[ WDPTR ]] = PTR;  # NEW BLOCK NOW LAST IN CHAIN     #
          P< PUTIL > = LOC( CODEBUF ) + PTR;
          END 
        END 
  
      ILPTR = ILPTR + 1;
      ILWD[ ILPTR ] = 0;
      ILOPT[ ILPTR ] = POP;        # TRUE FOR OPERATORS                #
  
      IF  POP 
      THEN
        BEGIN 
        ILOP[ ILPTR ] = OP$;
        END 
      ELSE
        BEGIN 
        ILOPN[ ILPTR ] = OP$; 
        END 
  
      RETURN; 
      CONTROL EJECT;
ENTRY PROC POPN(OP$); 
  
#     POPN - PUT OUT IL OPERAND                                        #
  
      POP = FALSE;           #SET OPERATOR FLAG FALSE                  #
  
      $BEGIN
      IF DEBFLG NQ 0 THEN 
          BEGIN 
          PRINT ("(14H    POPN OP$= O20)"); 
          LIST (OP$); 
          ENDL; 
          END 
      $END
  
         GOTO POP3; 
      CONTROL EJECT;
      ENTRY PROC OPRNDV(OP$); 
  
#     OPRNDV - SET OPERAND FIELD OF LAST WORD PUT IN CODE BUFFER       #
  
      $BEGIN
      IF DEBFLG NQ 0 THEN 
          BEGIN 
          PRINT ("(16H    OPRNDV OP$= O20)"); 
          LIST(OP$);
          ENDL; 
          END 
      $END
  
      ILOPN[ILPTR] = OP$; 
      RETURN; 
      CONTROL EJECT;
  ENTRY PROC CSAV(N); 
  
#     CSAV - OPEN A CODE BUFFER                                        #
  
#     CALLED TO ASSIGN A NEW CODE BUFFER TO THE CALLER SO THAT         #
#     SUBSEQUENT POPN AND POPR CALLS WILL CAUSE IL TO BE SAVED IN THE  #
#     NEW BUFFER                                                       #
  
#     ON OUTPUT, N = THE NUMBER OF THE CODE BUFFER ASSIGNED            #
  
  
          ITEM N; 
  
  
#     IF CODE CONTROL TABLE ALREADY FULL- ABORT                        #
  
##       IF NAVL EQ 0 THEN
            SYMABT(J806,"SAVE CONTROL OVERFLOW (CSAVE IN CODE)",37);     CODE 
      SAVPTR = NAVL;         #GET NUMBER OF NEXT AVAILABLE CODE BUFFER #
      NAVL = LINK[SAVPTR];   #NEXT AVAILABLE BUFFER NUMBER             #
      TMAX = BLKSIZ;         #MAX NO. WORDS TO PUT IN BLOCK            #
          IF HIGSAV LS SAVPTR THEN HIGSAV=SAVPTR; 
      WDSS[0] = ILPTR;       #SAVE NO WORDS IN BLOCK IN FIRST WORD     #
      WDPTR = WDPTR + 1;     # BUMP INDEX INTO WDT TABLE               #
      WD[WDPTR] = SAVPTR;    #PUT CURRENT BUFFER NO IN TABLE           #
  
#     IF TABLE OVERFLOW- ABORT                                         #
  
##       IF WDPTR GR WMAX THEN
            SYMABT(J807,"WHATS DOING TABLE OVERFLOW (CSAVE IN CODE)",    CODE 
                   42);                                                  CODE 
               TSPACE(PTR); #GET SPACE FROM SYMBOL TABLE# 
      LSTR[SAVPTR] = PTR;    #POINTER TO LAST BLOCK OF BUFFER = POINTER#
                             #TO THIS BLOCK                            #
      LINK[SAVPTR] = PTR;    #POINTER TO FIRST BLOCK OF BUFFER= POINTER#
                             #TO THIS BLOCK                            #
  
          SVALID[SAVPTR]=FALSE; 
          SOPEN[SAVPTR]=TRUE; 
          SFULL[SAVPTR]=TRUE; 
  
#     SET PUTIL POINTER TO ADDRESS OF THIS BLOCK                       #
  
      P<PUTIL> = LOC(CODEBUF) + PTR;
               ILPTR=0; 
      N = SAVPTR;            #RETURN BUFFER NUMBER TO CALLER           #
##       $BEGIN 
     IF DEBFLG EQ 0 THEN RETURN;
          PRINT ("(12H    SAVE N= I5)");
                LIST(N);
                ENDL; 
##       $END 
               RETURN;
      CONTROL EJECT;
  ENTRY PROC ENDSAV;
  
#     ENDSAV - CLOSE CURRENT CODE BUFFER                               #
  
  
  
  
##       $BEGIN 
     IF DEBFLG NQ 0 THEN
        BEGIN 
          PRINT ("(14H    ENDSAV N= I5)");
              LIST (WD[WDPTR]); 
                ENDL; 
        END 
##       $END 
  
#     IF NO OPEN BUFFERS- ABORT                                        #
  
##       IF WD[WDPTR] EQ -1 THEN
            SYMABT(J808,"BAD ENDSAVE REQ.NO SAVE REQ EXTANT (ENDSAVE IN  CODE 
 CODE)",53);                                                             CODE 
      WDSS[0] = ILPTR;       #SAVE NO WORDS IN BLOCK IN FIRST WORD     #
  
          SOPEN[WD[WDPTR]]=FALSE; 
               WD[WDPTR]=0;#CLEAR CURRENT WDT ENTRY#
               WDPTR=WDPTR-1; #SET PTR TO PREVIOS STATUS# 
               #WAS PREVIOUS STATUS PUT OR SAVE#
               IF WD[WDPTR] GR -1 THEN GOTO ENDS2;
               #PUT#
                    #RESET BASED ARRAY PTR TO IL TABLE# 
ENDS33:   #    ENTRY FROM CODCLR TO RESET WD TABLE     #
               P<PUTIL>=LOC(IL);
                TMAX=ILUP;
 ENDS3: 
      ILPTR = WDSS[0];       #INDEX INTO BLOCK = NO WORDS ALREADY IN   #
                             #BLOCK                                    #
               RETURN;
  
#     THERE IS AN OPEN BUFFER, M.  WE SET UP SO SUBSEQUENT POPN AND    #
#     POPR CALLS WILL GO INTO M.                                       #
  
 ENDS2: 
  
#     SET TEMP = POINTER TO LAST BLOCK OF M.                           #
  
      TEMP = LSTR[WD[WDPTR]]; 
  
#     SET PUTIL POINTER TO ADDRESS OF LAST BLOCK OF M.                 #
  
      P<PUTIL> = LOC(CODEBUF)+TEMP; 
               GOTO ENDS3;
      CONTROL EJECT;
   ENTRY PROC RESTR(N); 
  
#     RESTR - RESTORE A CODE BUFFER                                    #
  
#     PERMITS RETRIEVAL OF A CLOSED CODE BUFFER.  IF THE CURRENT IL    #
#     DESTINATION IS THE IL OUTPUT BUFFER THEN THE "RESTORED" BUFFER   #
#     WILL APPEAR IN THE IL STREAM.  IF THE CURRENT IL DESTINATION IS  #
#     A CODE BUFFER THEN THE CONTENTS OF THE "RESTORED" BUFFER ARE     #
#     LOGICALLY APPENDED TO THE CURRENT BUFFER BY LINKING THE BLOCKS   #
#     BELONGING TO THE "RESTORED" BUFFER ONTO THE END OF THE CHAIN     #
#     CURRENTLY PART OF THE CURRENT BUFFER.  IN ANY CASE THE "RESTORED"#
#     BUFFER CEASES TO EXIST.  A RESTR OF BUFFER 0 IS IGNORED          #
  
  
  
  
##       $BEGIN 
     IF DEBFLG NQ 0 THEN
        BEGIN 
          PRINT ("(13H    RESTR N= I5)"); 
                LIST(N);
                ENDL; 
        END 
##       $END 
      IF N EQ 0 THEN RETURN; #IGNORE RESTORE OF 0                      #
          POP=STERF EQ 0 OR SVALID[N];            # VALIDATED BUFFERS 
                    CAN BE RESTORED EVEN IN ERROR CASES#
          ZAP(N);                                 #CLEAR SLOT#
          RETURN; 
      CONTROL EJECT;
PROC  ZAP ( (N) );                 #SLOT ERASER#
BEGIN 
  
  
  
  
ITEM N; 
#     IF BUFFER IS NOT CLOSED- ABORT                                   #
  
##       IF NOT SFULL[N] THEN  #SLOT ENPTY# 
           SYMABT(J809,"RESTR/FORGET ON NON-EXTANT SAVE BUFFER (ZAP IN C CODE 
ODE)",52);                                                               CODE 
##       IF SOPEN[N] THEN  # SLOT TOO HOT (IN USE) #
           SYMABT(J810,"RESTR/FORGET ON CURRENT SAVE BUFFER (ZAP IN CODE CODE 
)",49);                                                                  CODE 
      WDSS[0] = ILPTR;       # SAVE WRD COUNT OF CURRENT BLOCK IN BLOCK#
          IF POP THEN              #RESTORE OR FORGET#
               BEGIN                    #RESTORE# 
                    #ARE WE CURRENTLY IN A PUT OR SAVE CONDITION# 
               IF WD[WDPTR] GR -1 THEN GOTO RESTRS; 
                    #PUT# 
               OUTIL;  #OUTPUT IL TABLE # 
               END
         TEMP=LINK[N];                      #GET LOCN OF FIRST TABLE# 
          ILPTR = LOC(CODEBUF) + TEMP;         #IN RESTORE CHAIN       #
          RESTR2:   P<PUTIL>=ILPTR;  #MUST BE ABLE TO REF WD CT 
                         AND LINK ITEMS IN SAVE TABLE#
          ILPTR = LOC(CODEBUF) + SLINK[0];
          IF POP THEN BEGIN OUTIL; END #RESTORE IF APPROPRIATE# 
          RSPACE(TEMP); 
                         #HAVE WE REACHED END OF CHAIN# 
                IF LSTR[N] NQ TEMP THEN 
                  BEGIN 
                TEMP = ILPTR - LOC(CODEBUF);
                GOTO RESTR2;
                  END 
              # WE HAVE REACHED THE END OF THE CHAIN #
         P<PUTIL>=LOC(IL);             #SET UP FOR PUT NEXT TIME# 
          ILPTR=WDSS[0];
RESTRF:   SAVWRD[N]=0;
          LINK[N]=NAVL; 
               NAVL=N; #SET NEXT AVAILABLE TO RESTORED ENTRY# 
               RETURN;
  
                   #SITUATION HERE IS: RESTORE WITHIN A SAVE# 
  
 RESTRS:  
      TEMP=LSTR[WD[WDPTR]];  #POINTER TO LAST BLOCK OF CURRENT (= LAST #
                             #OPENED) BLOCK                            #
          P<PUTIL> = LOC(CODEBUF) + TEMP; 
  
#     LINK "RESTORED" BUFFER TO "CURRENT" BUFFER BY SETTING THE SLINK  #
#     FIELD (POINTER TO NEXT BLOCK) OF LAST BLOCK OF "CURRENT" BUFFER  #
#     TO POINT TO FIRST BLOCK OF "RESTORED" BUFFER                     #
#     ALSO SET LSTR FIELD(POINTER TO LAST BLOCK OF BUFFER) OF "CURRENT"#
#     CODE BUFFER TO POINT TO LAST BLOCK OF "RESTORED" BUFFER          #
  
          SLINK[0]=LINK[N]; 
                LSTR[WD[WDPTR]]=LSTR[N];
  
#     SET PUTIL POINTER TO LAST BLOCK OF "CURRENT" BUFFER (WHICH = LAST#
#     BLOCK OF "RESTORED" BUFFER)                                      #
  
          TEMP=LSTR[N]; 
      P<PUTIL> = LOC(CODEBUF) + TEMP; 
      ILPTR = WDSS[0];       #PUTIL INDEX = NO WORDS ALREADY IN BLOCK  #
               GOTO RESTRF; 
      END 
      CONTROL EJECT;
      ENTRY PROC OSAV(N); 
  
#     OSAV - REOPEN A CLOSED BUFFER                                    #
  
#     REOPENS AN OLD BUFFER MAINTAINING THE BUFFER NUMBER (AS OPPOSED  #
#     TO RESTR WHICH APPENDS THE OLD BUFFER TO THE CURRENT OPEN ONE AND#
#     "LOSES" THE BUFFER NUMBER                                        #
  
  
##       $BEGIN 
          IF DEBFLG NQ 0 THEN 
               BEGIN
          PRINT ("(10H    REOPEN I3)"); 
               LIST(N); 
               ENDL;
               END
##       $END 
##       IF SOPEN[N] THEN  # IN USE # 
         SYMABT(J811,"OSAV ON CURRENT SAVE BUFFER (OSAV IN CODE) ",42);  CODE 
##       IF NOT SFULL[N] THEN  # SLOT VOID (EMPTY) #
         SYMABT(J812,"OSAV ON NON-EXTANT SAVE BUFFER (OSAV IN CODE)",    CODE 
                45);                                                     CODE 
      WDSS[0] = ILPTR;       #SAVE NO WORDS IN CURRENT BLOCK           #
      TMAX = BLKSIZ;         #MAX NO WORDS TO PUT IN BLOCK             #
  
#     MAKE A NEW ENTRY IN THE WDT FOR THE "REOPENED" BUFFER            #
  
      WDPTR = WDPTR + 1;     #BUMP INDEX INTO WDT                      #
##       IF WDPTR GR WMAX THEN  #CANTWINTHEMALL#
         SYMABT(J813,"WHATS DOING TABLE OVERFLOW (OSAV IN CODE)",41);    CODE 
      WD[WDPTR] = N;
          SOPEN[N]=TRUE;
  
#     SET PUTIL POINTER TO LAST BLOCK OF REOPENED BUFFER               #
  
      P<PUTIL> = LOC(CODEBUF) + LSTR[N];
      ILPTR = WDSS[0];       #COUNT OF WORDS IN BLOCK= NO WORDS ALREADY#
          RETURN; 
      CONTROL EJECT;
      ENTRY PROC VALID(N);
  
#     VALID - VALIDATE A CODE BUFFER (SO IT WON"T BE CLEARED BY CODCLR #
  
  
      $BEGIN
      IF DEBFLG NQ 0 THEN 
          BEGIN 
          PRINT ("(13H    VALID N= I5)"); 
          LIST(N);
          ENDL; 
          END 
      $END
  
          IF SFULL[N]THEN SVALID[N]=TRUE; 
          RETURN; 
      CONTROL EJECT;
      ENTRY PROC CODCLR;
  
#     CODCLR - WIPE OUT THE GARBAGE                                    #
  
#     CALLED PERIODICALLY (USUALLY ONCE PER STATEMENT) TO HOUSEKEEP    #
#     FORGOTTEN AND USELESS CODE                                       #
  
  
ITEM CLR,OLDHI; 
          WDSS[0]=ILPTR;
          OLDHI=HIGSAV; 
          HIGSAV=0; 
          POP=FALSE;
  
#     STEP THROUGH THE CODE CONTROL TABEL DESTROYING ALL UNVALIDATED   #
#     BUFFERS                                                          #
  
          FOR CLR=OLDHI STEP -1 UNTIL 1 DO
               BEGIN
               IF NOT SFULL[CLR]THEN TEST CLR;
               IF SVALID[CLR] THEN
                    BEGIN 
                    IF HIGSAV EQ 0 THEN HIGSAV=CLR; 
                    TEST CLR; 
                    END 
               SOPEN[CLR]=FALSE;
               ZAP(CLR);
               END
          WDPTR=0;
          GOTO ENDS33;
      CONTROL EJECT;
ENTRY PROC CODINT;
  
#     CODINT - INITIALIZE DATA USED BY CODE SUBROUTINES                #
  
  
      CONTROL FASTLOOP; 
  
  
#     INITIALIZE LINK FIELD OF ALL ENTRIES IN CODE CONTROL TABLE       #
  
          FOR I = 1 STEP 1 UNTIL SMAX - 1 DO
             LINK[I]=I+1; 
             LINK[SMAX]=0;
  
#     INITIALIZE NAVL TO POINT TO FIRST ENTRY IN CODE CONTROL TABLE    #
  
         NAVL=1;
  
#     SET PUTIL POINTER SO POPN AND POPR CALLS WILL GO DIRECTLY TO IL  #
#     BEFORE THE FIRST CSAV CALL                                       #
  
         P<PUTIL>=LOC(IL);
         WD[0]=-1;
         TMAX=ILUP; 
          HIGSAV=0; 
          ILPTR=0;
         WDPTR=0; 
          RETURN; 
  
  
      CONTROL SLOWLOOP; 
      CONTROL EJECT;
ENTRY PROC FLUSH; 
  
#     FLUSH - FLUSH IL BUFFER TO FILE                                  #
  
  
  
  
          IF WDPTR NQ 0 THEN
               BEGIN
               P<PUTIL>=LOC(IL);
               ILPTR=WDSS[0]; 
               WDPTR=0; 
               END
          WDSS[0]=ILPTR;
          OUTIL;
          ILPTR=0;
          RETURN; 
     END
TERM
