*DECK             ALOCTR
USETEXT   TSOURCE 
USETEXT   TSYMCNS 
USETEXT   TCEXECQ 
USETEXT   TCEXEC
USETEXT   TCOM39Q 
 PROC ALOCTR; 
      BEGIN 
  
      XREF  BEGIN 
               PROC MERR$;
               PROC PNAM; 
               PROC SPOST;
               PROC SOVER;
               PROC FIND; 
               PROC TSPACE; 
               PROC RSPACE; 
               PROC GTPST;
               PROC PTCFL;
               PROC PTLSTV; 
               PROC SYMABT;                                              ALOCTR 
            END  #XREF# 
  
  
  
  
*CALL COMEX 
  
         DEF FSTSZ #17#; #FILE STATUS TABLE SIZE# 
         DEF  WDSIZ #60#;  #WORD SIZE#
         DEF  BYSIZ #6#;   #MACHINE BYTE SIZE#
         DEF BYPWD #10#; #BYTES/WORD# 
         DEF CWSZ #60#;  #COMPIL WORD SIZE# 
         DEF CBPW #10#;  #COMPIL BYTES/WORD#
         DEF TWP2SZ #0#; #WDSIZ-CWSZ# 
         DEF TWPSZF #60#;#CWSZ-TWP2SZ#
        DEF  AITMAX #2500#;  #MAX ARRAY ITEM PRESET SIZE# 
         DEF ARYMAX #6000#; #MAX NO ARRAY WORDS THAT CAN BE PRESET# 
         DEF OCCSZ #100#;  #SIZE OF OCCUPY=ARYMAX/CWSZ# 
         DEF MAXPOP #1#; #MAX.PRESET OUTPUT CHUNCKS-MUST BE 1 ON COMM#
         DEF  MAXNAI #100#; #MAX.NO.OF ARRAY ITEMS# 
         DEF OBUFSZ #100#;   #OUTPUT BUFFER SIZE# 
        DEF MAXPSO #(OBUFSZ-2)/BYPWD#;  #MAX.PRESET OUTPUT# 
        DEF PSOBPW #CWSZ/BYSIZ#; #PRESET OUTPUT BYTES/WORD# 
         DEF MAXCPS #120#;  #MAX SIZE CHARACTER PRESET# 
         DEF MAXGET #200#;  #CRADLE BLOCKING SIZE#
         DEF MAXDIM #100#;#MAX.NO.OF DIMENSIONS#
         DEF TILN #12#; #TITLE LENGTH FOR CDUMP#
         DEF CFEHSZ #1#; #CODE FILE ENTRY HEADER SIZE#
         DEF OVPTR1 #OVSEQ#;
         DEF OVPTR2 #OVLEG#;
##       DEF FILECHAR #O"60"#; #O"60" IS AN EQUIV CHAR# 
  
         DEF TRACE$IO   #B<29>INTOPS EQ 1#; #3 OPTION -- IO DUMPS      #
         DEF TRACE$DBUG #B<28>INTOPS EQ 1#; #2 OPTION -- INTERNAL TRACE#
         DEF TRACE$ROUT #B<27>INTOPS EQ 1#; #1 OPTION -- ROUTINE TRACE #
         DEF IO$BIT     #B<29>INTOPS     #; #3 OPTION -- BIT ACCESS    #
  
         DEF J803 #803#;           # SYMABT DIAGNOSTIC 803             # ALOCTR 
         DEF J804 #804#;           # SYMABT DIAGNOSTIC 804             # ALOCTR 
                                                                         ALOCTR 
         ITEM PIBDTI C(TILN)=" PRESET IBUF  ";
         ITEM  POBDTI C(TILN) = " PRESET OBUF  "; 
         ITEM SUBVTI C(TILN)=" SUBVEC  "; 
         ITEM ISAPTI C(TILN)=" ISAP  "; 
         ITEM AITPTI C(TILN)=" AITOP  ";
         ITEM OCCTI  C(TILN)=" OCCUPY  "; 
         ITEM STATI  C(TILN)=" STAGE  ";
         ITEM DPAKTI C(TILN)=" DPAKTB"; 
         ITEM OVRTI C(TILN) = "COM05";
  
         ITEM  DLCTR I, #DATA LOCATION COUNTER# 
               TLCTR I, #TABLE LOCATION COUNTER#
               INDX  I, #POINTER TO SYMBOL TABLE ENTRIES# 
               TCLAS I, #CLAS[INDX]#
               SLNK  I, #LINK THROUGH SLC#
               XTYP  I, #TYPE[INDX]#
               TMPX  I, #TEMP#
               TMPY  I, #TEMP#
               TMP1  I, #TEMP#
               TMP2  I, #TEMP#
               TMP3  I, 
               OLNK  I, #OLD LINK - LINK TO TABLE SYMBOL TABLE ENTRY# 
               DIM  I,  #TTYP[OLNK]#
               LINK I,  #INDX TO HEAD OF ITEM CHAIN#
               WCNT  I,  #WORD COUNT# 
               TMP   I;  #TEMP# 
         ITEM  SRGIX I;  #STRING INDEX FOR DMY SYMBOL TABLE ENTRY#
         ITEM  BDWRD I;  #BEAD WORD-JOV.PRESETS#
         ITEM  WDBDN I;  #WORD BEAD NUMBER-JOV PRESETS# 
         ITEM BOOL B; 
         ITEM NEWNAM C(10); 
         ITEM STIX I;      #SYMBOL TABLE INDEX-USED FOR JOVIAL PRESETS# 
         ITEM NBME I=0;    #NO.OFBEGINS MINUS ENDS-JOVIAL ARRAY PRES# 
         ITEM DPAK B; #TRUE IF DENSE PACKING# 
  
         ARRAY SUBVEC [1:MAXDIM];  ITEM SUBS; #SUBSCRIPT VECTOR#
         ITEM CUR I; #SUBVEC ITEM INDEX#
         ITEM OFFSET I; #PRESET LOCATION# 
  
    #DATA FOR JOPSET# 
         ITEM  I I, 
               J I, 
               K I; 
         ITEM  L,L1;
         ITEM  I1,I2; 
         ITEM INDXX U = 0; #INDEX TO S.T.BEG.-SAPP,STAOUT,JOPSET# 
         ITEM  INDX1 I; 
         ITEM  PSOI  I; 
         ITEM RBLSZ I;# READ BLOCK SIZE--SET BY GTPST # 
         ITEM FILL I=0; 
  
         STATUS QPETY SIMPLE,BEGIN,ITEM,END,LBRACK,RBRACK,
                      LPAREN,RPAREN,EMPTY,CONST;
  
         ARRAY PSIBUF[1:AITMAX];
     BEGIN
         ITEM PETY S:QPETY (0,0,18),
                   PEVL I  (0,18,18), 
                   PELN I  (0,42,18), 
                   PEDA C  (0,0,10);
         ITEM STP   I   (0,0,60); 
         ITEM NOBEG I   (0,0,18); 
         ITEM NOEND I   (0,18,18);
         ITEM NOCON I   (0,42,18);
         ITEM PCON      (0,0,60); 
     END
         ARRAY PSOBUF[0:OBUFSZ] S(1);  #PRESET OUTPUT BUFFER# 
         BEGIN
           ITEM CFOP S:QCFOP (0,0,12);
           ITEM CFWC U (0,12,6);  #NO. OF WORDS OF DATA#
           ITEM CFST U (0,18,18);   #SYMBOL TABLE INDEX#
           ITEM CFRA U (0,36,24); #RELATIVE ADDRESS#
           ITEM CFD  I  (1,0,60);  #DATA# 
           ITEM CFDMY C(0,0,10);
         END
         BASED ARRAY PSIB[0:0];;
      ARRAY STAGE[ARYMAX] S(1); 
           ITEM STAGE1 I(0,0,CWSZ); 
         ARRAY OCCUPY [0:OCCSZ];
           ITEM OCC;
         ITEM OCCX I; #INDEX TO OCCUPY VECTOR#
         ITEM OCCB I; #BIT POSITION IN OCCUPY WORD# 
               ITEM NOBIT I, #NUMBER OF BITS# 
                    FIBIT I; #FIRST BIT#
               ITEM FBIT1 I , 
                    FBIT2 I;
               ITEM NXBIT I;
         SWITCH SLCSWT:QESDC
                SLCPR2:NULL,
                SLCPR2:LITL,
                SLCPR2:FILE,
                SLCPR2:CODE,
                DATSLC:DATA,
                SLCPR2:ADCN,
      DATSL1: COMM, 
                SLCPR2:CMPL,
                DATSL1:XTRN;
  
