*COMDECK     COMPASS2   - WRITE OBJECT CODE IN CAPSULE FORMAT.
#*        PASS2 - WRITE OBJECT CODE IN CAPSULE FORMAT.
* 
*         R. H. GOODELL.     76/07/19.
* 
*         *PASS2* REFORMATS AND COMBINES THE TABLES CREATED BY THE
*         FIRST PASS CODE GENERATION ROUTINES, TO PRODUCE BINARY
*         OUTPUT IN THE FORM OF A CAPSULE.  *PASS2* ALSO CALLS
*         THE *EDITOR* ROUTINES TO PRINT THE OBJECT CODE LISTING. 
* 
*         CONTENTS (XDEF ENTRY POINTS). 
* 
*         PROC   PASS2       SECOND PASS PROCESSING OF ONE CAPSULE. 
# 
  
  
*CALL     COMDDEF            GENERAL DEFINITIONS. 
  
     XDEF BEGIN               # PUBLIC DATA # 
  
          ITEM EXTB I ;            # EXTERNALS BLOCK BASE ADDRESS # 
          ITEM LITB I ;            # LITERALS BLOCK BASE ADDRESS #
  
          END 
  
  
     XREF BEGIN               # MANAGED TABLES #
  
          ARRAY TABLES [0:9] S(2);  # ARRAY OF POINTERS AND LENGTHS    #
               BEGIN
               ITEM TABF (00,00,WL);
               END
  
*CALL     COMDTCAP           CURRENT CAPSULE (PASS 2).
  
*CALL     COMDTDPL           DATA BASE PROCEDURE LIST POINTERS. 
  
*CALL     COMDTCON           CONSTANT VALUES. 
  
*CALL     COMDTEPT           ENTRY POINTS.
  
*CALL     COMDTEXI           EXTERNAL IDENTIFIERS.
  
*CALL     COMDTEXT           EXTERNAL NAMES.
  
*CALL     COMDTLIT           LITERALS.
  
*CALL     COMDTREF           REFERENCES TO EXTERNALS (PASS 1).
  
*CALL     COMDTREL           RELOCATION BITS (PASS 2).
  
*CALL     COMDTSUB           SUB-SCHEMA DIRECTORY + FINISHED CAPSULES.
  
*CALL     COMDTSYM           SYMBOL TABLE.
  
*CALL     COMDTVAR           VARIABLES AND APLISTS (INTERMEDIATE).
  
*CALL     COMDTXEQ           EXECUTABLE CODE + PSEUDO OPS (INTERMEDIATE)
  
          END 
  
  
     XREF BEGIN               # OTHER EXTERNALS # 
  
*CALL     COMDHEAD           CAPSULE HEADER TABLE.
*CALL     COMDPRFX           CAPSULE PREFIX TABLE.
          ITEM CAPA I ;            # CAPSULE WORD ADDRESS # 
          ITEM CAPL I ;            # CAPSULE LENGTH IN WORDS #
          ITEM CAPS B ;            # TRUE IF CAPSULES ON SCRATCH FILE # 
          ITEM CSCR U ;            # CAPSULE SCRATCH FILE # 
          ITEM END2 ;              # DYNAMIC AREA FWA FOR THIS OVERLAY #
          ITEM ILEN I ;            # INSTRUCTION LENGTH: PARCELS - 1 #
          ITEM ILOC I ;            # LOCATION COUNTER # 
          ITEM INST U ;            # INSTRUCTION, LEFT JUST, FROM TXEQ #
          ITEM INSW U ;            # INSTRUCTION WORD GOING TO TCAP # 
          ITEM INTW U ;            # INSTRUCTION WORD FROM TXEQ # 
          ITEM IPAR I ;            # PARCEL NUMBER OF INSTR. (0-3) #
          ITEM IPOS I ;            # BEGINNING BIT POSITION OF INSTR. # 
          ITEM LOBJF B ;           # TRUE IF *LO=O* ON CONTROL CARD # 
          ITEM OLD65 ;             # LWA+1 OF THIS OVERLAY #
          ITEM REALMH C (30) ;     # REALM NAME IN 30H FORMAT # 
          ITEM RECORDH C (30) ;    # RECORD TYPE NAME IN 30H FORMAT # 
          ITEM VLOC I ;            # LOCATION COUNTER FOR TVAR #
          ITEM XPOS I ;            # NEXT BIT POSITION IN INTW #
          PROC ALLOC ;             # ALLOCATE TABLE SPACE # 
          PROC ASU ;               # ACCUMULATE STORAGE USED #
          PROC MOVE ;              # MOVE DATA, DIRECT ADDRESS #
          PROC MOVEI ;             # MOVE DATA, INDIRECT ADDRESS #
          FUNC OCTAL C (WC) ;      # CONVERT HALF-WORD TO OCTAL # 
          PROC PCP ;               # PRINT CAPSULE PREAMBLE # 
          PROC PIG ;               # PRINT INSTRUCTION GENERATED #
          PROC PLT ;               # PRINT LAST TABLES #
          PROC SDA ;               # SET DYNAMIC AREA BASE ADDRESS #
          PROC WRITEW ;            # WRITE WORDS FROM WORKING BUFFER #
          FUNC XSFW C (WC) ;       # SPACE FILL WORD #
          PROC XSST ;              # SHELL SORT TABLE # 
  
          END 
  
  
