*DECK     DECPRO
          IDENT  DECPRO 
          TITLE              DECLARATIVE STATEMENT PROCESSORS 
*CALL     SSTCALL 
 B=DECPR  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
          ENTRY  DPCOM,DPEQU,DPTYP,DPDIM
          ENTRY  DPIMP,LASTTYP
          EXT    CONVERT,RSELECT,PH1SCAN,ORGTAB 
          EXT    IMPTYP 
          EXT    NRB
          EXT    N.COM
          EXT    N.FP 
          EXT    VARDIM 
  
          TABLES COM,EQV,DIM
 Z.COM    EQU    0                 *** LOADER BUG 
  
 PROGRAM  EQU    RA.SSW+56B        PROG    12/2000B,48/0
*                                  BLKDTA  60/0 
*                                  SUBR    12/2001B,48/0
*                                  FUNC    12/2002B,48/0
 SYM1     EQU    12B
 TYPE     EQU    24B               STATEMENT TYPE 
 SELIST   EQU    32B
 ATYPE    EQU    51B               HOLDS CODE FOR TYPE STMT 
          SPACE  3
***       DECPRO - DECLARATIVE STATEMENT PROCESSORS (PHASE 1).
* 
*         *DECPRO* IS A SERIES OF SUBROUTINES THAT PROCESS THE
*         FOLLOWING DECLARATIVE STATEMENTS -- 
* 
*                COMMON 
*                DIMENSION
*                EQUIVALENCE
*                IMPLICIT 
*                LEVEL
*                TYPE (EXPRESSED OR IMPLIED)
* 
*         EACH SUBROUTINE CHECKS STATEMENT SYNTAX AND ACCUMULATES 
*         DECLARATIVE INFORMATION IN THE SYMBOL TABLE AND OTHER 
*         PERTINENT TABLES.  *DECPRO* DOES VERY LITTLE SEMANTIC 
*         CHECKING, LEAVING THAT CHORE FOR *DPCLOSE* WHEN THE FIRST 
*         EXECUTABLE STATEMENT IS ENCOUNTERED.
          SPACE  2
*         ERROR MESSAGE ORDINALS
  
 E.IFP    EQU    94                F.P. IN COMMON OR EQUIV STMT 
 E.IUF    EQU    310               ILLEGAL USE OF FUNCTION NAME 
 E.TLT    EQU    41                BAD SYNTAX 
 E47      =      47          CHARACTER BOUNDS REVERSED IN IMPLICIT STMT 
 E.TRT    EQU    49                NAME PREVIOUSLY TYPED
 E89      =      89          ILLEGAL SYNTAX IN IMPLICIT STMT
 E109     =      109         DECLARATIVE STMT OUT OF SEQUENCE 
 E.TSUB   EQU    233               SUBROUTINE OR PROGRAM NAME MAY NOT 
*                                  APPEAR IN A DECLARATIVE. 
 E.NOCOM  EQU    285               NO COMMA 
 E.BADSEP EQU    286               BAD SEPARATOR
 E.BADSYN EQU    287               BAD SYNTAX 
 E291     =      291         CONFLICTING LEVEL NUMBERS USED 
*CALL     PARSEM
          TITLE              CDN - CHECK NAME IN DECLARATIVE STMT 
 INITE    MACRO                    INITIALIZE E-LIST POINTER IN A4
          SA5    SELIST 
          SA4    X5+B5             START 1 BACK 
          ENDM
  
 CNAME    MACRO  ERNUM             CALL CDN TO PROCESS NAME 
          SB6    ERNUM
          RJ     CDN               PROCESS NAME 
          ENDM
  
*** 
*         CDN - CHECK DECLARED NAME 
* 
*         ON ENTRY: 
*                SELIST POINTS TO THE NAME
*                B6 = ERROR NUMBER IN CASE E-LIST IS NOT A NAME 
*                A4,A5 = E-LIST POINTERS AS SET BY GETE 
*                FPFLAG SET BY THE STATEMENT PROCESSOR
* 
*         ON EXIT:  
*                A0-A2,X1,X2,B1,B2 AS SET BY "SYMBOL" WITH
*                X6 = 0 IF PREVIOUS OCCURRENCES, ELSE 
*                X6 = NATURAL TYPE S"P.TYP" 
*                SAVEB1 = SAVED VALUE OF B1 
*                SNAME - E-LIST FOR THE NAME
* 
  
          USE    /MACBUF/ 
 FPFLAG   BSSZ   1                 1S_P.FP IF F.P.S NOT ALLOWED FOR STM 