$BEGIN                                                                   ALOCTR/
#DEBUG#  CONTROL IFNQ SYMTBLV,0;
XREF ITEM SYMTAB; 
PRINT("(10H **DEBUG**, /, 14H FIELD LENGTH= O6,/,19H UNUSED FREE SPACE= 
     O6, /, 17H START OF SYMTAB= O6, /, 12H SYMTAB CAP= O6, /,
     17H CURRENT ST LOCN= O6, /, 5H HHA= O6 )");
LIST(FREEMAX); LIST(SYMSTART); LIST(SYMCP);                              ALOCTR/
LIST(NXTAV);  LIST(SYMTAB);  ENDL;
#DEBUG#  CONTROL ENDIF; 
$END                                                                     ALOCTR/
  
         CFOP[0]=S"PRSF"; 
         PSOI=1;
ALOC0:  
         SLNK = SPLC; 
SLCPR1: 
         IF SLNK EQ 0 
         THEN 
           BEGIN
           GOTO PRESET; 
           END
         INDX = BABY[SLNK]; 
         GOTO SLCSWT[ESDC[SLNK]]; 
DATSLC: 
 DATSL1: DLCTR=0; 
 DATSL2:  
  REPEAT:IF INDX NQ 0 THEN
         BEGIN
           IF ESDC[SLNK] EQ S"XTRN" 
           THEN 
             BEGIN
             DLCTR = 0;            # INIT DLCTR IF XTRN                #
             END
           TCLAS=CLAS[INDX];
           IF TCLAS EQ QCLAS"DATA"
           THEN DATA; #SIMPLE ITEM ALLOCATION#
           ELSE IF TCLAS EQ QCLAS"TABL" THEN TABLE; #TABLE ALLOCATION#
         ELSE IF FPRI[INDX] EQ S"NAMC" THEN 
              BEGIN 
                LOCN[INDX]=DLCTR; 
                DLCTR=DLCTR+1;
              END 
  LOOP:    INDX=ASEQ[INDX]; 
           GOTO REPEAT; 
         END
         SSIZ[SLNK] = DLCTR;
         DLCTR=0; 
  SLCPR2: 
         SLNK = ASEQ[SLNK]; 
         IF ESDC[SLNK] EQ S"FILE" 
         THEN 
           BEGIN
           SLNK = ASEQ[SLNK]; 
           END
         GOTO SLCPR1; 
CONTROL EJECT;
  
 PRESET:  #PROCESS PRESET#
         $BEGIN 
         IF TRACE$IO THEN 
           SDUMP(4);               # DUMP THE SYMBOL TABLE             #
         $END 
         #CLEAR CODE FILE OUTPUT BUFFER#
         FOR I=0 STEP 1 UNTIL OCCSZ DO
           OCC[I]=0;
          SYPSET; 
         RETURN;