*CALL     COMDOPS            OPERATION CODES. 
  
  
#         LOCAL DATA. 
# 
          ARRAY [0:2] ;                 # RELOCATION BIT VALUES # 
               ITEM RBIT = [ 8, 4, 2 ] ;
          ITEM A C (WC) ;          # CHARACTER TEMPORARY #
          ITEM GH ;                # INSTRUCTION OPCODE # 
          ITEM I ;                 # INTEGER TEMPORARY #
          ITEM K ;                 # INSTRUCTION ADDRESS BEFORE RELOC. #
          ITEM M ;                 # INSTRUCTION ADDRESS AFTER RELOC.  #
          ITEM RB ;                # REL. BITS FOR CURRENT INSTR. WORD #
          ITEM RBBP ;              # RB BIT POSITION IN TREL WORD # 
          ITEM RBWN ;              # RB WORD NUMBER (TREL INDEX) #
          ITEM RELF S:RT ;         # RELOCATION FLAG #
  
  
  
  
#***      PASS2 - WRITE OBJECT CODE IN CAPSULE FORMAT.
  
          PROC PASS2
  
****
# 
          BEGIN 
  
          IF  END2 NE OLD65        # IF 1ST CALL OF THIS OVERLAY  # 
          THEN BEGIN                # (END2 = HHA), THEN SET END2 # 
               END2 = OLD65 ;        # TO ITS TRUE VALUE, AND SET # 
               CALL SDA (END2) ;      # DYNAMIC AREA BASE ADDRESS # 
               END
          CALL CCT ;               # COMBINE CODE TABLES #
          CALL CRC ;               # COMBINE REFERENCE CHAINS # 
          CALL WCP ;               # WRITE CAPSULE PREAMBLE # 
          CALL PCP ;               # PRINT CAPSULE PREAMBLE # 
          CALL WIN ;               # WRITE INSTRUCTIONS # 
          CALL PLT ;               # PRINT LAST TABLES #
          CALL WCD ;               # WRITE CONSTANT DATA #
          CALL WEP ;               # WRITE ENTRY POINTS # 
          CALL WEX ;               # WRITE EXTERNALS AND REFERENCES # 
          CALL WRB ;               # WRITE RELOCATION BITS #
          CALL WSS ;               # WRITE SUB-SCHEMA # 
          RETURN ;
  
  
  
  
#***      CCT  -  COMBINE CODE TABLES.
# 
          PROC CCT ;
  
#         *CCT* CONCATENATES TVAR TO THE END OF TXEQ, AND THEN
*         RELOCATES ALL TVAR-RELATIVE ADDRESSES IN TEPT, TREF,
*         AND TSYM.   *CCT* ALSO SUPPLIES SYMBOL NAMES OF THE 
*         FORM *LNNNNNN* FOR ALL TSYM ENTRIES THAT DO NOT HAVE
*         NAMES ALREADY.
****
# 
          BEGIN 
  
          ITEM VARB ;              # VARIABLES/APLISTS BASE ADDRESS # 
  
#         CONCATENATE *TVAR* TO *TXEQ*. 
# 
          MOVEI (TVARL, P<TVAR>, P<TXEQ> + TXEQL) ; 
          TXEQL = TXEQL + TVARL ; 
          TVARL = 0 ; 
          ALLOC (P<TXEQ>, 1) ;                    # APPEND ZERO WORD #
          XEQW [TXEQL-1] = 0 ;
  
#         COMPUTE BASE ADDRESSES OF TABLES WITHIN CAPSULE.
# 
          VARB = ILOC - O"400000" ;               # RELOCATION BIAS # 
          LITB = VARB + VLOC ;
          HEADEPTFWA = LITB + TCONL ; 
          EXTB = HEADEPTFWA + TEPTL ; 
#         HEADRELFWA = (SEE *CRC*)  # 
  