*                                  ELSE 0 
 SAVEB1   BSSZ   1                 SAVED VALUE OF SYMTAB ORD
 SNAME    BSSZ   1                 SAVED VALUE OF NAME (E-LIST FORMAT 
          USE    *
          SPACE  3
 CDN.F    SA7    SAVEB1 
          SB7    B0                SET FLAG FOR DPTYP 
          ZR     X5,CDN            IF NO PREVIOUS REFS IN A DEBUG STMT
          SA3    TYPE              STMT TYPE CODE 
          SX4    X3-8 
          ZR     X4,CDN            IF A TYPE STMT 
          BX7    X5 
          CFO    VAR               CHECK SETTING OF DEBUG BITS
  
 CDN      ENTRY. *
          MX7    0                 NOT PROCESSING COMMON
          SX6    B6-E56 
          NZ     X6,CDN.1 
          BX7    -X7-X7            PROCESSING COMMON
  
 CDN.1    SA7    COMFLAG
  
          NEXTE 
          IF.NE  NAME,CDN.EX2      IF NOT A NAME
  
          UPDATE                   ADVANCE PAST IT
          BX7    X4 
          SA7    SNAME
          SYMBOL                   GET SYMTAB ORDINAL 
          BX5    X7                SAVE F.O. EXIT CONDITION FROM SYMBOL 
          SX7    B1 
          EQ     CDN.F             FIRST OCCURRENCE 
  
          SA3    FPFLAG            PREVIOUS OCCURRENCES 
          MX6    0
          SX7    B1 
          SA7    SAVEB1 
          EQ     B1,B5,CDN.E1      IF ORDINAL 1 
  
          BX0    X3*X1
          NZ     X0,CDN.E2         ERROR IF A F.P.
  
          MX4    L.TYP
          BX5    X4*X2             EXTRACT TYPE FROM SYMTAB WORD B
          LX5    L.TYP
          SX7    X5-T.LAB 
          PL     X7,CDN.E3         ERROR IF RETURNS OR SUCH 
  
          SA4    TYPE 
          SX5    X4-8 
          ZR     X5,CDN            EXIT IF A TYPE STMT
  
          BX3    X2 
          LX3    59-P.EXT 
          PL     X3,CDN            EXIT IF NOT EXTERNAL 
          EQ     CDN.E3 
          SPACE  3
*         ERROR EXITS 
  
 CDN.E0   POSTER SEV=FE,NR=**,RETURN=PH1SCAN
  
 CDN.E1   SB6    E.TSUB            SUBROUTINE OR PROGRAM NAME MAY NOT 
*                                  APPEAR IN A DECLARATIVE. 
          BX6    X6-X6
          SA6    COMERR1     CLEAR DUPLICATE NAME FLAG
          EQ     CDN.EX 
  
 CDN.E2   SB6    E.IFP             F.P. IN COMMON OR EQV STMT 
          EQ     CDN.EX 
  
 CDN.E3   SB6    E.CUN             CONFLICTING USE OF A NAME
          EQ     CDN.EX 
  
 CDN.E4   SB6    E.IUF             ILLEGAL USE OF FUNCTION NAME 
  
 CDN.EX   SA5    RSELECT
          ZR     X5,CDN.EX1        IF R=0 
          ADDREF SAVEB1,REF        A REFERENCE FOR THE NAME 
  
 CDN.EX1  SA4    SNAME
  
 CDN.EX2  SA3    COMFLAG
          PL     X3,CDN.E0         IF NOT COMMON
  
          SX6    1
          SA6    A3                SET COMMON ERROR FLAG
          POSTER SEV=FE,NR=**,RETURN=CDN
          TITLE              DPCOM - COMMON STATEMENT PROCESSOR 
*** 
*         DPCOM - PROCESS COMMON STATEMENTS 
* 
*         FORMAT OF A COMMON DECLARATION IS: <BLOCK DEC><LIST>
*         WHERE <BLOCK DEC> MAY BE: 
*           NULL OR //             BLANK COMMON 
*           /INTEGER/              NUMBERED COMMON
*           /NAME/                 LABELED COMMON 
* 
*         THE LIST MAY CONTAIN NAMES OR ARRAY DECLARATIONS
* 
*         FOR EACH NAME IN THE LIST THE COMMON AND DEFINED BITS ARE SET 
* 
*         DURING PHASE 1 THE COMMON INFORMATION IS KEPT IN 2 TABLES:    
* 
*         THE COMMON BLOCK NAME TABLE STARTING AT "ORGTAB"
*         FORMAT:  42/7L_BLOCK NAME,18/COM TAB INDEX  ( FWA-O.COM ) 
* 
*         AND "COM TAB" STARTING AT (O.COM) 
*         FOR EACH BLOCK AND LIST OF NAMES THE FOLLOWING ENTRIES ARE
*         MADE: 
*         BLOCK NAME:    24/0,18/NUMBER OF NAMES,18/LINK ORD
*                                  WHERE LINK ORD = NEXT-*
*         VARIABLE NAME: 24/0,18/SYMTAB ORD,18/0
* 
  
*         ERROR MESSAGES
  
 E56      =      56          ILL SYNTAX IN COMMON DECLARATION 
 E.CIVN   EQU    57                ILLEGAL VARIABLE NAME OR ALREADY IN C
 E.CIBN   EQU    58                ILLEGAL BLOCK NAME 
 E.CTMB   EQU    230               TOO MANY COMMON BLOCKS 
 ENANC    EQU    205               NUMBERED COMMON IS NON-ANSI
  
 SAVEA4   BSS    1                 SAVE A4 ACROSS ERPRO CALL
  
          USE    /MACBUF/ 
*GNC                               NUMBER OF NAMES IN THE BLOCK 
 WORDBF                            WORD B SYMTAB FLAGS
 LINKA                             LINK ADDRESS 
          USE    *
  
 DPCOM.E  EQU    CDN.E0            ERROR EXIT 
          SPACE  6
 DPCOM    SX6    B5 
          LX6    P.FP 
          SA6    FPFLAG            F.P.S NOT ALLOWED IN COMMON STMTS
          EJECT 
*         PROCESS BLOCK NAME
  
 DPCOML   RJ     SCF               SAVE LENGTH OF COMTAB
          SA5    SELIST 
          SA4    X5 
          UX0    B1,X4
          SB2    EL.SLASH 
          EQ     B1,B5,DPCOM.BC    IF A NAME
          SB6    E56               ERR MSG NR - *ILL SNTX IN COMMON DEC*
          NE     B1,B2,DPCOM.E     IF NOT A / 
          SA4    A4-B5             NEXT  ( NAME OR / )
          UX5    B1,X4
          NE     B1,B2,DPCOM1      IF NOT A / 
          SA4    A4-B5             ADJUST E-LIST POINTER
  
*         SET UP BLANK COMMON 
  
 DPCOM.BC SX6    A4 
          SA5    =8R               NAME OF BLANK COMMON 
          EQ     DPCOM3 
  
 DPCOM1   EQ     B1,B5,DPCOM2      IF A NAME
          SB6    E.CIBN 
          NZ     B1,DPCOM.E        IF NOT A NUMBER
          AX5    18 
          SX6    X5-8 
          PL     X6,DPCOM.E        IF MORE THAN 7 DIGITS
          AX5    45-18
          SX7    X5-T.INT 
          NZ     X7,DPCOM.E        IF NOT AN INTEGER CONSTANT 
          SX6    A4 
          SA6    SAVEA4 
          POSTERR  NR=ENANC,SEV=ANSI
          SA4    SAVEA4 
          SA4    X4 
          SA2    X4          FETCH NAME 
  
*         STRIP LEADING ZEROS FROM NAME.
  
          SB1    -59+6-1-6   DEFAULT SHIFT COUNT FOR BLANK MASK 
          SA1    =10H 
          LX2    -6 
          SA3    =1L0 
          MX0    6
  
 DPCOM1A  LX2    6           ADVANCE NAME 
          BX6    X0*X2
          SB1    B1+6 
          IX4    X6-X3
          ZR     X4,DPCOM1A  IF CHARACTER .EQ. DPC(0) 
          LX0    B1          MASK FOR BLANK 
          BX4    X0*X2
          BX3    -X0*X1 
          BX5    X4+X3       BLANK FILL 
          IX3    X5-X1
          NZ     X3,DPCOM1C  IF NAME DOES NOT REDUCE TO ALL BLANKS
          SA5    =10H0
  
 DPCOM1C  SB2    EL.SLASH 
          LX5    60-12             ADJUST 
  
 DPCOM2   SA4    A4-B5
          UX0    B1,X4
          SB6    E56               ERR MSG NR - *ILL SNTX IN COMMON DEC*
          NE     B1,B2,DPCOM.E     IF NO SECOND / 
          MX7    0
          SX6    A4-B5             UPDATE E-LIST POINTER
  
*         ADD BLOCK NAME TO TABLES
*         X5 = 8R_BLOCK NAME , X6 = E-LIST POINTER
  
 DPCOM3   SA6    SELIST 
          MX0    L.NAME 
          LX5    12 
          BX6    X0*X5             EXTRACT BLOCK NAME 
  
          AX5    42 
          MX4    54 
          BX3    -X4*X5 
          SX1    X3-1R$ 
          NZ     X1,NODOL          IF NOT A $ 
          SX3    1R -1R$
          LX3    42 
          IX6    X6+X3             REMOVE $ FROM THE NAME 
 NODOL    BSS    0
  
          SX7    B0 
          SB1    B0 
          SA7    COMERR1     CLEAR DUPLICATE NAME FLAG
          SA7    GNC               CLEAR NUMBER OF VARIABLES IN THE BLOC
  
          SA1    N.COM             NUMBER OF BLOCKS 
          SB7    ORGTAB 
          SA6    B7+X1             STORE NAME AS TABLE TERMINATOR 
          SB2    X1 
  
+         SA2    B7+B1             SEARCH ORGTAB FOR A MATCH OF BLOCK NA
          SB1    B1+B5             ADVANCE BLOCK ORDINAL
          BX3    X0*X2
          IX4    X3-X6
          NZ     X4,*-1            LOOP IF NO HIT 
          SA7    A6                CLEAR THE LAST ENTRY 
          LE     B1,B2,DPCOM.P     IF NAME PREVIOUSLY ENCOUNTERED 
          SB3    M.NCB-2
          LE     B1,B3,DPCOM4      IF MAX NUMBER OF BLOCKS NOT EXCEEDED 
          SX0    1R 
          LX6    60-12
          BX3    X6+X0
          POSTER SEV=FE,NR=E.CTMB,FMT=DPC,TXT=X3,RETURN=PH1SCAN 
  
*         FIRST OCCURRENCE. 
  
 DPCOM4   SX6    B1 
          SA6    A1                UPDATE N.COM 
          SA6    E.ORG             SET RECOVERY FLAG
          SA3    L.COM
          BX6    X2+X3
          SA6    A2                SET UP ORGTAB ENTRY 42/7L_NAME,18/FWA
          EQ     DPCOM6 
  
*         PREVIOUS OCCURRENCES. 
  
 DPCOM.P  SA1    O.COM
          IX7    X1+X2             O.COM+INDEX
          SA2    X7                FIRST WORD 
  
+         SX3    X2                EXTRACT LINK TO NEXT 
          IX7    X7+X3
          SA2    X7 
          NZ     X3,*-1            IF NOT LAST OCCURRENCE OF THE BLOCK
          SX7    X7 
  
*         ENTER A WORD FOR THE BLOCK NAME IN COMTAB ( X7 = LINK ADD ) 
  
 DPCOM6   SA7    LINKA
          SX0    B1 
          LX0    P.RB 
          SX5    B5 
          LX5    P.VAR
          BX7    X0+X5             VAR BIT AND RB 
          SA7    WORDBF 
  
          MX1    0
          ADDWD  COM,X1            ADD A ZERO WORD FOR THE PRESENT
  
*         PROCESS THE LIST OF NAMES 
  
          INITE 
 DPCOM7   CNAME  E56         PROCESS NAME 
  
          SA3    COMFLAG
          NZ     X3,DPCOM12A       IF COMMON ERROR FLAG 
  
*         SET FLAGS IN SYMTAB 
*         WORD A - COM AND DEF BITS 
*         WORD B - COM ORD IN RB FIELD AND BLK COM BIT
  
          SX0    V.COM+V.DEF
          BX7    X6+X2       SET TYPE (X6 .NZ. ONLY IF FIRST OCCURRENCE)
          BX6    X0+X1
          SA3    WORDBF      WORD B FLAGS 
          BX7    X3+X7
          SA6    A1          WORD A 
          LX1    59-P.COM 
          PL     X1,DPCOM9   IF NAME NOT ALREADY IN COMMON
          SA3    COMERR1
          NZ     X3,DPCOM11  IF ERROR FLAG ALREADY SET
          SX7    B1 
          SA7    A3          SET ERROR FLAG TO SYMTAB ORDINAL 
          EQ     DPCOM11
  
*         ADD LEGAL NAME TO COMTAB
  
 DPCOM9   SX1    B1 
          SA7    A2          WORD B 
          LX1    18 
          ADDWD  COM         ADD SYMTAB ORDINAL TO COMTAB 
          SA5    RSELECT
          ZR     X5,DPCOM10  IF NO REF MAP SELECTED 
          ADDREF SAVEB1,REF  ADD SYMTAB ORDINAL TO REF MAP
 DPCOM10  SA1    GNC
          SX6    X1+B5
          SA6    A1          INCREMENT NAME COUNT FOR THIS GROUP
  
 DPCOM11  GETE               GET SEPARATOR
          IF.NE  EL.(,DPCOM12      IF NAME NOT SUBSCRIPTED
          RJ     DIMEN
  
 DPCOM12  IF.EQ  EL.COMMA,DPCOM7   IF MORE NAMES,LOOP 
  
 DPCOM12A SA2    E.COM
          SA4    O.COM
          SX2    X2-1 
          IX7    X4+X2       BLOCK NAME ENTRY IN COMTAB 
          SA1    GNC         NUMBER OF VARS IN GROUP
          ZR     X1,DPCOM13A IF NOTHING BUT DUPLICATE NAMES IN GROUP
          SA3    X7 
          LX1    18 
          IX6    X1+X3
          SA4    LINKA
          SA6    A3          ADD NUMBER OF VARS TO COMTAB ENTRY 
          ZR     X4,DPCOM13  IF FIRST TIME
          SA5    X4 
          IX0    X7-X4       LINK=LOCF(THIS)-LOCF(LAST) 
          BX7    X5+X0       ADD LINK 
          SA7    A5 
 DPCOM13  BX6    X6-X6
          SA6    E.COM
          SA6    E.ORG
  
 DPCOM13A SA2    COMFLAG
          NZ     X2,PH1SCAN        IF COMMON ERROR FLAG 
  
          SA2    COMERR1
          ZR     X2,DPCOM14  IF NO DUPLICATE NAME 
          CALL   PSYM 
          POSTER SEV=FE,NR=E.CIVN,FMT=DPC,TXT=X3
  
 DPCOM14  GETE
          IF.EQ  EL.SLASH,DPCOML   IF MORE GROUPS 
          IF.EQ  EL.EOS,PH1SCAN    IF NO MORE GROUPS
          SB6    E56         NO SLASH - ERROR 
          EQ     DPCOM.E
  
 COMERR1  BSSZ   1                 DUPLICATE ERROR FLAG 
 COMFLAG  BSSZ   1                 COMMON ERROR FLAG
  
 E.COM    BSSZ   1                 SAVED LENGTH OF COMTAB 
 E.ORG    BSSZ   1                 SAVED LENGTH OF ORGTAB 
  
*** 
*         SCF - SET COMMON FLAGS
* 
*         SETS OR RESETS THE FLAGS: 
*                E.COM - SAVED COM TAB LENGTH 
*                E.ORG - ORDINAL OF BLOCK BEING PROCESSED WHEN AN 
*                ERROR OCCURED
* 
 SCF1     SX6    X2+B5
          SA6    A1                SAVE COM TAB LENGTH
 SCF      ENTRY.
          SA1    E.COM
          SA2    L.COM
          ZR     X1,SCF1           IF NO PREVIOUS ERRORS
          SA3    E.ORG
          SX6    X1-1 
          BX7    X7-X7
          SA6    A2                RESET COM TAB LENGTH TO ERROR FREE 
*                                  VALUE
          ZR     X3,SCF2     IF IN AN OLD BLOCK 
  
*         NEW BLOCK - CLEAR OUT ORGTAB ENTRY AND RESTORE N.COM
  
          SX6    X3-1 
          SA6    N.COM             RESTORE N.COM
          SA7    ORGTAB-1+X3       CLEAR THE ENTRY
          EQ     SCF
* 
*         OLD BLOCK - BREAK FORWARD LINK TO ERRONEOUS COMTAB ENTRY
* 
 SCF2     SA3    LINKA       _ LAST LINK ENTRY
          MX7    42 
          SA4    X3 
          BX6    X7*X4
          SA6    A4          BREAK LINK TO BAD ENTRY
          EQ     SCF         EXIT 
          TITLE              DPEQU - PROCESS EQUIVALENCE STATEMENTS 
  
*** 
*         DPEQU - EQUIVALENCE STATEMENT PROCESSOR 
* 
*         SYNTAX CHECK STATEMENT AND FORM EQ LIST FOR THE 
*         EQUIVALENCE GROUPS. 
* 
*         THE FORMAT OF AN EQ LIST ENTRY IS:  
*          12/GORD,48/2*SYMORD
*          3/N.SUBS,3/0,18/SUB C ,18/SUB B ,18/SUB A
* 
*          WHERE GORD IS THE ORDINAL OF THE NAME IN THE GROUP ( 1,2,..) 
* 
  
 E.ESE    EQU    91                SUBSCRIPT ERROR
 E.E1N    EQU    92                1 NAME IN THE GROUP
 E.EBS    EQU    93                BAD SYNTAX 
          SPACE  3
*         ERROR EXITS 
  
 DPEQU.ES SB6    E.EBS             BAD SYNTAX 
          EQ     CDN.E0 
  
 DPEQU.SE SB6    E.ESE             SUBSCRIPT ERROR
          EQ     DPEQU.EX 
  
 DPEQU.E1 SB6    E.E1N             1 NAME IN THE GROUP
          EQ     DPEQU.EX 
  
 DPEQU.EX SA4    SNAME
          EQ     CDN.E0 
  
          USE    /MACBUF/ 
 EQVTEMP  BSS    1                 A WORD TO HOLD THE FIRST WORD OF EQV 
          USE    *
          SPACE  4
*         ENTRY POINT FROM PH1CTL 
  
 DPEQU    SX6    B5 
          LX6    P.FP 
          SA6    FPFLAG            F.P. S NOT ALLOWED 
  
 DPEQUL   RJ     SEF               SAVE EQV TABLE LENGTH
          GETE                     FIRST E-LIST ELEMENT 
          IF.NE  EL.(,DPEQU.ES     IF NOT A ( 
          MX7    0
          SA7    GNC               CLEAR THE GROUP NAME COUNT 
          EJECT 
*         PROCESS AN EQUIVALENCE GROUP
  
 DPEQU.L  CNAME  E.EBS             PROCESS NAME 
          MX0    1
          IX7    X6+X2             ADD TYPE TO WORD B 
          LX0    1+P.VAR
          BX7    X0+X7             SET VAR BIT
          SA7    A2 
  
*         MAKE AN EQV LIST ENTRY FOR THE NAME 
  
          SA4    GNC
          SX7    X4+B5             GNC = GNC+1
          SA7    A4 
          SX0    B1+B1
          SB7    X7 
  
          MX4    48                 PX1   B7,X0 
          SX5    B7 
          BX2    -X4*X5 
          MX3    12 
          LX2    48 
          BX6    -X3*X0 
          BX1    X2+X6              12/P(GORD), 48/2*SYMORD 
          ADDWD  EQV,X1            ADD FIRST WORD OF EQV TABLE ENTRY
          MX1    0
          ADDWD                    AND CLEAR SECOND WORD
          SX6    A6 
          SA6    EQVTEMP           SAVE ADDRESS OF SECOND WORD
  
          SA5    RSELECT
          ZR     X5,DPEQU2         IF R = 0 
          ADDREF SAVEB1,REF        ADD A REFERENCE FOR THE NAME 
  
 DPEQU2   GETE                     NEXT AFTER THE NAME
          IF.NE  EL.(,DPEQU4       IF NOT A ( 
          MX6    0
          SA6    N.SUBS            CLEAR SUBSCRIPT COUNT
  
*         PROCESS SUBSCRIPT LIST
  
 DPEQU.SL NEXTE                    SUBSCRIPT
          IF.NE  CON,DPEQU.SE      IF NOT A CONSTANT
          UPDATE
          AX1    45 
          SX2    X1-T.INT 
          SX3    X1-T.OCT 
          ZR     X2,DPEQU3         IF INTEGER 
          NZ     X3,DPEQU.SE       IF NOT OCTAL 
  
 DPEQU3   SB1    -B5
          BX1    X4 
          RJ     CONVERT           CONVERT THE CONSTANT TO BINARY 
          ZR     X1,DPEQU.SE       ERROR IF ZERO
          BX6    X1 
          AX1    17 
          NZ     X1,DPEQU.SE       ERROR IF TOO BIG 
          SA2    N.SUBS 
          SX7    X2+B5             N.SUBS = N.SUBS+1
          SA7    A2 
          SX3    X2-3 
          PL     X3,DPEQU.SE       IF TOO MANY SUBSCRIPTS 
          SA6    DIMTAB+X2         SAVE THE SUBSCRIPT 
          GETE                     NEXT AFTER THE SUBSCRIPT 
          IF.EQ  EL.COMMA,DPEQU.SL   LOOP IF A COMMA
  
          IF.NE  EL.),DPEQU.SE     IF NOT A ) 
          UPDATE
  
*         ADD SECOND WORD TO EQV LIST 
  
          SB2    X7                NUMBER OF SUBSCRIPTS 
          SB1    B0 
          SB3    B0                CLEAR SHIFT COUNT
          LX7    57                POSITION NUMBER OF SUBS
  
 DPEQUS   SA3    DIMTAB+B1         SUBSCRIPT
          SB1    B1+B5             ADVANCE INDEX
          LX4    B3,X3
          SB3    B3+18
          BX7    X7+X4
          LT     B1,B2,DPEQUS 
          SA2    EQVTEMP           ADDRESS OF WORD 2
          SA7    X2 
          GETE                     NEXT AFTER THE ) 
  
 DPEQU4   IF.EQ  EL.COMMA,DPEQU.L  LOOP IF A COMMA
          IF.NE  EL.),DPEQU.ES     IF NO )
          SA2    GNC
          SX0    X2-1 
          ZR     X0,DPEQU.E1       IF ONLY ONE NAME IN THE GROUP
  
 DPEQU7   GETE
  
 DPEQU8   MX7    0
          SA7    E.EQV             CLEAR SAVED EQV TAB LENGTH 
          NEXTE 
          IF.EQ  EL.EOS,PH1SCAN    EXIT IF EOS
          UPDATE
          IF.EQ  EL.COMMA,DPEQUL   LOOP IF A COMMA
  
          EQ     DPEQU.ES          SYNTAX ERROR 
          SPACE  3
 E.EQV                             SAVED EQV TBL LENGTH 
*** 
*         SEF - SET EQUIVALENCE FLAG
*         SAVE LENGTH OF EQV TAB IN CASE OF ERRORS
* 
 SEF1     SX6    X2+B5
          SA6    A1                E.EQV = L.EQV+1
 SEF      ENTRY.
          SA1    E.EQV
          SA2    L.EQV
          ZR     X1,SEF1           IF NO PREVIOUS ERRORS
          SX6    X1-1 
          SA6    A2 
          EQ     SEF
          TITLE              DPTYP - PROCESS TYPE STATEMENTS
*** 
*         DPTYP - TYPE STATEMENT PROCESSOR
* 
*         ENTER NAMES IN SYMTAB AND SET TYPE TO MODE SPECIFIED BY 
*         TYPE STATEMENT
* 
 ST.ECS   EQU    5                 STATEMENT TYPE OF ECS STATEMENT
          SPACE  3
  
 DPTYP    MX7    0
          SA5    ATYPE
          SA7    FPFLAG            F.P. S ALLOWED 
          SX4    X5-ST.ECS
          NZ     X4,DPERRO         IF NOT *TYPE ECS*
          POSTER SEV=INF,NR=E.SFO  *STATEMENT FORM OBSOLETE*
 DPERRO   SA5    ATYPE
          SB7    X5-T.DBL 
          NG     B7,DPTYP0         IF SINGLE PRECISION
          GT     B7,B5,DPTYP0      IF NOT TYPE DOUBLE OR COMPLEX
          MX6    1
          SA6    =XDBLDECL         /DOUBLE OR COMPLEX DECLAR/ FLAG ON 
  
*         PROCESS THE LIST OF NAMES 
  
 DPTYP0   INITE                    INITIALIZE E-LIST POINTER
  
 DPTYPL   CNAME  E.BADSYN          PROCESS NAME 
          NZ     B7,DPTYP.P        IF NOT FIRST OCCURRENCE
          ZR     X5,DPTYP.N        IF NO PRIOR OCCURRENCE IN DEBUG STMT 
  
          SA2    A2                GET WORD B FROM SYMTAB 
          BX7    X6                SAVE CURRENT TYPE
          CALL   NTYPE             GET NATURAL TYPE 
          BX3    X6-X7
          NZ     X3,DPTYP.I        IF PRESENT TYPE " NATURAL TYPE 
  
          MX0    L.SNT
          SA3    ATYPE             PLACE DECLARED TYPE IN SNT FIELD 
          SX4    X3-ST.ECS
          ZR     X4,DPTYP5         IF STATEMENT TYPE ECS
          LX0    L.SNT+P.SNT
          BX2    -X0*X2            REMOVE OLD VALUE OF SNT
          LX3    P.SNT
          IX7    X3+X2
          SA7    A2                UPDATE WORD B
          EQ     DPTYP1 
  
 DPTYP.P  RJ     =XNTYPE           GET NATURAL TYPE 
          NE     B1,B5,DPTYP.P1    IF NOT A FUNCTION
          SA3    =XVALUE.          ORDINAL OF *VALUE.* IN SYMTAB
          SA5    SYM1              FWA OF SYMTAB
          LX3    1                 2*ORD OF *VALUE.*
          IX2    X5-X3             (SYM1)-(VALUE.)=ADDR OF VALUE. WORD A
          SA2    X2-1              SYMTAB WORD B OF *VALUE.*
 DPTYP.P1 MX7    L.TYP
          BX5    X7*X2             EXTRACT PRESENT TYPE 
          IX4    X6-X5
          BX2    -X7*X2            REMOVE TYPE
          NZ     X4,DPTYP.I        IF PRESENT TYPE " NATURAL TYPE 
  
 DPTYP.N  SA3    ATYPE             MODE OF TYPE STMT
          SX4    X3-ST.ECS
          ZR     X4,DPTYP5         IF STATEMENT TYPE ECS
          LX3    P.TYP
          BX6    X3+X2             ADD TYPE TO WORD B 
          SA6    A2 
          NE     B1,B5,DPTYP1      IF NOT A FUNCTION
          MX7    1
          LX3    L.TYP
          SX4    X3-T.DBL 
          BX6    -X4*X7 
          LX6    1
          SX7    X6+B5
          SA7    =XFUNTYPE         NR WORDS IN FUNCTION RESULT
  
 DPTYP1   SA5    RSELECT
          ZR     X5,DPTYP2         IF R = 0 
          ADDREF B1,REF            A REFERENCE FOR THE NAME 
  
 DPTYP2   GETE                     SEPARATOR
          IF.NE  EL.(,DPTYP4       IF NEXT IS NOT A ( 
  
          SA3    SYM1 
          SA1    SAVEB1 
          SB1    X1 
          SA0    X3 
          LX1    1
          IX5    X3-X1
          SA2    X5-1              WORD B 
          BX3    X2 
          LX3    59-P.EXT 
          MI     X3,CDN.E3         IF PRIOR OCCURRENCE IN EXTERNAL STMT 
          EQ     B1,B5,CDN.E4      IF ILLEGAL USE OF FUNCTION NAME
  
          MX0    L.TYP
          BX3    X0*X2
          LX3    L.TYP             TYPE FIELD 
          SX4    X3-T.DBG 
          NZ     X4,DPTYP3         IF NOT AN UNUSED DEBUG VAR 
  
*         PREVIOUS OCCURANCE IN A DEBUG STMT, CALL CFO TO CHECK BIT SETT
  
          BX3    X2 
          LX3    P.TYP-P.SNT
          BX6    X0*X3             X6 = NATURAL TYPE
          MX5    L.DBGI 
          LX5    L.DBGI+P.DBGI
          BX7    X5*X2             SET UP X7
          MX0    60-12
          BX2    X0*X2             X2 = P- FIELD
          CFO    VAR               CHECK SETTING OF DEBUG BITS
          MX0    L.TYP
          LX0    L.TYP+P.TYP
          BX2    -X0*X2      REMOVE OLD TYPE
          IX7    X6+X2             ADD TYPE 
          SA7    A2 
          GETE                     RESTORE SEPARATOR
  
 DPTYP3   RJ     DIMEN             PROCESS DIMENSION SPECIFICATION
  
 DPTYP4   IF.EQ  EL.COMMA,DPTYPL   LOOP IF A ,
          IF.EQ  EL.EOS,PH1SCAN    EXIT IF EOS
  
          SB6    E.BADSEP 
          EQ     CDN.E0 
  
 DPTYP5   SA2    A2                REFETCH SYMTAB WORD B
          EQ     B1,B5,CDN.E4      IF ILLEGAL USE OF FUNCTION NAME
          SX7    3
          SA7    =XLEVEL2 
          SX6    B5 
          LX6    P.LCM
          BX2    X2+X6
          SA7    =XLEVEL           /LEVEL STMT APPEARED/ FLAG TO -YES-
          LX7    P.LVL
          BX6    X2+X7       LEVEL = 3
          SA6    A2 
          EQ     DPTYP1 
  
*         INFORMATIVE ERROR FOR PREVIOUSLY TYPED NAME 
  
 DPTYP.I  POSTER SEV=INF,NR=E.TRT,FMT=ELIST,TXT=SNAME,RETURN=DPTYP1 
          TITLE              DPDIM - PROCESS DIMENSION STATEMENTS 
 E.DNT    EQU    287               ILLEGAL SYNTAX 
 E.DTMS   EQU    43                TOO MANY SUBSCRIPTS
 E.DBCON  EQU    44                ILLEGAL SUBSCRIPT
 E.DDD    EQU    45                PREVIOUSLY DIMENSIONED 
 E.DIVD   EQU    46                IMPROPER VARIABLE DIMENSIONS 
 E.CUN    EQU    48                CONFLICTING USE OF A NAME
  
          USE    /MACBUF/ 
 TEMP                              A GENERAL TEMPORARY
 N.SUBS                            NUMBER OF SUBSCRIPTS 
 VARSUB                            VARIABLE SUBSCRIPTS FLAG 
 DIMTAB   BSS    3                 SUBSCRIPTS ( VALUE OR SYMTAB ORD ) 
 GNC                               GROUP NAME COUNT 
          USE    *
          SPACE  3
*** 
*         DPDIM - DIMENSION STATEMENT PROCESSOR 
* 
          SPACE  3
 DPDIM    INITE                    INITIALIZE E-LIST POINTER
          MX6    0
          SA6    FPFLAG            ALLOW F.P. S 
  
 DPDIML   CNAME  E.DNT             PROCESS NAME 
          BX7    X6+X2             SET TYPE (X6 .NZ. ONLY IF 1ST OCCUR) 
          SA7    A2 
  
          SA5    RSELECT
          ZR     X5,DPDIM1         IF R = 0 
          ADDREF B1,REF            ADD A REFERENCE FOR THE NAME 
  
 DPDIM1   GETE                     NEXT E-LIST ITEM, A (
          SB6    E.DNT
          IF.NE  EL.(,CDN.E0       IF NO (
          RJ     DIMEN             PROCESS DIMENSION DECLARATION
  
          IF.EQ  EL.COMMA,DPDIML   LOOP IF A COMMA
  
          IF.EQ  EL.EOS,PH1SCAN    EXIT IF EOS
  
          SB6    E.BADSEP          BAD SEPARATOR
          EQ     CDN.E0 
          TITLE  DPLEV - PROCESS LEVEL STATEMENTS 
 M.LVL    EQU    3                 MAXIMUM ALLOWABLE LEVEL NUMBER 
 E.BADLEV EQU    290               BAD LEVEL NUMBER SPECIFIED 
 E.SFO    EQU    295               STATEMENT FORM OBSOLETE
 EASAST   EQU    299               NON-ANSI STATEMENT 
  
          ENTRY  DPLEV
 DPLEV    MX7    0
          SA7    FPFLAG            PROCESS FORMAL PARAMETERS
          MX6    1
          SA6    =XLEVEL           /LEVEL STMT FOUND/ FLAG ON 
  
          POSTERR  NR=EASAST,SEV=ANSI 
          GETE
          IF.NE  CON,DPLEV.B       IF NOT A CONSTANT
  
          AX1    45 
          SX2    X1-T.INT 
          NZ     X2,DPLEV.B        IF NOT A SIMPLE INTEGER CONSTANT 
          SB1    -B5
          BX1    X4 
          RJ     CONVERT           CONVERT THE INTEGER
  
          NG     X1,DPLEV.B        IF VALUE < 0 
          ZR     X1,DPLEV.B        IF LEVEL NUMBER = 0
          SX2    X1-M.LVL-1 
          PL     X2,DPLEV.B        IF > MAXIMUM LEVEL 
          SA2    SELIST 
          SX6    X2-1 
          SA6    A2+
  
 #DAL     IFEQ   .DAL,0      .ZR. IF LCM DIRECT ACCESS NOT ALLOWED
          SX2    X1-3 
          NZ     X2,DPLEV3   IF NOT LCM-RESIDENT
          SX2    B5 
          LX2    P.LCM-P.LVL
          BX1    X1+X2
  
 #DAL     ELSE
          SX2    X1-2 
          MI     X2,DPLEV3   IF NOT LCM RESIDENT
          SX6    B5 
          LX6    P.LCM-P.LVL
          BX1    X1+X6
 #DAL     ENDIF 
  
          SX6    B5+B5
          SA6    =XLEVEL2 
  
 DPLEV3   LX1    P.LVL
          BX6    X1 
 DPLEV0   SA6    LVL               SET THE LEVEL VALUE
          GETE
          IF.NE  EL.COMMA,DPLEV.A  IF NOT FOLLOWED BY A COMMA 
  
 DPLEV1   CNAME  E.BADSYN          PROCESS NAME 
          MX0    60-L.LVL 
          BX7    X6+X2             SET TYPE IF FIRST TIME 
          SX5    B5 
          LX0    P.LVL             POSITION MASK
          BX1    -X0*X7             EXTRACT DECLARED LEVEL
          SA3    LVL
          ZR     X1,DPLEV1A        IF NO PREVIOUS LEVEL 
          IX1    X3-X1             COMPARE PREVIOUS LEVEL WITH NEW ONE
          NZ     X1,DPLEV.C        IF DIFFERENT LEVELS
  
 DPLEV1A  BX1    X3+X7       INSERT SPECIFIED LEVEL 
          LX5    P.VAR
          BX7    X1+X5       SET -VAR- BIT
          SA7    A2 
  
 DPLEV1B  SA5    RSELECT
          ZR     X5,DPLEV2         IF R = 0 
          ADDREF B1,REF            ADD A REFERENCE FOR THE NAME 
  
 DPLEV2   GETE
          IF.EQ  EL.COMMA,DPLEV1   IF A COMMA 
  
          IF.EQ  EL.EOS,PH1SCAN    IF EOS 
  
 DPLEV.A  SB6    E.BADSEP          BAD SEPARATOR
          EQ     CDN.E0 
  
 DPLEV.B  SB6    E.BADLEV          BAD LEVEL NUMBER 
          GETE
          EQ     CDN.E0 
  
 DPLEV.C  POSTER SEV=INF,NR=E291,FMT=ELIST,TXT=SNAME,RETURN=DPLEV1B 
  
          USE    /MACBUF/ 
 LVL                               LEVEL BITS FOR SETTING WORD B
          USE    *
          TITLE              DIMEN - PROCESS A ARRAY DECLARATION
*** 
*         DIMEN - PROCESS ARRAY DECLARATION 
* 
*         ON ENTRY: 
*                PREVIOUS CALL TO CDN 
*                A ( FOLLOWS THE NAME 
* 
*         ON EXIT:  
*                MACRO "GETE" CALLED TO SET UP REGISTERS TO ITEM
*                AFTER CLOSING PAREN
* 
*         FORMS A DIM TAB ENTRY FOR THE NAME AND DIMENSIONS 
*         FORMAT: 
*          6/0,18/SYMTAB ORD,36/0 
*          3/N.SUBS,3/V(ABC),18/NUMBER OF WORDS,18/SUB B,18/SUB A 
*          WHERE V(ABC) IS THE VARIABLE SUBSCRIPT FLAG FIELD
* 
  
 DIMEN.B  SB6    E.DBCON           BAD CONSTANT SUBSCRIPT 
  
 DIMEN.E  SA4    SNAME
          POSTER SEV=FE,NR=**,RETURN=PH1SCAN
* 
DIMEN.G   BX7    X2+X6
          SA7    A2              STORE WORD B 
          EQ     DIMEN.E
          SPACE  3
 DIMENX   GETE                      E-LIST ELEMENT AFTER )
  
 DIMEN
          MX7    0
          SA7    N.SUBS 
          SA7    VARSUB            CLEAR FLAGS
  
*         PROCESS DIMENSION DECLARATION LIST
  
  
 DIMEN.L  NEXTE                    SUBSCRIPT ( CONSTANT OR NAME ) 
          UPDATE
          SA2    N.SUBS 
          SX7    X2+B5             N.SUBS = N.SBUS+1
          SA7    A2 
          SX3    X2-3 
          SB6    E.DTMS 
          PL     X3,DIMEN.E        IF TOO MANY DIMENSIONS 
  
          IF.EQ  NAME,DIMEN.V      IF A NAME
          IF.NE  CON,DIMEN.B       IF NOT A CONSTANT
  
*         PROCESS CONSTANT DIMENSION
  
          AX1    45 
          SX2    X1-T.INT 
          SX3    X1-T.OCT 
          ZR     X2,DIMEN.C        IF TYPE INTEGER
          NZ     X3,DIMEN.B        IF NOT TYPE OCTAL
  
 DIMEN.C  SB1    -B5
          BX1    X4 
          RJ     CONVERT           CONVERT THE CONSTANT 
  
          BX6    X1 
          MX0    0
          AX1    17 
          ZR     X6,DIMEN.B        IF ZERO
          NZ     X1,DIMEN.B        IF TOO BIG 
          EQ     DIMEN.S           GO STORE THE SUBSCRIPT 
  
*         PROCESS VARIABLE DIMENSION
  
 DIMEN.V  SYMBOL                   GET SYMTAB ORDINAL 
 DIMEN.V1 SB6    E.DIVD            FIRST OCCURRENCE, NOT AN F.P.
          EQ     DIMEN.G
  
          BX3    X1 
          LX3    59-P.FP
          PL     X3,DIMEN.V1       IF NOT A F.P.
  
 VNRL     BIT    P.VAR-P.RL 
          SX4    VNRL+1            SET VAR BIT
          LX4    P.RL              AND SET RL = 1 TO FLAG 
          BX7    X4+X2             USED AS SUBSCRIPT IN VARDIM ARRAY
          SA7    A2 
  
          SX0    1S3               VARIABLE SUBSCRIPT FLAG
          SX6    B1 
  
*         SAVE DIMENSION INFO 
  
 DIMEN.S  SA3    N.SUBS 
          SA4    VARSUB 
          SB3    X3 
          AX0    B3,X0             POSITION FLAG
          BX7    X0+X4
          SA6    DIMTAB-1+X3
          SA7    A4 
  
          ZR     X0,DIMEN.N        IF NOT A VARIABLE SUBSCRIPT
          SA7    VARDIM            SET FOR VARDIM CHECK IN DPCLOSE
          SA5    RSELECT
          ZR     X5,DIMEN.N 
          ADDREF B1,REF            ADD A REFERENCE FOR THE NAME 
  
 DIMEN.N  GETE                     SEPARATOR
          IF.EQ  EL.COMMA,DIMEN.L  LOOP IF A ,
  
          SB6    E.DNT
          IF.NE  EL.),DIMEN.E      IF NO )
          UPDATE                   ADVANCE PAST ) 
  
  
*         PROCESS ARRAY NAME
  
          SA3    SAVEB1            SYMTAB ORDINAL 
          SA4    SYM1 
          SB1    X3 
          LX3    1
          IX6    X4-X3
          SA1    X6                WORD A 
          SA2    A1-B5             WORD B 
  
          BX3    X1 
          LX3    59-P.DIM 
          PL     X3,DIMEN.F        IF NOT DOUBLY DIMENSIONED
          POSTER SEV=INF,NR=E.DDD,FMT=ELIST,TXT=SNAME,RETURN=DIMENX 
  
*         CHECK FOR VARIABLE SUBSCRIPTS AND ARRY NAME NOT AN F.P. 
  
 DIMEN.F  SA5    VARSUB 
          ZR     X5,DIMEN1         IF NO VARIABLE SUBSCRIPTS
          BX3    X1 
          LX3    59-P.FP
          MI     X3,DIMEN1   IF F.P.
          SB6    E.DIVD 
          EQ     DIMEN.E
  
*         SET UP DIM BIT AND DIMP ORD TO BE STORED IN SYMTAB AFTER ALL
*         THE POSSIBLE ERROR CHECKING.
  
 DIMEN1   SA3    L.DIM
          SX4    V.DIM
          MX5    1
          SX0    X3+2              NEXT DIM ORD 
          LX0    P.DIMP-1 
          BX6    X4+X1             SET DIM BIT
          LX5    1+P.VAR
          IX7    X0+X2             ADD DIMP ORDINAL 
          BX1    X5+X7
  
*         FORM SECOND WORD OF THE ENTRY 
  
          SA4    N.SUBS 
          SA5    VARSUB 
          SB4    X4                B4 = N.SUBS
          SB6    X5                B6 = VAR SUBS  FLAG
          LX4    3
          BX7    X4+X5
          LX7    54                3/N.SUBS,3/V(ABC),54/0 
  
          SB2    B0                CLEAR SUBSCRIPT INDEX
          SX0    B5 
          SB3    B0                CLEAR SHIFT COUNT
          PX0    X0                INITIALIZE PRODUCT 
  
 DIMEN3   SA3    DIMTAB+B2         FETCH SUBSCRIPT
          SB2    B2+B5
          PX5    X3 
          LX4    B3,X3
          DX0       X5*X0 
          BX7    X4+X7             ADD SUBSCRIPT TO SECOND WORD 
          SB3    B3+18
          LT     B2,B4,DIMEN3 
  
          NZ     B6,DIMEN4         IF VARIABLE SUBSCRIPTS 
          UX2    X0                INTEGER FORM OF RESULT 
          AX2    17 
          NZ     X2,DIMEN.B        IF WORD COUNT EXCEEDS CORE SIZE
          UX2    X0 
          MX3    17 
          LX3    17+36
          BX7    -X3*X7            REMOVE THIRD SUBSCRIPT 
          LX2    36 
          IX7    X2+X7             ADD IN TOTAL 
  
*         ADD 2 WORD ENTRY FOR ARRAY TO DIMTAB
  
 DIMEN4   SA7    DIMTAB            SAVE SECOND WORD 
          SA6    A1                UPDATE SYMTAB ENTRY FOR WORD A 
          BX7    X1 
          SA7    A2                FOR WORD B 
          SX1    B1                SYMTAB ORDINAL 
          LX1    36 
          ADDWD  DIM,X1            FIRST WORD 
          ADDWD  ,DIMTAB           AND SUBSCRIPTS 
          EQ     DIMENX 
  
          TITLE              DPIMP - PROCESS IMPLICIT STATEMENT 
***       DPIMP - PROCESS IMPLICIT STATEMENT
* 
* 
* 
* 
*         THE PREVIOUS TYPE IS CHECKED TO SEE IF IT IS A HEADER CARD
*         AND IF THERE IS A SYNTAX ERROR.  IN EITHER CASE A FATAL ERROR 
*         IS ISSUED.  THE NATURAL TYPE TABLE IS CLEARED, AND AS 
*         CHARACTER BOUNDS ARE IMPLICITED, THEY ARE ENTERED IN THE
*         TABLE.  IN CASE OF FATAL ERRORS IN PROCESSING, THE ORIGINAL 
*         NATURAL BITS ARE RESTORED.  AT THE END OF PROCESSING, THE 
*         NATURAL BITS WHICH HAVE NOT BEEN IMPLICITED ARE ENTERED 
*         IN THE TABLE, FORMAL PARAMETERS ARE IMPLICITED, 
*         INFORMATIVE DIAGNOSTICS ARE ISSUED,IF ANY, AND THE
*         NON-ANSI DIAGNOSTIC IS ISSUED.
* 
*         REGISTERS USED: 
*                B1           TYPE CURRENTLY BEING IMPLICITED 
*                             (SET TO ATYPE UPON ENTRY) 
*                X0           BITS 58 - 33 HOLD THE BITS WHICH HAVE 
*                             BEEN IMPLICITED SO FAR. 
*                X7           IN BITS 58 - 33 THE BITS TO BE IMPLICITED 
*                             A CERTAIN TYPE
* 
* 
* 
 DPIMP    SA1    LASTTYP      BITS 37-20 LAST ATYPE;17-0 LAST STMT TYPE 
          AX1    1            IF LAST TYPE 0 OR 1  O.K. 
          SB4    X1 
          ZR     B4,IMP2     IF LAST STATEMENT WAS PROG UNIT HEADER 
          POSTER SEV=FE,NR=E109,RETURN=PH1SCAN *DECL OUT OF SEQUENCE* 
  
 IMP2     SB5    1
          GETE
          IF.EQ  EL.(,IMP3
          POSTER SEV=FE,NR=E89,FMT=ELIST,TXT=X4,RETURN=PH1SCAN
 IMP3     SA1    ATYPE
          MX7    0
          BX0    X0-X0       (X0) = INITIAL *ALREADY IMPLICITED* BITS 
          SB1    X1          (B1) = FIRST IMPLICIT TYPE CODE
          SA7    IMPTYP 
          SA7    A7+B5
          SA7    A7+B5        ZERO OUT THE NATURAL TYPE TABLE 
  
*         MAIN LOOP.
  
 DPIMP.1  SB3    B1-T.DBL 
          MI     B3,DPIMP.10       IF ANY SINGLE PRECISION TYPE 
          GT     B3,B5,DPIMP.10    IF NOT TYPE DOUBLE OR COMPLEX
          MX6    1
          SA6    =XDBLDECL   /DOUBLE OR COMPLEX DECLAR/ FLAG ON 
  
*         FIRST LETTER SCAN.
  
 DPIMP.10 ADVIN 
          IF.NE  EL.(,ERR1    UNEXPECTED SEPARATOR
 DPIMP.61 ADVIN 
 DPIMP.6  IF.NE  NAME,ERR2    ILLEGAL CHARACTER BOUND 
          AX1    24 
          MX5    60-6 
          SX2    X1-3R
          NZ     X2,ERR2      IF NOT A SINGLE CHARACTER 
          AX1    18 
          BX2    -X5*X1       MASK OFF CHARACTER BOUND
          ADVIN 
          IF.EQ  EL.MINUS,SETRNGE 
  
*         SET UP MASK FOR A SINGLE LETTER 
  
          MX3    1
          SB7    X2-59-1
          AX3    X3,B7        SHIFT BIT INTO POSITION 
          BX7    X7+X3        MASK INTO CHARACTER MASK
          IF.EQ  EL.COMMA,DPIMP.61
 DPIMP.4  IF.NE  EL.),ERR1    UNEXPECTED SEPARATOR
  
*         PUT THE MASK IN THE IMPTYP TABLE
  
          SX1    B1           TYPE TO BE IMPLICITED 
          MX5    60-1 
          BX2    -X5*X1       INDICATE UPPER OR LOWER HALF OF TBL WORD
          AX1    1
          SB3    X1           INDICATE WHICH TABLE WORD 
          BX1    X7 
          SA4    IMPTYP+B3
          ZR     X2,DPIMP.91
          AX1    58-32        SHIFT THE IMPLICIT MASK IF LOWER HALF 
 DPIMP.91 BX3    X1*X4        BITS ALREADY IMPLICITED THIS TYPE 
          BX1    X1-X3        ELIMINATE FROM ALIGNED MASK 
          ZR     X2,DPIMP.92
          SB2    58-32
          LX7    X1,B2        ELIMINATE FROM UNALIGNED MASK 
 DPIMP.92 BX3    X7*X0        BITS ALREADY IMPLICITED ANOTHER TYPE
          ZR     X3,DPIMP.93
          BX7    X7-X3        ELIMINATE FROM UNALIGNED MASK 
          ZR     X2,DPIMP.94
          AX3    58-32
 DPIMP.94 BX1    X1-X3        ELIMINATE FROM ALIGNED MASK 
          SA5    ERRORWD
          MX6    1
          LX6    59 
          BX6    X6+X5
          SA6    A5           ISSUE INFORMATIVE DIAGNOSTIC
 DPIMP.93 BX6    X4+X1        MASK INTO TABLE 
          BX0    X0+X7        ADD TO TOTAL IMPLICITED BITS
          BX0    X0+X3        ADD TO TOTAL IMPLICITED BITS
          SA6    A4 
          ADVIN 
          IF.EQ  EL.COMMA,DPIMP.2 
          IF.NE  EL.EOS,ERR1  UNEXPECTED SEPARATOR
  
*         RESTORE THE NATURAL BITS WHICH HAVE NOT BEEN IMPLICITED 
  
          SA2    NRB          NATURAL REAL BITS 
          BX6    -X0*X2       N R B  NOT IMPLICITED 
          AX0    58-32
          SA3    IMPTYP+1     2ND WORD OF NAT. TYPE TABLE 
          MX2    6
          BX6    X6+X3        MASK REMAINING NRB INTO TABLE WD
          LX2    24+1         NATURAL INTEGER BITS
          SA4    A3-B5        1ST WORD OF NATURAL TYPE TABLE
          BX7    -X0*X2       N I B  NOT IMPLICITED 
          SA6    A3           STORE BACK INTO TABLE 
          BX7    X7+X4        MASK REMAINING NIB INTO TABLE WD
          SA7    A4           STORE BACK INTO TABLE 
          EQ     DPIMP.P
  
*         SET UP MASK FOR A RANGE OF LETTERS
  
 SETRNGE  ADVIN 
          IF.NE  NAME,ERR2    ILLEGAL CHARACTER BOUND 
          AX1    24 
          SB7    X1-3R
          AX1    18 
          NZ     B7,ERR2      IF NOT A SINGLE CHARACTER 
          MX5    60-6 
          BX1    -X5*X1       MASK OFF CHARACTER BOUND
          IX3    X1-X2        COMPUTE LENGTH OF RANGE - 1 
          PL     X3,DPIMP.5   IF VALID RANGE
          BX3    -X3          COMPLEMENT THE LENGTH - 1 
          BX2    X1 
          SA5    ERRORWD
          MX6    1
          BX6    X6+X5
          SA6    A5           ISSUE INFORMATIVE DIAGNOSTIC
 DPIMP.5  SB7    X3           LENGTH OF RANGE - 1 
          MX5    1
          SB6    X2-59-1
          AX3    X5,B7        SET A MASK THE LENGTH OF RANGE
          AX3    X3,B6        SHIFT TO ALIGN MASK WITH LETTER POSITIONS 
          BX7       X7+X3     OR INTO MASK BEING BUILT
          ADVIN 
          IF.NE  EL.COMMA,DPIMP.4 
          EQ     DPIMP.61 
  
*         DETERMINE THE NEXT TYPE TO BE IMPLICITED. 
  
 DPIMP.2  SB4    4
          ADVIN 
          SB1    B0-B5
          IF.NE  NAME,ERR3    ILLEGAL TYPE SPECIFICATION
          MX7    0            CLEAR REGISTER TO HOLD IMPLICIT BITS
 DPIMP.3  SA2    B1+TYPETBL+1 LOAD COMPARE WORD FROM TABLE OF TYPES 
          SB1    B1+B5
          IX3    X2-X1
          ZR     X3,DPIMP.1   IF A MATCH
          GT     B1,B4,ERR3   AT THE END OF THE TABLE AND NO MATCH
          EQ     DPIMP.3
  
*         IN CASE OF FATAL ERROR, RESTORE ALL NATURAL BITS
  
 DPIMP.N  MX6    6
          SA3    NRB          NATURAL REAL BITS 
          LX6    24+1         NATURAL INTEGER BITS
          BX7    X3 
          SA6    IMPTYP 
          SA7    A6+B5
          EQ     DPIMP.I
  
*         IMPLICITLY TYPE FORMAL PARAMETERS OF A SUBROUTINE OR
*         FUNCTION , AND THE FUNCTION NAME IF IT WAS NOT
*         EXPLICITLY TYPE IN THE PROGRAM HEADER CARD. 
  
 DPIMP.P  SA1    PROGRAM
          UX7    B3,X1
          ZR     X1,DPIMP.I  IF A BLOCK DATA SUBPROGRAM 
          ZR     B3,DPIMP.I  IF A MAIN PROGRAM
          SA1    SYM1         START OF THE SYMBOL TABLE 
          SA2    X1-2 
          SB6    B5+B5        SYMBOL TABLE INCREMENT
          MX5    L.TYP
          SA1    N.FP         NUMBER OF FORMAL PARAMETERS 
          SB4    B6           START AT ORDINAL 2
          LX1    1
          SA3    LASTTYP
          SB7    X1+B6        LIMIT TO BE NATURAL TYPED 
          BX1    X2 
          EQ     B3,B5,DPIMP.P1 
  
*         PROCESS FUNCTION NAME 
  
          PL     X3,DPIMP.P1  FUNCTION EXPLICITLY TYPED 
          RJ     NTYPE        GET NATURAL TYPE OF FUNCTION NAME 
          SA1    =XVALUE. 
          LX1    1            2 * ORD 
          SB3    X1-1 
          SA4    A2-B3
          BX2    -X5*X4 
          BX1    X5*X4        GET TYPE FIELD
          LX1    L.TYP
          SX7    B5 
          LX6    -P.TYP 
          SX0    X6-T.DBL 
          LX6    P.TYP
          MI     X0,DPIMP1   IF SINGLE PRECISION
          SX7    B5+B5
 DPIMP1   SA7    =XFUNTYPE   FUNTYPE = NUMBER OF WORDS IN FUNCTION RESUL
          SX0    X1-T.DBG 
          NZ     X0,DPIMP.P3  NOT UNUSED DEBUG VARIABLE 
 DPIMP.P2 LX6    L.TYP+P.SNT SHIFT NAT TYPE TO SNT POSITION 
          MX0    L.SNT
          LX0    L.SNT+P.SNT
          BX2    -X0*X4       CLEAR SAVE NAT TYPE FIELD 
          BX7    X6+X2        MASK INTO SYMBOL TABLE WORD 
          SA7    A4           STORE BACK INTO SYMBOL TABLE
 DPIMP.P1 EQ     B7,B4,DPIMP.I
          SA1    A2-B4
          SB4    B4+B6
          RJ     NTYPE        GET NATURAL TYPE
          SA4    A1-B5        WORD B OF F.P. SYMBOL TABLE ENTRY 
          BX2    -X5*X4       CLEAR TYPE FIELD
          BX3    X5*X4        GET TYPE FIELD
          LX3    L.TYP
          SX0    X3-T.DBG 
          ZR     X0,DPIMP.P2  AN UNUSED DEBUG VARIABLE
 DPIMP.P3 BX7    X6+X2
          SA7    A4           ENTER TYPE IN SYMBOL TABLE
          EQ     DPIMP.P1 
  
*         CHECK FOR INFORMATIVE DIAGNOSTICS TO BE ISSUED
  
 DPIMP.I  SA1    ERRORWD
          PL     X1,DPIMP.I1
          POSTER SEV=INF,NR=E47 
 DPIMP.I1 SA1    ERRORWD
          LX1    1
          PL     X1,PH1SCAN  IF NO ERROR, EXIT... 
          POSTER SEV=INF,NR=E.TRT,RETURN=PH1SCAN
 ERR1     SB6    E.BADSEP 
          EQ     ERR.O
 ERR2     SB6    E.BADBND     ILLEGAL CHARACTER BOUND 
          EQ     ERR.O
 ERR3     SB6    E.BADTYP     ILLEGAL TYPE
 ERR.O    POSTER SEV=FE,NR=**,RETURN=DPIMP.N
  
  
  
 E.BADBND EQU    65           ILLEGAL CHARACTER BOUND 
 E.BADTYP EQU    71           ILLEGAL TYPE
 SYMEND   EQU    13B
 TYPETBL  VFD    12/0,48/8CLOGICAL
          VFD    12/0,48/8CINTEGER
          VFD    12/0,48/8CREAL 
          VFD    12/0,48/8CDOUBLE 
          VFD    12/0,48/8CCOMPLEX
 LASTTYP  BSSZ   1
 ERRORWD  BSSZ   1
          END 