CONTROL EJECT;
 PROC DATA;   #SIMPLE ITEM STORAGE ALLOCATION#
                                        #THIS ROUTINE IS USED TO ALLO- #
                                        # CATE STORAGE FOR SIMPLE      #
                                        # ITEMS.                       #
      BEGIN 
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC DATA   ENTERED  )"); 
           ENDL;
         END
        $END
         XTYP=TYPE[INDX]; #SIMPLE ITEM TYPE#
         IF XTYP EQ QTYPE"HLTH" OR XTYP EQ QTYPE"TRAN"
         OR XTYP EQ QTYPE"EBCD" THEN #COMPUTE NO.OF WORDS#
         BEGIN
            TMPX=NBYT[INDX]; #NO.OF BYTES#
            TMPY=(TMPX+BYPWD-1)/BYPWD;
            IF TMPY GR 1 OR XTYP  EQ QTYPE"EBCD" THEN FBIT[INDX]=0; 
            ELSE FBIT[INDX]=WDSIZ-NBYT[INDX]*BYSIZ; 
         END ELSE 
         BEGIN
            FBIT[INDX]=WDSIZ-NBIT[INDX]; #SET FIRST BIT IND.# 
            TMPY=1; 
         END
       IF FPRI[INDX] NQ S"NAMC" THEN
         BEGIN
         LOCN[INDX]=DLCTR;
         DLCTR=DLCTR+TMPY;
         END
        ELSE BEGIN   # FORMAL PARM - ONLY ALLOC ONE WORD #
                LOCN[INDX]=DLCTR; 
                DLCTR=DLCTR+1;
            END 
         IF TMPY EQ 0 THEN RETURN;
         ARRAY CONS55[25];
           ITEM CONS55A U(0,0,30)=[25(O"5555555555")],
                CONS55B U(0,30,30)=[25(O"5555555555")]; 
         ARRAY CONS05[25];
           ITEM CONS05A U(0,0,30)=[25(O"0505050505")],
                CONS05B U(0,30,30)=[25(O"0505050505")]; 
       IF XTYP EQ QTYPE"HLTH" THEN PUTPS(TMPY,LOCN[INDX], 
                                   CONS55   ,INDX); 
              ELSE
       IF XTYP EQ QTYPE"TRAN" THEN PUTPS(TMPY,LOCN[INDX], 
                                      CONS05,INDX); 
      END #DATA#
CONTROL EJECT;
 PROC TABLE;  #TABLE ALLOCATION#
                                        #ROUTINE TABLE IS CALLED TO    #
                                        # ALLOCATE STORAGE FOR THE     #
                                        # ITEMS OF A JOVIAL TABLE OR A #
                                        # SYMPL ARRAY. FOR FORMAL      #
                                        # PARAMETERS AND SYMPL-BASED   #
                                        # ARRAYS, THE TABLE ITEMS ARE  #
                                        # ALLOCATED RELATIVE TO THE    #
                                        # BEGINNING OF THE TABLE, WHILE#
                                        # IN OTHER TABLES THE ITEMS ARE#
                                        # ALLOCATED RELATIVE TO THE    #
                                        # START OF THE SLC CHAIN.      #
      BEGIN 
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC TABLE  ENTERED  )"); 
           ENDL;
         END
        $END
         OLNK=INDX; #SAVE LINK# 
         TLCTR=DLCTR;  #TABLE LOCATION COUNTER# 
         DIM=TTYP[OLNK];  #TABLE TYPE#
         IF DIM EQ QTTYP"BASED" THEN DLCTR=0; 
         IF FPRI[OLNK] NQ S"NULL" THEN DLCTR=0; 
          PACK[OLNK] = S"DENSE";
         INDX=BABY[INDX]; #GET 1ST TABLE ITEM#
         IF INDX EQ 0 THEN GOTO TAB9; 
         LINK=INDX;       #SAVE POINTER TO HEAD OF ITEM CHAIN#
  TAB6:  IF PORS[OLNK] THEN MFAC[OLNK]=WENT[OLNK];
         ELSE MFAC[OLNK]=1; 
     TAB8:  
           IF PORS[OLNK] THEN LOCN[INDX]=WDEN[INDX]+DLCTR;
           ELSE LOCN[INDX]=WDEN[INDX]*TENT[OLNK]+DLCTR; 
         MFAC[INDX]=MFAC[OLNK]; 
         PACK[INDX] = S"DENSE"; 
         TAB8A: 
         INDX=ASEQ[INDX]; #GET NEXT ENTRY#
         IF INDX NQ 0 THEN GOTO TAB8;  #LOOP# 
  TAB9: 
         DLCTR=TLCTR; 
         INDX=OLNK; 
             LOCN[INDX]=DLCTR;
         IF FPRI[OLNK] EQ S"NAMC" OR DIM EQ QTTYP"BASED"
              THEN DLCTR=DLCTR+1; 
             ELSE 
             DLCTR=DLCTR+WENT[OLNK]*TENT[OLNK]; 
         RETURN;
      END #PROC TABLE#