#         RELOCATE ENTRY POINTS TABLE.
# 
          FOR  I = 0 THRU TEPTL-1  DO 
               BEGIN
               IF  EPTA [I] LT 0
               THEN EPTA [I] = EPTA [I] + VARB ;
               END
  
#         RELOCATE EXTERNAL REFERENCES TABLE. 
# 
          FOR  I = 0 THRU TREFL-1  DO 
               BEGIN
               IF  REFA [I] LT 0
               THEN REFA [I] = REFA [I] + VARB ;
               IF  REFB [I] LT 0
               THEN REFB [I] = REFB [I] + VARB ;
               END
  
#         RELOCATE SYMBOL TABLE AND FILL IN NAMES AS NEEDED.
# 
          FOR  I = 0 THRU TSYML-1  DO 
               BEGIN
               IF  SYMA [I] LT 0
               THEN SYMA [I] = SYMA [I] + VARB ;
               IF  B<0,NL> SYMW [I] EQ 0
               THEN BEGIN 
                    A = OCTAL (SYMA [I]) ;
                    C<0,1> SYMW [I] = "L" ; 
                    C<1,6> SYMW [I] = C<4,6> A ;
               END  END 
  
          RETURN ;
  
          END 
  
  
  
  
#***      CRC  -  COMBINE REFERENCE CHAINS. 
# 
          PROC CRC ;
  
#         *CRC* CREATES TEXI IF IT WILL BE NEEDED BY *EDITOR*,
*         AND THEN SORTS TEXT INTO ALPHABETIC ORDER AND THEN
*         REARRANGES TREF AS REQUIRED BY THE CAPSULE LOADER.
*         WHEN *CRC* IS DONE, TREF IS EMPTY AND ALL REFERENCES
*         HAVE BEEN ADDED TO TEXT.
****
# 
          BEGIN 
  
          ITEM I, J, L, N, P, Q, W ;
  
#         EACH EXTA [I] POINTS TO THE LAST TREF WORD FOR THAT 
*         EXTERNAL NAME, AND EACH REFX [J] POINTS TO THE TEXT 
*         WORD FOR THE EXTERNAL NAME REFERENCED.
# 
          FOR  J = TREFL-1  STEP  -1  UNTIL  0  DO
               BEGIN
               I = REFX [J] ; 
               REFX [J] = EXTA [I] ;
               EXTA [I] = J ; 
               END
  
#         SAVE EXTERNAL IDENTIFIERS IN TEXI IN ORIGINAL TEXT ORDER
*         FOR USE IN OBJECT CODE LISTING, AND THEN SORT TEXT INTO 
*         ALPHABETIC ORDER AS REQUIRED BY THE FAST DYNAMIC LOADER.
# 
          IF  LOBJF                     # IF OBJECT CODE LISTING WANTED#
          THEN BEGIN
               ALLOC (P<TEXI>, TEXTL) ; 
               MOVEI (TEXTL, P<TEXT>, P<TEXI>) ;
               END
          CALL XSST (TEXT, TEXTL) ;     # SORT EXTERNAL NAMES # 
  
#         NOW EACH EXTA [I] POINTS TO THE FIRST TREF WORD IN THE
*         CHAIN FOR THAT EXTERNAL NAME, EACH REFX [J] POINTS TO 
*         THE NEXT TREF WORD IN THE SAME CHAIN, AND THE LAST
*         REFX [J] IN A CHAIN POINTS TO ITSELF.  NEXT, MAKE EACH
*         CHAIN CONTIGUOUS 20-BIT ENTRIES.
# 
          HEADNEXT = TEXTL ;            # NUMBER OF EXTERNALS # 
          N = TEXTL - 1 ; 
          FOR  I = 0 THRU N  DO         # FOR EACH EXTERNAL ... # 
               BEGIN
               J = EXTA [I] ;                # START OF CHAIN # 
               EXTA [I] = EXTB + TEXTL ;     # REL FWA OF LIST #
               W = 0 ;
               P = 20 ;                      # FIRST 20 BITS ZERO # 
               FOR  J = J  WHILE  J GE 0  DO
                    BEGIN                    # FOR EACH TREF WORD # 
                    IF  REF1 [J] NE 0         # IN THE CHAIN ... #
                    THEN BEGIN
                         B<P,20> W = REF1 [J] ; 
                         P = P + 20 ;             # STORE FIRST # 
                         IF  P EQ WL               # REFERENCE #
                         THEN BEGIN 
                              P = 0 ; 
                              ALLOC (P<TEXT>, 1) ;     # MAKE A NEW # 
                              EXTW [TEXTL-1] = W ;      # WORD,  IF # 
                              W = 0 ;                   # NECESSARY # 
                         END  END 
                    IF  REF2 [J] NE 0 
                    THEN BEGIN                    # STORE SECOND #
                         B<P,20> W = REF2 [J] ;    # REFERENCE  # 
                         P = P + 20 ; 
                         IF  P EQ WL
                         THEN BEGIN                    # MAKE A NEW # 
                              P = 0 ;                   # WORD,  IF # 
                              ALLOC (P<TEXT>, 1) ;      # NECESSARY # 
                              EXTW [TEXTL-1] = W ;
                              W = 0 ; 
                         END  END 
                    IF  REFX [J] EQ J             # TEST IF END # 
                    THEN J = -1 ;                  # OF CHAIN  #
                    ELSE J = REFX [J] ; 
                    END 
               ALLOC (P<TEXT>, 1) ;          # STORE LAST WORD OF # 
               EXTW [TEXTL-1] = W ;          # REF LIST, WITH AT #
               END                           # LEAST 20 ZERO BITS # 
          CALL ASU ;                    # ACCUMULATE STORAGE USED # 
          TREFL = 0 ;                   # CLEAR TREF #
          HEADRELFWA = EXTB + TEXTL ;   # SET RELBITS BASE ADDRESS #
          RETURN ;
  
          END 
  
  
  
  
#***      FUP  -  FORCE UPPER.
# 
          PROC FUP ;
  
#         *FUP* WRITES OUT ONE COMPLETED WORD OF THE BINARY CODE
*         IMAGE INTO TCAP AND ITS RELOCATION BITS INTO TREL.
****
# 
          BEGIN 
  
          IF  IPAR EQ 0  THEN  RETURN ; 
          ALLOC (P<TCAP>, 1) ;          # ADD INSTRUCTION WORD #
          CAPW [ILOC] = INSW ;          # TO CAPSULE CODE IMAGE # 
          ILOC = TCAPL ;
          INSW = O"61000 46000 61000 46000" ;     # START NEW WORD #
          IPAR = 0 ;
          IPOS = 0 ;
          B<RBBP,4> RELW [RBWN] = RB ;  # STORE RELOCATION BITS # 
          RB = 0 ;
          RBBP = RBBP + 4 ;             # ADVANCE RELBIT POINTERS # 
          IF  RBBP EQ WL
          THEN BEGIN                    # IF END OF RELBITS WORD #
               RBBP = 0 ;                # THEN START NEXT WORD # 
               RBWN = RBWN + 1 ;
               END
          RETURN ;
  
          END 
  
  
  
  
#***      GNP  -  GET NEXT PARCEL FROM INTERMEDIATE (TXEQ). 
# 
          FUNC GNP ;
  
#         *GNP* EXTRACTS THE NEXT 15-BIT PARCEL FROM TXEQ.
****
# 
          BEGIN 
  
          IF  XPOS GE WL                # IF NEW WORD NEEDED #
          THEN BEGIN
               XPOS = 0 ;               # GET NEXT WORD # 
               INTW = XEQW [0] ;
               P<TXEQ> = P<TXEQ> + 1 ;  # ELIDE ANTERIOR OF TABLE # 
               TXEQL = TXEQL - 1 ;       # (EAT)  WORD FROM TXEQ #
               END
          GNP = B<XPOS,15> INTW ;       # RETURN PARCEL # 
          XPOS = XPOS + 15 ;
          RETURN ;
  
          END 
  
  
  
  
#***      RSA  -  RELOCATE SYMBOLIC ADDRESS.
# 
          PROC RSA ;
  
#         ENTRY  (K) = ADDRESS FIELD OF INSTRUCTION FROM TXEQ.
*                (RELF) = RELOCATION FLAG.
* 
*         EXIT   (M) = RELOCATED ADDRESS. 
* 
****
# 
          BEGIN 
  
          LABEL  NIL, EXT, LIT, SYM ; 
  
          SWITCH  ADDRESS: RT 
                    NIL: NO,  EXT: EXT,  LIT: LIT,  SYM: SYM ;
          GO TO ADDRESS [RELF] ;
               BEGIN
  
      NIL:                         # NO RELOCATION, K = ABSOLUTE ADDR # 
               M = K ;
               RETURN ; 
  
      EXT:                         # EXTERNAL RELOCATION, K = INDEX # 
               M = ILOC + O"400000" ;   # OF EXTERNAL NAME #
               RB = RB + RBIT [IPAR] ;
               RELF = S"NO" ; 
               RETURN ; 
  
      LIT:                         # CONSTANT RELOCATION, K = INDEX # 
               M = LITB + LITA [K] ;    # OF LITERALS TABLE ENTRY # 
               RB = RB + RBIT [IPAR] ;
               RELF = S"NO" ; 
               RETURN ; 
  
      SYM:                         # SYMBOL RELOCATION, K = INDEX # 
               M = SYMA [K] ;           # OF SYMBOL TABLE ENTRY # 
               RB = RB + RBIT [IPAR] ;
               RELF = S"NO" ; 
               RETURN ; 
  
               END       # OF RELF CASES #
  
          END 
  
  
  
  