CONTROL EJECT;
 PROC SYPSET; #SYMPL PRESET PROCESSING# 
                                        #SYPSET IS CALLED BY ALOCTR    #
                                        # AFTER THE ALLOCATION OF      #
                                        # STORAGE IS COMPLETE FOR A    #
                                        # SYMPL COMPILATION. SYPSET    #
                                        # INITIALIZES THE CODE FILE    #
                                        # AND BUILDS CODE FILE ENTRIES #
                                        # FOR ANY PRESETS.             #
      BEGIN 
         BASED ARRAY CONPT[0];; 
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC SYPSET ENTERED  )"); 
           ENDL;
         END
         IF TRACE$DBUG THEN 
           BEGIN
           IO$BIT = 1;             # FORCE THE IO DUMP TRACE ON        #
           END
        $END
         INDX1=0; #INITIALIZE INDX1 TO INDICATE FIRST GETPS CALL# 
 PRE4:   GETPS; #GET A PRESET#
         IF INDX NQ 0 THEN  #IF A PRESET WAS FOUND# 
         BEGIN
           IF PETY[INDX] EQ QPETY"BEGIN" THEN SAPP; #SYM ARRAY P.PROC#
           ELSE IF PETY[INDX] EQ S"END" THEN GOTO PRE4; 
           ELSE 
           BEGIN
             IF TYPE[PELN[INDX]] EQ S"EBCD" 
             THEN TMP1=(NBYT[PELN[INDX]]+BYPWD-1)/BYPWD;
             ELSE TMP1=1; 
             P<CONPT> = LOC(PSIBUF[INDX+1]);
             PUTPS(TMP1,LOCN[PELN[INDX]],CONPT,PELN[INDX]); 
           END
           GOTO PRE4; 
         END
         CFOP[PSOI]=QCFOP"TERM";
        $BEGIN
         IF TRACE$IO THEN 
         CDUMP(LOC(PSOBUF),PSOI+1,POBDTI);
        $END
         PTCFL(PSOBUF,PSOI+1);    # WRITE REM.OF CODE FILE# 
     END #SYPSET# 
CONTROL EJECT;
 PROC SAPP;   #SYMPL ARRAY PRESET PROCESSING# 
              #ON ENTRY INDX=INDEX OF BEGIN IN PRESET TABLE#
                                        #SAPP IS CALLED BY SYPSET TO   #
                                        # BUILD A COPY OF THE ARRAY    #
                                        # BEING PRESET AND THEN TO     #
                                        # BUILD CODE FILE ENTRIES FOR  #
                                        # THE WORDS OF THE ARRAY       #
                                        # ACTUALLY PRESET.             #
      BEGIN 
         DEF  PTESZ    #1#;    #PRESET TABLE ENTRY SIZE#
         ITEM ADR I; #ADDRESS OF PRESET#
         ITEM MERGE B; #TRUE INDICATES MORE THAN ONE PRESET#
         ITEM  IT B=FALSE; #USED TO INDICATE ARRAY ITEM PROCESSED#
         SWITCH PREP2:QPETY  #PRESET PASS2 SWITCH#
                  SAP20:BEGIN,
                  SAP21:ITEM, 
                SAP60:END,
                  SAP24:LBRACK, 
                  SAP26:RBRACK, 
                  SAP28:EMPTY,
                  SAP34:CONST,
                  SAP30:LPAREN, 
                  SAP32:RPAREN; 
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC SAPP   ENTERED  )"); 
           ENDL;
         END
        $END
 SAP20:  #PASS 2 OF SYMPL ARRAY PRESET PROCESSING#
         IT=FALSE;
         INDXX=PELN[INDX];
         LINK=INDX+PTESZ; 
  SAP21: #ITEM# 
         IF IT THEN 
         BEGIN
           GETPS; 
           IF  PETY[INDX] EQ S"END"                                      NOV04
           THEN                                                          NOV04
             BEGIN                                                       NOV04
             GOTO SAP60;           # ERROR ON LAST ITEMS PRESET- IGNORE# NOV04
             END                                                         NOV04
                                                                         NOV04
           LINK=INDX; 
         END
         ELSE IT = TRUE;
         CUR=0; 
         TMP=LINK;
 SAP22:  LINK=LINK+PTESZ; 
         IF LINK GR RBLSZ THEN
         BEGIN
           GETPS; 
           IF  INDX EQ 0                                                 NOV04
           THEN                                                          NOV04
             BEGIN                                                       NOV04
             GOTO SAP60;           # EARLY EOF . . . GO AWAY           # NOV04
             END                                                         NOV04
                                                                         NOV04
           IT=FALSE;
           LINK=INDX; 
         END
         GOTO PREP2[PETY[LINK]];
 SAP24:  # [ #
         PEVL[PELN[LINK]]=PEVL[LINK]; #TRANSFER COUNT TO ]# 
 SAP25:  CUR=CUR+1; #MOVE CURSOR RIGHT# 
         SUBS[CUR]=0; 
         GOTO SAP22;
 SAP26:  PEVL[LINK]=PEVL[LINK]-1;  #DECREMENT COUNT#
         CUR=CUR-1; 
         IF CUR GR 0 THEN SUBS[CUR]=SUBS[CUR]+1;
         IF PEVL[LINK] EQ 0 THEN GOTO SAP22;
         LINK=PELN[LINK]; #GOTO [ PROCESSING# 
         GOTO SAP25;
 SAP28:  #EMPTY#
         SUBS[CUR]=SUBS[CUR]+PEVL[LINK];
         GOTO SAP22;
  
SAP30:   # (                                                           #
         IF  PEVL[LINK] EQ 0       # ZERO REP COUNT                    #
         THEN 
           BEGIN
           LINK = PELN[LINK];      # SKIP TO RIGHT PAREN               #
           GOTO SAP22;
           END
         PEVL[PELN[LINK]] = PEVL[LINK];  # MOVE REP CNT TO MATCHING )  #
         GOTO SAP22;
  