#***      WCD  -  WRITE CONSTANT DATA.
# 
          PROC WCD ;
  
#         *WCD* MOVES THE *LITERALS BLOCK* FROM TCON TO TCAP. 
****
# 
          BEGIN 
  
          ALLOC (P<TCAP>, TCONL) ;      # APPEND TCON TO TCAP # 
          MOVEI (TCONL, P<TCON>, P<TCAP> + LITB) ;
          CALL ASU ;                    # ACCUMULATE STORAGE USED # 
          TCONL = 0 ;                   # CLEAR CONSTANT AND #
          TLITL = 0 ;                    # LITERAL TABLES # 
          RETURN ;
  
          END 
  
  
  
  
#***      WCP  -  WRITE CAPSULE PREAMBLE. 
# 
          PROC WCP ;
  
#         *WCP* MOVES THE THREE HEADER WORDS FOR THE CAPSULE
*         FROM HEAD TO TCAP.
****
# 
          BEGIN 
  
          HEADNEPT = TEPTL ;
          HEADLENGTH = HEADRELFWA + (LITB + 14) / 15 ;
          HEADCAP = PRFXCAP ; 
          ALLOC (P<TCAP>, 3) ;          # ALLOCATE 3 WORDS FOR TCAP # 
          MOVE (3, HEAD, TCAP) ;        # MOVE HEADER WORDS TO TCAP # 
          RETURN ;
  
          END 
  
  
  
  
#***      WEP  -  WRITE ENTRY POINTS. 
# 
          PROC WEP ;
  
#         *WEP* MOVES THE *ENTRY POINTS* FROM TEPT TO TCAP. 
****
# 
          BEGIN 
  
          ALLOC (P<TCAP>, TEPTL) ;      # APPEND TEPT TO TCAP # 
          MOVEI (TEPTL, P<TEPT>, P<TCAP> + HEADEPTFWA) ;
          CALL ASU ;                    # ACCUMULATE STORAGE USED # 
          TEPTL = 0 ;                   # CLEAR ENTRY POINTS TABLE #
          RETURN ;
  
          END 
  
  
  
  
#***      WEX  -  WRITE EXTERNALS AND REFERENCES. 
# 
          PROC WEX ;
  
#         *WEX* MOVES THE *EXTERNAL NAMES AND REFERENCES* FROM
*         TEXT TO TCAP. 
****
# 
          BEGIN 
  
          ALLOC (P<TCAP>, TEXTL) ;      # APPEND TEXT TO TCAP # 
          MOVEI (TEXTL, P<TEXT>, P<TCAP> + EXTB) ;
          CALL ASU ;                    # ACCUMULATE STORAGE USED # 
          TEXTL = 0 ;                   # CLEAR EXTERNALS TABLE # 
          RETURN ;
  
          END 
  
  
  
  
#***      WIN  -  WRITE INSTRUCTIONS. 
# 
          PROC WIN ;
  
#         WIN READS MACHINE INSTRUCTIONS AND PSEUDO INSTRUCTIONS
*         IN INTERMEDIATE LANGUAGE FORM FROM *TXEQ*, CONVERTS 
*         THEM TO FINAL FORM, AND STORES THEM INTO THE CAPSULE
*         IMAGE *TCAP*.  ALSO PUTS RELOCATION BITS INTO *TREL*, 
*         AND CALLS *PIG* TO PRINT INSTRUCTIONS AS THEY ARE 
*         GENERATED.
****
# 
          BEGIN 
  
#         INITIALISE. 
# 
          ALLOC (P<TREL>, (LITB + 14) / 15) ;     # ALLOCATE AND     #
          FOR  K = TRELL-1 STEP -1 UNTIL 0  DO    # CLEAR RELOCATION #
               RELW [K] = 0 ;                     # BITS TABLE       #
          RB   = 0 ;
          RBBP = TCAPL * 4 ;
          RBWN = 0 ;
          RELF = S"NO" ;
          INST = 0 ;
          INSW = O"61000 46000 61000 46000" ; 
          IPAR = 0 ;
          IPOS = 0 ;
          XPOS = WL ; 
  
#         PROCESS INSTRUCTIONS. 
# 
          FOR  ILOC = TCAPL  WHILE  TXEQL NE 0  DO
               BEGIN
               B<0,15> INST = GNP ;     # GET NEXT PARCEL # 
               GH = B<0,6> INST ;       # EXTRACT OPCODE #
               IF  GH EQ OP"PSEUDO" 
               THEN CALL WPI ;          # WRITE PSEUDO INSTRUCTION OR # 
               ELSE CALL WMI ;          # WRITE MACHINE INSTRUCTION # 
               END
  
#         TERMINATE.
# 
          CALL ASU ;                    # ACCUMULATE STORAGE USED # 
          TEXIL = 0 ;                   # CLEAR EXTERNAL IDENT TABLE #
          TSYML = 0 ;                   # CLEAR SYMBOL TABLE #
          RETURN ;
  
          END 
  
  
  
  
#***      WMI  -  WRITE MACHINE INSTRUCTION.
# 
          PROC WMI ;
  
#         CALLED BY *WIN* TO PROCESS A MACHINE INSTRUCTION. 
****
# 
          BEGIN 
  
          ITEM LONG U = O"7760 0000 0000 0340 7016" ; 
  
          IF  GH GE WL                  # ILEN = 0 IF 15-BIT INSTR. # 
          THEN ILEN = 0 ;               #     OR 1 IF 30-BIT INSTR. # 
          ELSE ILEN = B<GH> LONG ;
          IF  IPAR + ILEN GE 4          # IF INSTR. WILL NOT FIT INTO # 
          THEN CALL FUP ;                # CURRENT WORD, FORCE UPPER #
          IF  ILEN EQ 0 
          THEN B<IPOS,15> INSW = B<0,15> INST ;   # STORE INSTRUCTION # 
          ELSE BEGIN
               B<15,15> INST = GNP ;    # GET SECOND PARCEL # 
               K = B<12,18> INST ;
               CALL RSA ;               # RELOCATE SYMBOLIC ADDRESS # 
               B<IPOS,12> INSW = B<0,12> INST ;   # STORE GHIJ #
               B<IPOS+12,18> INSW = M ;           # RELOCATED K # 
               END
          CALL PIG ;                    # PRINT INSTRUCTION GENERATED # 
          IPAR = IPAR + ILEN + 1 ;
          IPOS = IPAR * 15 ;            # ADVANCE POSITION COUNTERS # 
          IF  IPAR GE 4 
          THEN CALL FUP ;               # FORCE UPPER IF WORD IS FULL # 
          RETURN ;
  
          END 
  
  
  
  
#***      WPI  -  WRITE PSEUDO INSTRUCTION. 
# 
          PROC WPI ;
  
#         CALLED BY *WIN* TO PROCESS A PSEUDO INSTRUCTION.
****
# 
          BEGIN 
  
          ARRAY ;                  # TO STORE VALUE OF *CON* #
               BEGIN
               ITEM V1 (0,  0, 15) ;    # INDIVIDUAL PARCELS #
               ITEM V2 (0, 15, 15) ;
               ITEM V3 (0, 30, 15) ;
               ITEM V4 (0, 45, 15) ;
               ITEM W1 (0,  0, 60) ;    # SIGN EXTENSION #
               ITEM W2 (0, 15, 45) ;
               ITEM W3 (0, 30, 30) ;
               ITEM W4 (0, 45, 15) ;
               END
          ITEM I, J ; 
  
          LABEL PP0, PP1, PARG, PEQU ;
          LABEL PNO, PFORCE, PCON, PIMMED, PSUBR ;
          LABEL PCONA1, PCONA2, PCONA3, PCONA4 ;
          LABEL PCONB1, PCONB2, PCONB3, PCONB4 ;
          LABEL PLINE, PLABEL, PBSS, PSCON, PSVFD ; 
          LABEL PCON3, WPI1 ; 
  
          I = B<6,3> INST ;        # EXTRACT INSTRUCTION SUBFIELDS #
          J = B<9,3> INST ; 
  
          SWITCH  PPSEUDO: PS 
                    PP0: P0,  PP1: P1,  PARG: ARG,  PEQU: EQU ; 
          GO TO PPSEUDO [J] ; 
               BEGIN
  