SAP32:   # )                                                           #
         PEVL[LINK] = PEVL[LINK] - 1;  # DECREMENT REP COUNT           #
         IF  PEVL[LINK] LQ 0
         THEN 
           BEGIN
           GOTO SAP22;
           END
         LINK = PELN[LINK];        # SKIP TO MATCHING (                #
         GOTO SAP22;
 SAP34:  # CONST #
         FOR I=1 STEP 1 UNTIL PELN[LINK] DO 
         BEGIN
           # PUT OUT THE PRESET CONSTANT #
           # SUBVEC IS SUBSCRIPT VECTOR READ RIGHT TO LEFT# 
        $BEGIN
           IF TRACE$DBUG THEN 
           CDUMP(LOC(SUBVEC),CUR,SUBVTI); 
        $END
           # LINK LINKS TO CONST PETY AND MAY NOT BE CHANGED #
           #INDXX LINKS TO BEGIN IN ST# 
           # TMP LINKX TO ITEM PETY # 
           OFFSET=0;
           TMP1=SBSC[INDXX];
           IF PORS[INDXX] THEN TMP3=WENT[INDXX];
           ELSE TMP3=1; 
           FOR J=1 STEP 1 UNTIL NDIM[INDXX] DO
           BEGIN
              IF DMPY[TMP1] NQ 0
              THEN BEGIN
                    FIND(DMPY[TMP1],TMP2);
                    TMP2=CONS[TMP2];
                   END
              ELSE  TMP2=1; 
              OFFSET=OFFSET+SUBS[NDIM[INDXX]+1-J]*TMP2; 
              TMP1=BPLK[TMP1];
           END
           #SET PRESET IN STAGE#
           P<PSIB>=LOC(PSIBUF[LINK+I]); 
           PSET(LOCN[PELN[TMP]]+OFFSET*TMP3,PELN[TMP],PSIB);
           IF TYPE[PELN[TMP]] EQ S"EBCD"
             THEN I=I-1+PELN[LINK]/PEVL[LINK];
           SUBS[CUR]=SUBS[CUR]+1; 
         END
         LINK=LINK+PELN[LINK];
         GOTO SAP22;
  
  SAP60: #END#
         STAOUT;
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(12H SAPP RETURN)"); 
           ENDL;
         END
        $END
         RETURN;
         END  #SAPP#
CONTROL EJECT;
 PROC PSET( ADDR, (SYTB) , CON) ;           #SET PRESET IN STAGE# 
                                        #PSET IS CALLED BY SAPP AND    #
                                        # JOPSET TO MOVE A CONSTANT    #
                                        # FROM THE PRESET FILE TO THE  #
                                        # APPROPRIATE PLACE IN STAGE.  #
     BEGIN
         ITEM ADDR I; #TRG.MACH.PRESET ADDRESS# 
         ITEM SYTB I; #INDEX TO SYMBOL TABLE ENTRY# 
         ARRAY CON [0:0];  #CONSTANT IN COMP. FORMAT# 
           ITEM CON1; 
         ITEM RADR I; #RELATIVE ADDRESS#
         ITEM RADR1;
         ITEM WF I;   #INDEX OF WORD FROM#
         ITEM BF I; #INDEX OF BIT FROM# 
         ITEM  STP I; 
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC PSET   ENTERED  )"); 
           ENDL;
         END
         IF TRACE$DBUG THEN 
         BEGIN
           PRINT("(11H PSET ADDR=,O6,6H SYTB=,O6,8H CON[0]=,O20,
                             8H CON[1]=,O20)"); 
           LIST (ADDR); 
           LIST (SYTB); 
           LIST(CON1[0]); 
           LIST(CON1[1]); 
           ENDL;
         END
        $END
         L=1; #NO. OF TARGET WORDS# 
         STP=1;    # NUMBER OF WORDS BETWEEN PRESET WORDS # 
         IF CLAS[SYTB] EQ S"ARRY"THEN 
         BEGIN
           RADR1=ADDR-LOCN[SYTB]; 
           IF TYPE[SYTB] EQ S"BOOL"THEN 
           BEGIN
             NOBIT=1; 
             TMP=DDEL[SBSC[SYTB]];
             ADDR=RADR1/TMP;
             FIBIT=RADR1-ADDR*TMP;
             RADR1=ADDR;
        $BEGIN
             IF TRACE$DBUG THEN 
             BEGIN
               PRINT("(22H PSET ADDR CHANGED TO ,O6)"); 
               LIST(ADDR);
               ENDL;
             END
        $END
             GOTO PSE10;
           END
         END
         IF TYPE[SYTB] EQ S"EBCD" THEN
         BEGIN
              IF (CLAS[SYTB] EQ S"TITM" OR CLAS[SYTB] EQ S"STRG") 
                   AND  NOT PORS[MAMA[SYTB]] THEN 
                                 STP=TENT[MAMA[SYTB]];
          IF CLAS[SYTB] EQ S"TABL" AND NOT PORS[SYTB] THEN               PSRSIAA
             STP = TENT[SYTB];                                           PSRSIAA
             NOBIT=NBYT[SYTB]*BYSIZ;
             FIBIT=FBIT[SYTB];
             L=(NBYT[SYTB]+BYPWD-1)/BYPWD;
             BF = 0;                                                     PSRSIAA
             IF FIBIT NQ 0 AND FIBIT+NOBIT GR WDSIZ THEN L=L+1; 
          L=L*STP;
           WF=0;
         END
         ELSE 
         BEGIN
                  NOBIT=NBIT[SYTB]; 
                  FIBIT=FBIT[SYTB]; 
 PSE10:    BF=WDSIZ-NOBIT;
           IF BF GQ CWSZ THEN 
           BEGIN
             BF=BF-CWSZ;
             WF=1;
           END
           ELSE WF=0; 
         END
 PSE20: 
         IF CLAS[SYTB] NQ S"ARRY" THEN
         RADR1=ADDR-LOCN[MAMA[SYTB]]; 
         IF RADR1 + L GR ARYMAX THEN
            BEGIN                                                        ALOCTR 
            SYMABT(J803,"ARRAY PRESET EXCEEDS MAXIMUM SIZE(PSET IN ALOCT ALOCTR 
R)",49);                                                                 ALOCTR 
            END                                                          ALOCTR 
         FBIT2=FIBIT; 
         FOR RADR=RADR1 STEP STP UNTIL RADR1+L-STP DO 
         BEGIN
           OCCX=RADR/CWSZ;
           OCCB=RADR-OCCX*CWSZ; 
        $BEGIN
           IF TRACE$DBUG THEN 
           BEGIN
             PRINT ("(2X,6H RADR=,O6,6H OCCX=,O6,6H OCCB=,O6)");
             LIST (RADR); 
             LIST (OCCX); 
             LIST (OCCB); 
             ENDL;
           END
        $END
           IF B<OCCB> OCC[OCCX] EQ 0 THEN 
           BEGIN
             B<OCCB> OCC[OCCX] = 1; 
             STAGE1[RADR]=0;
           END
             IF L GR STP THEN 
           IF RADR EQ RADR1 THEN NOBIT=WDSIZ-FIBIT; 
           ELSE IF RADR LS RADR1+L-STP THEN NOBIT=WDSIZ;
           ELSE NOBIT=NBYT[SYTB]*BYSIZ+FIBIT+WDSIZ-(L/STP)*WDSIZ; 
         $BEGIN 
           IF TRACE$DBUG THEN 
           BEGIN
             PRINT("(4H WF=,O20,10H CON1[WF]=,O20)"); 
             LIST (WF); 
             LIST (CON1[WF]); 
             ENDL;
             PRINT("(4H BF=,O20,7H NOBIT=,O20,7H FBIT2=,O20)"); 
             LIST(BF);
             LIST(NOBIT); 
             LIST(FBIT2); 
             ENDL;
           END
        $END
           FOR K=0 STEP 1 UNTIL NOBIT-1 DO
           BEGIN
           B<FBIT2+K>STAGE1[RADR]=B<BF>CON1[WF];
             IF BF LS CWSZ-1 THEN  BF=BF+1; 
             ELSE BEGIN 
                   WF=WF+1; 
                   BF=0;
                 END
           END
         $BEGIN                                                          PSRSIAA
           IF TRACE$DBUG THEN 
           BEGIN
             PRINT("(6H RADR=,O20,14H STAGE1[RADR]=,O20)"); 
           LIST (RADR); 
           LIST (STAGE1[RADR]); 
             ENDL;
           END
        $END
           FBIT2=0; 
         END #FOR#
     END #PROC PSET#