#                             PROCESS PSEUDOS WITH J = PS"P0".
# 
      PP0:     ILEN = 0 ;               # SET 15-BIT LENGTH # 
               K = B<12,3> INST ;       # EXTRACT SUB-SUB-OPCODE #
  
               SWITCH PPP0: P0
                         PNO: NO,  PFORCE: FORCE,  PCON: CON, 
                         PIMMED: IMMED,  PSUBR: SUBR ;
               GO TO PPP0 [K] ; 
                    BEGIN 
  
           PNO:                    # 00R00        NO-OP (PADDING)      #
                    RELF = I ;
                    GO TO WPI1 ;        # SET RELOCATION FOR NEXT *Q* # 
  
           PFORCE:                 # 00R01        FORCE UPPER          #
                    CALL FUP ;          # FORCE UPPER # 
                    RELF = I ;          # SET RELOCATION FOR NEXT *Q* # 
                    GO TO WPI1 ;
  
           PCON:                   # 00N02 XXXX   CON WORD             #
                    CALL FUP ;          # FORCE UPPER # 
  
                    SWITCH  PCONA 
                              , PCONA4, PCONA3, PCONA2, PCONA1 ;
                    GO TO PCONA [I] ; 
                         BEGIN
                PCONA1:  V1 = GNP ;     # STORE VALUE PARCELS # 
                PCONA2:  V2 = GNP ; 
                PCONA3:  V3 = GNP ; 
                PCONA4:  V4 = GNP ; 
                         END
  
                    SWITCH  PCONB 
                              , PCONB1, PCONB2, PCONB3, PCONB4 ;
                    GO TO PCONB [I] ; 
                         BEGIN
                PCONB1:  INSW = W4 ;    # EXTEND SIGN # 
                         GO TO PCON3 ;
                PCONB2:  INSW = W3 ;
                         GO TO PCON3 ;
                PCONB3:  INSW = W2 ;
                         GO TO PCON3 ;
                PCONB4:  INSW = W1 ;
                         END
  
           PCON3:   CALL PIG ;          # PRINT INSTRUCTION GENERATED # 
                    IPAR = 4 ;
                    CALL FUP ;          # FORCE UPPER # 
                    RETURN ;
  
           PIMMED:                 # 00N03 XXXX   IMMEDIATE LITERAL    #
                    K = I / 3 + 1 ; 
                    FOR  J = 1 THRU K  DO 
                         B<J*15,15> INST = GNP ;
                    GO TO WPI1 ;
  
           PSUBR:                  # 00004        SUBROUTINE ENTRY/EXIT#
                    CALL FUP ;          # FORCE UPPER # 
                    B<0,30> INSW = O"0400 400000" + ILOC ;  #EQ *+1S17# 
                    RB = RBIT [0] ;     # SET RELOCATION BITS # 
                    CALL PIG ;          # PRINT INSTRUCTION GENERATED # 
                    IPAR = 4 ;          # INDICATE WORD IS FULL # 
                    CALL FUP ;          # AND FLUSH IT OUT #
                    RETURN ;
  
                    END            # OF PS"P0" CASES #
  
#                             PROCESS PSEUDOS WITH J = PS"P1".
# 
      PP1:     ILEN = 1 ;               # SET 30-BIT LENGTH # 
               B<15,15> INST = GNP ;    # GET SECOND PARCEL # 
               K = B<12,18> INST ;
  
               SWITCH  PPP1: P1 
                         PLINE: LINE,  PLABEL: LABEL,  PBSS: BSS, 
                         PSCON: SCON,  PSVFD: SVFD ;
               GO TO PPP1 [I] ; 
                    BEGIN 
  
           PLINE:                  # 0001KKKKKK   PRINT SOURCE LINE NO.#
                    GO TO WPI1 ;
  
           PLABEL:                 # 0011KKKKKK   DEFINE GEN.STMT.LABEL#
                    CALL FUP ;          # FORCE UPPER # 
                    GO TO WPI1 ;
  
           PBSS:                   # 0021KKKKKK   BSS K WORDS          #
                    CALL FUP ;          # FORCE UPPER # 
                    CALL PIG ;          # PRINT INSTRUCTION GENERATED # 
                    FOR  I = 1 THRU K  DO 
                         BEGIN
                         INSW = 0 ;     # WRITE N WORDS OF ZERO # 
                         IPAR = 4 ; 
                         CALL FUP ; 
                         END
                    RETURN ;
  
           PSCON:                  # 0031KKKKKK   K WORDS OF CON 0LID+N#
  
           PSVFD:                  # 0041KKKKKK   K WORDS OF VFD N/Q...#
                    CALL FUP ;          # FORCE UPPER # 
                    CALL PIG ;          # PRINT INSTRUCTION GENERATED # 
                    FOR  I = 0 THRU K-1  DO 
                         BEGIN
                         INSW = XEQW [I] ;   # WRITE K WORDS OF DATA #
                         IPAR = 4 ; 
                         CALL FUP ; 
                         END
                    P<TXEQ> = P<TXEQ> + K ;  # EAT K WORDS FROM TXEQ #
                    TXEQL = TXEQL - K ; 
                    XPOS = WL ; 
                    RETURN ;
  
                    END            # OF PS"P1" CASES #
  
#                             PROCESS REMAINING PSEUDO OPERATIONS.
# 
      PARG:                        # 00R2KKKKKK   APLIST WORD          #
               ILEN = 1 ;               # SET 30-BIT LENGTH # 
               CALL FUP ;               # FORCE UPPER # 
               RELF = I ;               # SET RELOCATION #
               B<15,15> INST = GNP ;    # GET SECOND PARCEL # 
               K = B<12,18> INST ;
               IPAR = 2 ; 
               CALL RSA ;               # RELOCATE SYMBOLIC ADDRESS # 
               IPAR = 0 ; 
               INSW = M ;               # SET INSTRUCTION WORD #
               CALL PIG ;               # PRINT INSTRUCTION GENERATED # 
               IPAR = 4 ; 
               CALL FUP ;               # FORCE UPPER # 
               RETURN ; 
  
      PEQU:                        # 00R3KKKKKK   EQUATE SYMBOL        #
               ILEN = 1 ;               # SET 30-BIT LENGTH # 
               B<15,15> INST = GNP ;    # GET SECOND PARCEL # 
               GO TO WPI1 ; 
  
               END            # OF PSEUDO OPERATION CASES # 
  
 WPI1:    CALL PIG ;                    # PRINT INSTRUCTION GENERATED # 
          RETURN ;
  
          END 
  
  
  
  
#***      WRB  -  WRITE RELOCATION BITS.
# 
          PROC WRB ;
  
#         *WRB* MOVES THE *RELOCATION BITS* FROM TREL TO TCAP.
****
# 
          BEGIN 
  
          ALLOC (P<TCAP>, TRELL) ;      # APPEND TREL TO TCAP # 
          MOVEI (TRELL, P<TREL>, P<TCAP> + HEADRELFWA) ;
          CALL ASU ;                    # ACCUMULATE STORAGE USED # 
          TRELL = 0 ;                   # CLEAR RELBITS TABLE # 
          RETURN ;
  
          END 
  
  
  
  
#***      WSS  -  WRITE SUB-SCHEMA. 
# 
          PROC WSS ;
  
#         *WSS* APPENDS THE COMPLETED CAPSULE TO THE SUB-SCHEMA 
*         DIRECTORY, EITHER IN MEMORY OR ON THE SCRATCH FILE IF 
*         THE CAPSULES HAVE BEEN SPILLED. 
****
# 
          BEGIN 
  
          CAPA = SBCWSBLENG ;                # CAPSULE WORD ADDRESS # 
          CAPL = PRFXWDCT + 1 + TCAPL ;      # CAPSULE LENGTH # 
          SBCWSBLENG = SBCWSBLENG + CAPL ;   # TOTAL SUB-SCHEMA LENGTH #
          IF  SBCWMAXCAPL LT CAPL            # GREATEST CAPSULE LENGTH #
          THEN SBCWMAXCAPL = CAPL ; 
          IF  NOT CAPS                       # TRY TO APPEND CAPSULE #
          THEN ALLOC (P<TSUB>, PRFXWDCT+1) ;  # TO SUB-SCHEMA IN CORE # 
          IF  NOT CAPS     # (MAY HAVE JUST SPILLED) #
          THEN BEGIN                         # IF ENOUGH MEMORY SPACE # 
               MOVEI (PRFXWDCT+1, LOC (PRFX), P<TSUB>+CAPA) ; # PREFIX #
  
                             # APPEND CONTENTS OF TCAP TO TSUB         #
  
               MOVEI (TCAPL, P<TCAP>, P<TSUB>+TSUBL) ;  # CAPSULE BODY #
               TSUBL = TSUBL + TCAPL ;
  
                             # RESET THE TCAP POINTER                  #
                             # WHEN POSSIBLE, LEAVE SPACE FOR NEXT PRFX#
  
               P<TCAP> = LOC(TSUB) + TSUBL + PRFXWDCT +1; 
               IF TABF[2] GR TABF[3]   # IF P<TCAP> GR P<'NEXT'> #
               THEN 
                 BEGIN
                 P<TCAP> = LOC(TSUB) + TSUBL; 
                 END
               END
          ELSE BEGIN                         # IF SCRATCH FILE NEEDED # 
               WRITEW (CSCR, PRFX, PRFXWDCT+1) ;              # PREFIX #
               WRITEW (CSCR, TCAP, TCAPL) ;             # CAPSULE BODY #
               END
          CALL ASU ;                         # ACCUMULATE STORAGE USED #
          TCAPL = 0 ;                        # CLEAR CAPSULE TABLE #
          RETURN ;
  
          END 
  
     END  TERM