CONTROL EJECT;
   PROC STAOUT;  #OUTPUT STAGE WORDS# 
                                        #STAOUT IS CALLED BY SAPP AND  #
                                        # JOPSET TO OUTPUT THE STAGE   #
                                        # WORDS ACTUALLY PRESET.       #
     BEGIN
         ITEM NN; 
         ITEM WD; 
         ITEM BT; 
         ITEM BDS;
         ITEM J;
         BASED ARRAY STAG[0:0]; 
           ITEM STAGI;
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC STAOUT ENTERED  )"); 
           ENDL;
         END
         IF TRACE$DBUG THEN 
         BEGIN
           CDUMP(LOC(OCCUPY),OCCSZ,OCCTI);
           CDUMP(LOC(STAGE),ARYMAX,STATI);
         END
        $END
         NN=0;
         FOR WD=0 STEP 1 UNTIL OCCSZ DO 
         BEGIN
           FOR BT=0 STEP 1 UNTIL CWSZ-1 DO
           BEGIN
             IF B<BT,1> OCC[WD] EQ 1 THEN 
             BEGIN
               NN=NN+1; 
               IF NN EQ MAXPOP THEN GOTO STA10; 
             END
             ELSE 
             IF NN NQ 0 THEN
 STA10:      BEGIN
               P<STAG>=LOC(STAGE[WD*CWSZ+BT]);
               PUTPS(NN,LOCN[INDXX]+WD*CWSZ+BT,STAG,INDXX); 
        $BEGIN
               IF TRACE$DBUG THEN 
               BEGIN
                 PRINT("(2X,3HWD=,O12,4H BT=,O12)");
                 LIST (WD); 
                 LIST (BT); 
                 ENDL;
               END
        $END
               NN=0;
             END
           END #FOR LOOP# 
         END  #FOR  LOOP# 
         IF NN NQ 0 THEN
         BEGIN
           P<STAG>=LOC(STAGE[WD*CWSZ+BT]);
           PUTPS(NN,LOCN[INDXX]+WD*CWSZ+BT,STAG,INDXX); 
           NN=0;
         END
         FOR J=0 STEP 1 UNTIL OCCSZ DO
           OCC[J]=0;
         RETURN;
     END #PROC STAOUT#
CONTROL EJECT;
 PROC GETPS;  #GET NEXT SYMPL PRESET# 
              #READ PRESET FILE IF NECESSARY# 
              #INDX=0 OR INDEX   OF PRESET ON EXIT# 
              #INDX1=0 IF FIRST CALL ON ENTRY#
                                        #GETPS IS CALLED BY SYPSET AND #
                                        # SAPP TO GET A SYMPL PRESET,  #
                                        # WHERE A SYMPL PRESET IS      #
                                        # EITHER A SIMPLE DATA PRESET  #
                                        # OR THE ENTIRE PRESET FOR AN  #
                                        # ITEM OF A SYMPL ARRAY. FOR   #
                                        # SYMPL ARRAY ITEMS GETPS ALSO #
                                        # LINK THE CORRESPONDING RIGHT #
                                        # AND LEFT PARENTHESES AND     #
                                        # BRACKETS TOGETHER.           #
      BEGIN 
 GET0:  
         ITEM TMP0; 
         ITEM RBLSZ1; 
         BASED ARRAY PSPARM [0:0];
           ITEM PSIPAR; 
         ITEM ITM B=FALSE; #TRUE INDICATES AN ITEM SCAN STARTED#
         ITEM INDX2;
         ITEM I;
  
         SWITCH SCAN:QPETY  #SCAN SYMPL PRESET FOR ENTIRE ITEM# 
                GET11:BEGIN,
                GET12:ITEM, 
                GET11:EMPTY,
               GET16:LBRACK,
                GET16:LPAREN, 
                GET17:RBRACK, 
                GET17:RPAREN, 
                GET17A:CONST, 
                GET18:END;
         SWITCH SCAN1:QPETY 
               GET14:LBRACK,
               GET14:RBRACK,
               GET14:EMPTY, 
               GET14:LPAREN,
               GET14:RPAREN,
               GET13:CONST, 
               GET15:ITEM,
               GET15:END; 
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC GETPS  ENTERED  )"); 
           ENDL;
         END
        $END
  
#          IF THE BUFFER IS EMPTY, WE FILL IT...                      # 
  
 GET1:  
         IF INDX1 EQ 0 OR INDX1 GR RBLSZ THEN 
         BEGIN
           RBLSZ1 = 0;
        $BEGIN
           IF TRACE$ROUT THEN 
           BEGIN
             PRINT("(13H GTPST CALL  )"); 
             ENDL;
           END
        $END
           GTPST(PSIBUF,RBLSZ,GET20); 
##       $BEGIN 
           IF TRACE$ROUT THEN 
           BEGIN
             PRINT("(17H GTPST RETURNED  )"); 
             ENDL;
           END
##       $END 
           INDX1 = 1; 
  
#          WE NOW CHECK FOR SIMPLE ITEM PRESETS                        #
#                                                                      #
  
  GET2:    IF PETY[INDX1] NQ S"BEGIN" AND PETY[INDX1] NQ S"ITEM" THEN 
  GET3:    BEGIN
             INDX=INDX1;
             IF PETY[INDX] EQ S"SIMPLE" THEN
             IF TYPE[PELN[INDX]] EQ QTYPE"EBCD" THEN
             BEGIN
             TMP0=(NBYT[PELN[INDX]]+CBPW-1)/CBPW; 
               INDX1=TMP0+INDX1+1;
             END
             ELSE INDX1=INDX1+2;
             ELSE INDX1=0;
             IF NOT SIND[PELN[INDX]] THEN GOTO GET1;
        $BEGIN
             PIBDMP;
        $END
             RETURN;
           END
  
  
  
  
#         AT THIS POINT, WE SHOULD HAVE AN ARRAY ITEM.  WE SCAN EACH   #
#         ITEM-S PRESETS, LINKING UP THE PAIRS OF BRACKETS AND PARENS. #
#                                                                      #
#         IF WE FIND AN ITEM THAT HAS NO PRESETS (ACCORDING TO ITS     #
#         "SIMP" FIELD IN THE DNT), WE KNOW THAT THERE WAS AN ERROR IN #
#         ITS PRESET, SO WE SKIP AHEAD TO THE NEXT ITEM...             #
#                                                                      #
  
  
  
          CONTROL FASTLOOP; 
GET4: 
          TMPX = 0; 
          ITM = FALSE;
          INDX2 = INDX1;
          FOR  K = K
            WHILE  INDX2 LQ RBLSZ 
          DO
            BEGIN 
            GOTO SCAN[PETY[INDX2]];    # A PSEUDO-CASE STATEMENT       #
  
GET12:                             # ITEM PROCESSING                   #
            IF  ITM                # ANOTHER ITEM...END OF THE SCAN    #
            THEN
              BEGIN 
              ITM = FALSE;
              INDX = INDX1; 
              INDX1 = INDX2;
  
                $BEGIN
                PIBDMP; 
                $END
  
              RETURN; 
              END 
  
  
  
            ITM = TRUE; 
            IF NOT SIND[PELN[INDX2]]
            THEN
              BEGIN                # THERE WAS AN ARRAY PRESET ERROR   #
              TMPX = INDX2; 
              INDX2 = INDX2 + 1;
              FOR  J = J
                WHILE  INDX2 LQ RBLSZ 
              DO
                BEGIN 
                GOTO SCAN1[PETY[INDX2]];   # START SKIPPING            #
  
GET13:                             # CONSTANTS COME HERE               #
  
                INDX2 = INDX2 + PELN[INDX2];  # SKIP CONST             #
  
GET14:                             # MOST STUFF COMES HERE             #
                INDX2 = INDX2 + 1;
                END 
              GOTO GET19;          #FILL THE BUFFER AGAIN              #
  
  
              END 
            GOTO GET11;            # END OF CASE...                    #
  
GET15:                             # END-S AND ITEM-S COME HERE        #
            PEVL[TMPX] = INDX2;    # START SCAN WITH THIS NEW ITEM     #
            INDX1 = INDX2;
            TMPX = 0; 
            INDX2 = INDX2 - 1;
            ITM = FALSE;
            GOTO GET11;            # END OF CASE                       #
  
GET16:                             # LBRACK,LPAREN                     #
            PELN[INDX2] = TMPX; 
            TMPX = INDX2; 
            GOTO GET11;            # END OF CASE                       #
  
GET17:                             # RBRACK,RPAREN                     #
            PELN[INDX2] = TMPX; 
            TMPX = PELN[PELN[INDX2]]; 
            PELN[PELN[INDX2]] = INDX2;
            GOTO GET11;            # END OF CASE                       #
  
GET17A:                            # CONST                             #
            INDX2 = INDX2 + PELN[INDX2];
            GOTO GET11;            # END OF CASE                       #
  
GET18:                             # END                               #
            ITM = FALSE;
            INDX = INDX1; 
            INDX1 = 0;
  
              $BEGIN
              PIBDMP; 
              $END
  
            RETURN; 
  
  
GET11:                             # END OF CASE... BEGIN, EMPTY ALSO  #
            INDX2 = INDX2 + 1;
  
            END                    # OF FOR...A PSEUDO-CASE STMT       #
  
          CONTROL SLOWLOOP;        # BACK TO THE USUAL...              #
  
  
#          WE COME HERE TO REFILL THE BUFFER.....                      #
  
  
  GET19: #MOVE IF NOT AT TOP OF BUFFER# 
           IF INDX1 NQ 1 THEN 
           BEGIN
             FOR I=0 STEP 1 UNTIL RBLSZ-INDX1 DO
               PEDA[I+1]=PEDA[INDX1+I]; 
        $BEGIN
             IF TRACE$DBUG THEN 
             BEGIN
               PRINT ("(2X,O6,12H WORDS MOVED,7H RBLSZ=,O12,
                                      7H INDX1=,O12)"); 
             LIST (I);
             LIST (RBLSZ);
             LIST (INDX1);
             ENDL;
             END
        $END
             RBLSZ=RBLSZ-INDX1+1; 
             INDX1=1; 
             ITM=FALSE; 
           END
           #READ MORE OF THE PRESET#
           IF RBLSZ+MAXGET GR AITMAX THEN 
           SYMABT(J804,"ARRAY ITEM PRESET LARGER THAN ALOCTR BUFFER(GETS ALOCTR 
P IN ALOCTR)",60);                                                       ALOCTR 
           P<PSPARM>=LOC(PSIBUF[RBLSZ+1]);
        $BEGIN
           IF TRACE$ROUT THEN 
           BEGIN
             PRINT("(13H GTPST CALL  )"); 
             ENDL;
           END
        $END
           GTPST(PSPARM,RBLSZ1,GET10);
         $BEGIN 
           IF TRACE$ROUT THEN 
           BEGIN
             PRINT("(17H GTPST RETURNED  )"); 
             ENDL;
           END
        $END
           RBLSZ=RBLSZ+RBLSZ1;
           GOTO GET4; 
  
         END #IF AT GET1# 
         IF PETY[INDX1] EQ S"ITEM" OR PETY[INDX1] EQ S"BEGIN" 
         THEN GOTO GET4;
         ELSE GOTO GET3;
 GET10:  #EOF#
        $BEGIN
         PRINT("(42H EOF TERMINATED ARRAY PRESET PREMATURELY  )");
         ENDL;
        $END
 GET20:  #EOF#
         $BEGIN 
         IF TRACE$IO THEN 
         BEGIN
           PRINT("(6H EOF  )"); 
           ENDL;
         END
        $END
         INDX=0;
         INDX1=0; 
      END #PROC GETPS#
CONTROL EJECT;
     PROC  PUTPS ( (N), PADR, PDATA,STI);   #PUT PRESET INTO OUTPUT 
                                                          BUFFER# 
                                        #PUTPS IS CALLED BY SYPSET,    #
                                        # JOPSET, SAPP, AND STAOUT TO  #
                                        # BUILD CODE FILE ENTRIES.     #
      BEGIN 
         ITEM N I, #NO.OF (6600) WORDS OF PRESET DATA#
              PADR I; #RELATIVE (6600) ADDRESS OF PRESET# 
         ARRAY PDATA[0:0];  #PRESET DATA# 
             ITEM PDAT I; 
         ITEM STI; #SYMBOL TABLE INDX#
         ITEM X I;
        $BEGIN
         IF TRACE$ROUT THEN 
         BEGIN
           PRINT ("(22H PROC PUTPS  ENTERED  )"); 
           ENDL;
         END
         IF TRACE$DBUG THEN 
         BEGIN
         PRINT ("(14H PUTPS CALLED ,2X,5H N = ,I6,8H PADR = ,O12, 
           12H PDATA[0] = ,O20,12H PDATA[1] = O20)"); 
         LIST (N);
         LIST (PADR); 
         LIST (PDAT[0]);
         LIST (PDAT[1]);
         ENDL;
         END
        $END
         X=N*BYPWD/CBPW;
         IF X*CBPW NQ N*BYPWD THEN X=X+1; 
         IF PSOI+X+1 GQ OBUFSZ THEN 
         BEGIN
        $BEGIN
           IF TRACE$IO THEN 
           CDUMP(LOC(PSOBUF),PSOI,POBDTI);
        $END
             PTCFL(PSOBUF,PSOI); #WRITE BUFFER# 
             FOR I=0 STEP 1 UNTIL PSOI DO 
               CFDMY[I]=0;
             PSOI=0;
         END
         CFOP[PSOI]=QCFOP"PRSD";
         CFWC[PSOI]=N;
         CFRA[PSOI]=PADR; 
         CFST[PSOI]=STI;
         FOR I=0 STEP 1 UNTIL X-1 DO
             CFD[PSOI+I]=PDAT[I]; 
         PSOI=PSOI+X+CFEHSZ;  #FIX BUFFER INDEX#
      END #PROC PUTPS#
CONTROL EJECT;
 PROC PIBDMP; #PRESET INPUT BUFFER DUMP#
     BEGIN
        $BEGIN
         IF TRACE$IO THEN 
         CDUMP(LOC(PEDA[INDX]),RBLSZ-INDX,PIBDTI);
        $END
         RETURN;
     END #PIBDMP# 
  
      END   #END OF ALLOCATOR#
      TERM
