*DECK     DBGPHCT 
          IDENT  DBGPHCT
          TITLE              DBGPHCT - DEBUG OPTION CONTROLLER
*CALL,SSTCALL 
*** 
*         DBGPHCT - DEBUG OPTION CONTROLLER AND COMPASS SUBROUTINES 
* 
          SPACE  3
 B=DBGPH  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
          ENTRY  ALLARR 
          ENTRY  ALLCALL
          ENTRY  ALLFUNC
          ENTRY  GOTOSFL
          ENTRY  NOGOFLG
          ENTRY  TRACEL 
          ENTRY  D.SAASI
  
          TABLES DCON,CON 
  
 SYM1     EQU    12B
 SYMEND   EQU    13B
 TYPE     EQU    24B
 ATYPE    EQU    51B         AUXILIARY STMT TYPE CODE 
 SELIST   EQU    32B
 LELIST   EQU    34B
 DUKE     EQU    RA.SSW+37B  INITIAL LINE NR (BIN) OF LAST STATEMENT
 PROGRAM  EQU    56B               SUBPROGRAM TYPE FLAG 
 NLABEL   EQU    RA.SSW+60B  NEXT STMT LABEL
*                            0     EMPTY OR ILLEGAL LABEL 
*                            .NZ.  NEXT LABEL, DPC LEFT JUST, BLANK FILL
  
 E.IMDS   EQU    60                CONFLICTING USE OF NAME,FORTRAN DEBUG
 E.DCUN   EQU    61                CONFLICTING USE OF NAME, DEBUG-FORTRA
  
 FWASAVE  BSSZ   1
          SPACE  4,8
**        STATEMENT TYPE CODES. 
  
 ST.END   =      13          END (NORMAL) 
 ST.INV   =      37          END (INVENTED) 
  
**        DEFINE SYSTEM AND TESTMODE DEBUG FILE NAME. 
  
#T        IFEQ   TEST,0 
 OPT      MICRO  1,, ZZZZZOP
#T        ELSE
 OPT      MICRO  1,, FTNOPT 
#T        ENDIF 
          TITLE 
*CALL     PARSEM
*CALL,DBGCOM
 DBGEPKT  TITLE  DBGEPKT - DEBUG EXTERNAL PACKET PROCESSING CONTROLLER
***       DBGEPKT - DEBUG EXTERNAL PACKET PROCESSING CONTROLLER.
* 
* 
  
          QUAL   DBGEPKT
  
  
 DBGEPKT  SUBR               ** ENTRY/EXIT ** 
          SB1    1
          SX0    DEBUG-1     FWA // 
          SX1    =XPROGNAM
          BX6    X0 
          IX7    X1-X0
          SA6    LDEBUG 
          SA7    DBGPROG     ADDR PROG UNIT NAME REL TO //
          SA2    =XFWAWORK
          SA3    LNGIND 
          IX6    X2-X0
          IX7    X6+X3
          SA6    SDBGIND     FWA DEBUG INDEX = (FWAWORK) REL TO //
          SA7    D.SAREA     FWA AREA LIST REL TO //
          SA7    D.EAREA
          SA1    =XDFLAG
          MI     X1,EXP71    IF EXT PACKET PROCESSING ALREADY DONE
  
**        NORMAL EXTERNAL PACKET PROCESSING.
  
          SX6    1RE
          SA6    C.PACK      SET *EXTERNAL PACKET* STATUS 
          SX7    B1          SET *EXTERNAL PACKET* STATUS 
          SB2    B0          SET *EXTERNAL PACKET* STATUS 
          SA6    DBGPHCT     SET *EXTERNAL PACKET* STATUS 
          SA7    D.PACK 
          RJ     MIA         MISC INIT A
  
*         MAIN PROCESSING LOOP. 
  
 EXP2     SA1    =20H     DEBUG PACKET
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    =XTL.PTYP   *DEBUG PACKET* TO TITLE LINE 
          SA7    A6+B1
          SA2    SYMEND 
          RJ     DTABLE      SET UP DEBUG TABLES
          ZR     B6,EXP81    IF NO ROOM FOR TABLES
          SA1    SUCCESS
          ZR     X1,EXP3     IF NO DEBUG INFO ON DISK 
          CALLF  BUGPRO      SET UP DRL AND DVL 
 EXP3     RJ     SNS         SCAN NEXT (FIRST) STATEMENT
          SA2    =XFWAWORK
          SA3    LNGIND 
          SX4    DEBUG-1
          IX6    X2-X4
          IX7    X6+X3
          SA6    SDBGIND     FWA DEBUG INDEX = (FWAWORK) REL TO //
          SA7    D.SAREA     AREA LIST STARTS AFTER INDEX 
          SA7    D.EAREA
          EQ     B7,B6,EXP4  IF KEYWORD *DEBUG* 
          ZR     B2,EXP91    IF NOT A DEBUG STATEMENT 
          DBGERR (C$ DEBUG STATEMENT MISSING OR BAD AT START OF PACKET.)
          MI     B2,EXP3     IF BAD DEBUG STATEMENT, GET NEXT ONE 
          SA1    SPIDER      (X1) = DUMMY ROUTINE NAME
          SA2    D.EDRL 
          SX6    B1 
          MX7    1
          SA6    ALLROU      SET *APPLIES TO ALL ROUTINES*
          SA7    DEBUG+X2    2ND WD OF DRL ENTRY - SET BIT 59 *ACTIVE*
          BX6    X1 
          SA6    A7-B1       1ST WD OF DRL ENTRY - ENTER DUMMY ROUTINE
          SX7    X2+2 
          SA7    A2          UPDATE POINTER TO NEXT AVAILABLE ENTRY 
 EXP4     SA1    D.EAREA
          SA2    =XFWAWORK
          SX6    X1 
          BX7    X2 
          SA6    D.NESTW     NEXT AVAILABLE OPTIONS LIST WORD 
          SA7    FWASAVE     SAVE (FWAWORK) 
          SX6    4
          SA6    D.NEST      SET TO 1ST POSITION IN OPTIONS LIST WORD 
          CALL   DSL         DUMP SAVED LINES 
  
*         PACKET PROCESSING LOOP. 
  
 EXP11    RJ     POINTRS     SET POINTERS FOR FORTRAN ROUTINES
          CALLF  BUGCON      CONVERT STATEMENT TO TABLE FORM
 EXP12    RJ     DLO         CHECK NEXT STMT FOR C/-LIST OPTION 
          SA2    TYPE 
          NZ     X1,EXP12A   IF NEXT STATEMENT IS C$
          SA1    =XDFLAG
          AX1    1
          ZR     X1,EXP21    IF INPUT FILE NOT EXTERNAL DEBUG FILE
          SA1    CP.CARD
          ZR     X1,EXP21    IF EOS/EOP/EOI 
  
 EXP12A   SB3    X2-41
          SA1    D.NESTW     PRESET AREA OR OPTIONS LIST
          PL     B3,EXP13    IF NOT *DEBUG* OR *AREA* STATEMENT 
          SA1    D.EAREA
 EXP13    SX6    DEBUG-1+X1 
          SA6    =XFWAWORK
 EXP13A   RJ     SNS         SCAN NEXT STATEMENT
          GT     B2,B0,EXP11 IF A GOOD DEBUG STATEMENT
          SA3    =XDFLAG
          SA1    CP.CARD
          AX3    1
          ZR     X3,EXP12    IF INPUT FILE = MAIN 
          DBGERR (NON-DEBUG LINE FOUND ON EXTERNAL DEBUG FILE...IGNORED)
          NZ     X1,EXP13A   IF NOT EOS/EOP/EOI ON DEBUG FILE 
          PL     X1,EXP21    IF EOS/EOP/EOI 
          EQ     EXP13A      SCAN NEXT STATEMENT
  
*         NON-DEBUG STATEMENT PENDING.  WRAP UP EXT PACKET PROCESSING.
  
 EXP21    SX6    B0+
          SA6    D.POW       SET *CLEAR PACKET AREA LIST* FLAG
          CALLF  BUGCLO      FLUSH PACKET AREA LIST TO DISK 
          SA1    FWASAVE
          BX6    X1 
          SA6    =XFWAWORK   RESTORE (FWAWORK)
 EXP22    SB1    1
          RJ     D.RESET     RESTORE TABLE POSITIONS AND TITLE LINE 
          SA1    =XDFLAG
          MX7    -1 
          AX1    1
          SA7    D.COL       SET *DEBUG PACKET FINISHED* STATUS 
          ZR     X1,EXP31    IF INPUT FILE = MAIN 
  
*         SWITCH TO MAIN INPUT FILE AND SCAN FOR MORE C$ DEBUG INFO.
  
          CALL   DSL         DUMP SAVED LINES 
          SX6    B0+
          SA6    =XN.LINES   PRESET FOR PAGE EJECT ON NEXT *LISTL* CALL 
          SA6    =XN.FERR    IGNORE FATAL-TO-EXEC ERRS IN EXTERNAL PKT
          CLOSE  =XF.IN,NR,RCL
          SA1    =XFV.IN
          MX0    7*6
          SX7    B1 
          BX6    X0*X1       EXTRACT MAIN INPUT FILE NAME 
          SX2    X1          EXTRACT ADDRESS OF INPUT FET OR FIT
          SA7    =XDFLAG     SET *DEBUG = MAIN* STATUS
  
 #RM      IFEQ   CP#RM,0
          BX6    X6+X7       MERGE CIO COMPLETE BIT 
          SA6    X2          UPDATE INPUT FET 
          SETFIL FILE=(=XF.IN),MODE=RESET      REINITIALIZE FET 
          OPEN   =XF.IN,READNR
          READ   =XF.IN      FILL INPUT BUFFER
 #RM      ELSE
          STORE  X2,LFN=X6
          OPEN   =XF.IN 
 #RM      ENDIF 
  
          EQ     EXP2        REPEAT MAIN LOOP FOR MAIN INPUT FILE 
  
*         NON-DEBUG STATEMENT PENDING FROM MAIN INPUT FILE. 
*         CALL *SCANNER* TO TYPE IT FOR *PH1CTL*. 
  
 EXP31    SX6    B0+
          SA6    =XN.LINES   PRESET FOR PAGE EJECT ON NEXT *LISTL* CALL 
          RJ     SNS         SCAN NEXT STATEMENT
  
*         TERMINATE EXTERNAL PACKET PROCESSING AND EXIT.
  
 EXP39    SA1    LNGDRL 
          SA2    LNGDVL 
          SA3    LNGIND 
          SA4    DISPOW 
          SA5    RECORD 
          BX6    X1 
          LX7    X2 
          SA6    =XGL.DRL 
          SA7    =XGL.DVL 
          LX4    18 
          SB5    B1 
          BX6    X3 
          IX7    X4+X5
          SA6    =XGL.IND 
          SA7    =XLASTREC
          MX6    -1 
          SX7    B1 
          SA6    =XDFLAG     SET *EXT PACKET ILLEGAL* STATUS
          SA7    INDEXNO
          SA1    TYPE 
          MX7    0
          SB7    X1          (B7) = STATEMENT TYPE CODE 
          SA7    DBGPHCT     CLEAR *EXTERNAL PACKET* STATUS 
          EQ     EXIT.
  
  
**        ABNORMAL EXTERNAL PACKET PROCESSING.
  
*         HERE WHEN *DBGPHCT* IS RE-ENTERED BETWEEN PROGRAM UNITS.
*         CHECK FOR SPURIOUS EXTERNAL PACKET. 
  
 EXP71    RJ     SNS         SCAN NEXT (FIRST) STATEMENT
          ZR     B2,EXIT.    IF NOT DEBUG STATEMENT 
          DBGERR (AN EXTERNAL PACKET IS ILLEGAL BETWEEN PROGRAM UNITS.) 
          EQ     EXP71       SCAN OFF C$ STATEMENTS 
  
*         HERE IF NO ROOM FOR DEBUG TABLES. 
  
 EXP81    SA1    SUCCESS
          NZ     X1,EXP82    IF DEBUG INFO ON DISK
          SX6    B1 
          SA6    A1 
          RJ     WRTMS1 
          SA1    SDBGIND
          SX6    B0+
          SA6    DEBUG+X1    CLEAR DRL
          NO
          SA6    A6+B1       CLEAR DVL
          RJ     WRTMS4 
 EXP82    RJ     SNS         SCAN NEXT (FIRST) STATEMENT
          ZR     B2,EXP91    IF FIRST STATEMENT NOT C$
 EXP83    MI     B2,EXP84    IF BAD DEBUG STATEMENT 
          RJ     POINTRS     SET POINTERS FOR FORTRAN ROUTINES
          CALLF  BUGCON      CONVERT STATEMENT TO TABLE FORM
 EXP84    RJ     DLO         CHECK NEXT STMT FOR C/-LIST OPTION 
          ZR     X1,EXP22    IF NEXT STATEMENT NOT C$ 
          RJ     SNS         SCAN NEXT STATEMENT
          EQ     EXP83
  
*         HERE IF FIRST STATEMENT IS NON-DEBUG. 
  
 EXP91    SA1    =XDFLAG
          AX2    X1,B1
          ZR     X2,EXP92    IF INPUT FILE = MAIN 
          DBGERR (NO DEBUG INFORMATION FOUND ON EXTERNAL DEBUG FILE.) 
          EQ     EXP22
  
 EXP92    RJ     D.RESET     RESTORE TABLE POSITIONS
          EQ     EXP39       TERMINATE
          SPACE  4,4
          QUAL   *
  
 DBGEPKT  =      /DBGEPKT/DBGEPKT 
          ENTRY  DBGEPKT
          TITLE              DBGIPKT - INTERNAL PACKET PROCESSING 
*** 
*         DBGIPKT - CONTROLLER FOR DEBUG OPTION INTERNAL PACKET 
*         PROCESSING
* 
 DBGIPKT  ENTRY.
          BX6    X6-X6
          LX7    X6 
          SA6    SUCCESS      SET TO 'NOTHING ON DISK'
          SA7    D.NOGO      SET TO *PROCESS DEBUG STATEMENTS*
          RJ     DLO         CHECK NEXT STMT FOR C/-LIST OPTION 
          SA2    NOPROG 
          ZR     X1,D.PI22    FIRST STATEMENT NOT DEBUG 
          NZ     X2,D.PI22   IF NO PROGRAM LINE WAS FOUND AND CALLING 
*                              *DBGIPKT* ONLY TO SET UP FOR FURTHER 
*                              PROCESSING 
          SB2    B1          SET *INTERNAL PACKET* STATUS 
          RJ     MIA         MISC INIT A
          SA2    =XLWAWORK
          RJ     DTABLE       SET UP DEBUG TABLES 
          ZR     B6,D.PI4    IF NO ROOM FOR TABLES
          RJ     POINTRS      SET UP FORTRAN POINTERS 
          SA3    SELIST 
          SX6    -1 
          SA6    SUCCESS      SET TO 'INFORMATION ON DISK'
          IX7    X1-X4
          SA7    A1           LWAWORK=LWAWORK-LNGDRL-LNGDVL-2 
          IX6    X3-X4
          SA6    A3           SELIST=SELIST+LNGDRL-LNGDVL-2 
          CALLF  BUGPRO,B1   SET UP DRL AND DVL 
          SX7    4
          SA1    D.EAREA
          SA7    D.NEST 
          MX6    -1 
          BX7    X1 
          SA6    D.PACK       SET TO 'INTERNAL PACKET'
          SA7    D.NESTW      SET START OF OPTIONS LIST FOR BUGCON
          SX6    1RI
          SA1    =XFWAWORK
          SA6    C.PACK       SET TO 'INTERNAL PACKET'
          BX7    X1 
          SA7    FWASAVE      SAVE FWAWORK
  
*         LOOK FOR C$  DEBUG AS FIRST CARD OF PACKET
  
 D.PI4    RJ     SNS         SCAN NEXT (FIRST) STATEMENT
          PL     B2,D.PI2    IF NOT BAD DEBUG LINE
          RJ     DLO         CHECK NEXT STMT FOR C/-LIST OPTION 
          NZ     X1,D.PI4     TRY AGAIN FOR A C$  DEBUG CARD
          EQ     D.PI45       NO MORE DEBUG CARDS 
  
 D.PI2    SB6    DBGFSTT
          EQ     B7,B6,D.PI247  PROCESS THE C$ DEBUG CARD 
  
          SA1    D.NOGO 
          DBGERR (C$ DEBUG STATEMENT MISSING OR BAD AT START OF PACKET.)
          NZ     X1,D.PI247   DO NOT PROCESS DUMMY CARD, BUT
*                             CHECK CURRENT CARD FOR SYNTAX 
  
*         PROCESS DUMMY DEBUG CARD
  
          SA2    SYM1 
          MX0    42 
          SA1    X2-2         GET ROUTINE NAME
          SA2    D.EDRL 
          BX6    X0*X1
          MX7    1
          SA6    X2+DEBUG-1   ENTER NAME IN DRL 
          SA7    A6+1         ACTIVATE ROUTINE NAME 
          SX6    X2+2 
          MX7    0
          SA6    A2           UPDATE END OF DRL 
          SA7    AREAFLG      SET TO 'DEBUG STATEMENT PROCESSED LAST' 
          EQ     D.PI247      PROCESS THE CURRENT CARD
  
*         MAIN LOOP FOR PROCESSING DEBUG CARDS
  
 D.PI24   SA2    TYPE 
          SB3    40 
          SB7    X2 
          SA1    D.EAREA      CONTINUE WITH AREA LIST OR OPTIONS LIST 
          LE     B7,B3,D.PI245  LAST STMT DEBUG OR AREA 
          SA1    D.NESTW      LAST STMT OPTION
 D.PI245  SX6    X1+DEBUG-1 
          SA6    =XFWAWORK
          RJ     SNS         SCAN NEXT STATEMENT
          MI     B2,D.PI33   IF BAD DEBUG STATEMENT 
 D.PI247  RJ     POINTRS      SET UP POINTERS FOR FORTRAN ROUTINES
          CALLF  BUGCON,B1   CONVERT STATEMENT TO TABLE FORM
 D.PI33   RJ     DLO         CHECK NEXT STMT FOR C/-LIST OPTION 
          NZ     X1,D.PI24    GET THE NEXT DEBUG STATEMENT
  
*         END LOOP
  
 D.PI45   SA2    SUCCESS
          PL     X2,D.PI22    NOTHING ON DISK 
          BX6    X6-X6
          SA6    D.POW
          CALLF  BUGCLO,B1   FLUSH AREA LISTS TO DISK 
          SA1    FWASAVE
          SA2    =XL.DCON 
          SX6    3
          IX7    X1+X2        ADJUST FWAWORK BY LENGTH OF DCON
          SA6    INDEXNO      INTERNAL PACKET EXISTS
          SA7    =XFWAWORK    RESTORE FWAWORK 
 D.PI222  SA2    =XLWAWORK
          SX1    DEBUG+100
          IX3    X2-X1
          NG     X3,D.PI25    NOT ENOUGH ROOM FOR DEBUGGING 
          SB6    DEBUG-1-100
          MX6    0
          SB6    -B6
          SA1    SYM1 
          SA6    D.NOGO       RESET TO 'PROCESS DEBUG STATEMENTS' 
          SX7    X1+B6
          SA7    D.SFDIT     D.SFDIT = SYM1-DEBUG+1+100 
          SX6    X7-99
          SA6    D.SAASI     D.SAASI = SYM1-DEBUG+1+1 
  
*         RESET FLAGS, SET FLAGS TO INTERSPERSED, AND EXIT
  
 D.PI27   BX6    X6-X6
          SA2    LNGIND 
          SX7    B0 
          SA6    D.OPFLG      SET TO 'NO OPTIONS TO SEND TO DISK' 
          SA7    D.PACK       SET PACKET FLAG TO 'INTERSPERSED' 
          SA6    D.PADD       SET TO 'INTERSPERSED' 
          SB5    B1 
          BX7    X2 
          SA7    =XGL.IND     UPDATE INDEX LENGTH 
          EQ     DBGIPKT      EXIT
  
*         NOT ENOUGH ROOM TO PROCESS DEBUG INFORMATION
  
 D.PI25   SA1    D.NOGO 
          NZ     X1,D.PI27    MESSAGE ALREADY PRINTED 
          MX6    59 
          SA6    A1 
          DBGERR (MORE CORE NEEDED FOR DEBUG PROCESSING)
          EQ     D.PI27 
  
 D.PI22   SX6    1
          SA6    INDEXNO      NO INTERNAL PACKET INFORMATION
          EQ     D.PI222
          TITLE              DBGINT - INTERSPERSED STATEMENT PROCESSING 
*** 
*         DBGINT - INTERSPERSED STATEMENT PROCESSOR 
* 
  
 DBGINT   ENTRY.
          SX7    -1 
          SA7    PHSFLAG      SET PHSFLAG TO PHASE 1
  
 DBGINT8  RJ     SNS         SCAN NEXT STATEMENT
          MI     B2,DBGINT3  IF BAD DEBUG STATEMENT 
  
 DBGINT2  SX7    4
          SA7    D.NEST       SET FIELD POSITION IN OPTIONS LIST
          SB1    1
          RJ     POINTRS
          SX7    X6+1 
          SA6    D.EAREA      D.EAREA = D.DOLAST
          SA7    D.OPL       START OF OPTIONS FOR *TURNON*
          SA7    D.NESTW                       AND FOR BUGCON 
          CALLF  BUGCON       CONVERT STATEMENT TO TABLE FORM 
          SA1    TYPE 
          SX2    1401B        IF STMT TYPE .EQ. 39, 40, OR 48 
          SB2    X1+11       (DEBUG, AREA OR OFF) 
          LX3    X2,B2
          NG     X3,DBGINT3   NO LIST PROCESSING
          CALLF  TURNON 
 DBGINT3  RJ     DLO         CHECK NEXT STMT FOR C/-LIST OPTION 
          NZ     X1,DBGINT8   MORE DEBUG STATEMENTS TO PROCESS
          MX6    0
          SB5    B1 
          SA6    PHSFLAG     SET *NOT PHASE 1*
          EQ     DBGINT      EXIT ... 
 DBGINTX  SPACE  4,8
*         ENTRY WHEN A DEBUG CARD FOLLOWS AN UNRECOGNIZED FTN STMT
* 
 DBGINTX  ENTRY.
          PLUG   AT=DBGINT,FROM=DBGINTX 
          SB6    DBGEXTP
          NE     B7,B6,DBGINT2     IF ALREADY TYPED 
          RJ     GETTYPE
          NZ     B7,DBGINT2  IF TYPE OK 
          EQ     DBGINT3     ERROR
 DOP      TITLE  DEBUG OPTION PROCESSOR FOR PASS 1, PHASE 2 
**        DOP - DEBUG OPTION PROCESSOR FOR PASS 1, PHASE 2. 
* 
*                TASKS PERFORMED -- 
*         1.  SETS (D.ON) .LT. 0 AND CALLS *BUGACT* TO TURN OFF ALL 
*         OPTIONS DESIGNATED TO END AT THE STATEMENT JUST PROCESSED.
* 
*         2.  CALLS *SCANNER* TO TYPE AND TRANSFORM THE NEXT STATEMENT
*         TO E-LIST.
* 
*         3.  SETS (D.ON) = 0 AND CALLS *BUGACT* TO TURN ON ALL OPTIONS 
*         DESIGNATED TO BEGIN AT THE NEW STATEMENT. 
* 
*         4.  IF THE NEW STATEMENT IS A DEBUG OPTION (ACTION), CALLS
*         *BUGCON* TO CONVERT IT TO OPTIONS LIST FORM.  THEN CALLS
*         *TURNON* TO ACTIVATE THE NEW OPTION.
* 
*         ENTRY  NONE 
* 
*         EXIT   (B1) = 1 
* 
*         USES   ALL
* 
*         CALLS  ADEXTS, BUGACT, BUGCON, CALLF, POINTRS, SNS, TURNON, 
*                WRM
  
  
          QUAL   DOP
  
 DOP      SUBR               ** ENTRY/EXIT ** 
  
*         ISSUE *RJ FTNERR.* TO R-LIST IF A FATAL-TO-EXECUTION ERROR
*         WAS FOUND IN THE LAST STATEMENT.
  
          SA1    FEFLAG 
          SA2    NOGOFLG
          ZR     X1,DOP2     IF NO FATAL ERROR IN LAST STMT 
          NZ     X2,DOP2     IF C$-NOGO ACTIVE
          ADEXTS =8RFTNERR. 
          SA1    DUKE        (X1) = LINE NR OF LAST INIT LINE 
          SX6    B1          (X6) = SYMTAB ORDINAL OF *FTNERR.* 
          BX7    X1 
          SA6    DOPB 
          SA7    DOPB+1 
          WRM    DOPA        MACRO TO R-LIST
  
*         TURN OFF ALL OPTIONS. 
  
 DOP2     SA1    =XFSTEX
          SA2    NOACT
          SB1    1
          ZR     X1,DOP11    IF FIRST EXECUTABLE STMT NOT FOUND YET 
          NZ     X2,DOP11    IF NO DEBUG PACKET INFORMATION 
          SX6    B1+
          SA6    D.ON        SET *TURN OPTIONS OFF* 
          RJ     POINTRS
          CALLF  BUGACT      DEACTIVATE ALL OPTIONS 
  
*         TURN OPTIONS OFF/ON FOR COMMENT AND CONTINUATION LINES
*         SCANNED SINCE INITIAL LINE OF LAST STATEMENT. 
  
          SA1    DUKE        (X1) = LINE NR OF LAST INITIAL LINE
          SA2    =XDUKE1     (X2) = LINE NR OF NEXT INITIAL LINE
          SB1    1
          SB2    X1+B1
          SB3    X2 
          GE     B2,B3,DOP11 IF NO INTERVENING COMMENT OR CONTIN LINES
          SX6    B0+
          SA6    D.ON        SET *TURN OPTIONS ON*
          SA6    SCNUPDT
          SA6    D.LABEL     NO LABEL POSSIBLE ON COMMENT OR CONTIN 
 DOP3     SX6    B0+
          SA6    DOPB        INITIALIZE LOOP COUNTER
 DOP4     SA1    DOPB 
          SA2    DUKE        (X2) = LAST INITIAL LINE NR
          SA3    =XDUKE1     (X3) = NEXT INITIAL LINE NR
          SX6    X1+B1       LOOP COUNT + 1 
          IX7    X2+X6
          LX1    X6,B1       2 * LOOP COUNT 
          IX2    X7-X3
          SA3    COUNTUP     (X3) = NR OF SAVED UPDATE ID TABLE ENTRIES 
          PL     X2,DOP6     IF ALL CONTIN AND COMMENTS PROCESSED 
          SA6    A1 
          IX3    X3-X1
          SA7    D.DUKE1     LINE NR FOR OPTIONS PROCESSING 
          SA1    UPDTTBL-2+X1 
          SA2    A1+1 
          BX6    X1 
          LX7    X2 
          PL     X3,DOP5     IF NOT PAST END OF SAVED UPDATE ID TABLE 
          MX6    0
          SX7    B0 
 DOP5     SA6    D.CURUD     CURRENT UPDATE ID FOR OPTIONS PROCESSING 
          SA7    A6+1 
          CALLF  BUGACT      ACTIVATE OR DEACTIVATE OPTIONS 
          SB1    1
          EQ     DOP4        LOOP FOR NEXT COMMENT OR CONTIN LINE 
  
 DOP6     SA1    D.ON 
          MX6    1
          SA6    A1          SET *TURN OPTIONS OFF* 
          ZR     X1,DOP3     IF LAST CYCLE TURNED OPTIONS ON
  
*         PROCESS NEXT STATEMENT. 
  
 DOP11    RJ     DLO         CHECK NEXT STMT FOR C/-LIST OPTION 
          ZR     X1,DOP14    IF NEXT STATEMENT NOT C$ 
  
*         PROCESS NEW C$ STATEMENT. 
  
          RJ     SNS         SCAN NEXT STATAMENT
 DOP12    SA1    NOACT
          SX6    B0+
          NZ     X1,DOP13    IF NO DEBUG PACKET INFORMATION 
          SA6    D.ON        SET *TURN OPTIONS ON*
          RJ     POINTRS
          CALLF  BUGACT      ACTIVATE OPTIONS 
 DOP13    SA1    TYPE 
          SB2    X1-41
          MI     B2,DOP2     IF NOT AN ACTION DEBUG STATEMENT 
          SX6    4
          SA6    D.NEST 
          RJ     POINTRS
          SA1    D.DOLAST 
          SX6    X1+B1
          BX7    X1 
          SA6    D.NESTW
          SA7    D.EAREA
          SA6    D.OPL
          CALLF  BUGCON      POST NEW STMT INFO TO DEBUG TABLES 
          SA1    TYPE 
          SB2    X1-48
          ZR     B2,DOP2     IF *OFF* STATEMENT 
          CALLF  TURNON      SET NEW OPTION STATUS *ON* 
          EQ     DOP2 
  
*         PROCESS NEW NON-C$ STATEMENT. 
  
 DOP14    RJ     SNS         SCAN NEXT STATEMENT
          NZ     B2,DOP12    IF IT WAS C$ STMT (PROBABLE FTN BUG) 
          SA1    =XFSTEX
          ZR     X1,EXIT.    IF FIRST EXECUTABLE STMT NOT FOUND YET 
          SA2    NOACT
          NZ     X2,EXIT.    IF NO DEBUG PACKET INFORMATION 
          SX6    B0+
          SA6    D.ON        SET *TURN OPTIONS ON*
          RJ     POINTRS
          CALLF  BUGACT 
          SB1    1
          EQ     EXIT.
  
  
  
 RJ60     =      122B        *RJ* R-LIST MACRO NUMBER 
 DOPA     RMHDR  RJ60,2      MACRO SKELETON WORD 1
 DOPB     BSSZ   2           MACRO WORDS 2 AND 3  .. ALSO SCRATCH 
 DOP      SPACE  4,4
          QUAL   *
  
 DOP      =      /DOP/DOP 
          ENTRY  DOP
          TITLE              SUBROUTINES
 DLO      SPACE  4,8
**        DLO - DEBUG LIST OPTION CHECK.
* 
*                CALL *PLO* TO CHECK TO SEE IF NEXT STATEMENT IS A
*         C/-LIST DIRECTIVE AND IF IT IS, TO PROCESS IT. THIS SUBROUTINE
*         IS NECESSARY SO THAT A C/-LIST DIRECTIVE DOES NOT BREAK A 
*         DEBUG PACKET. 
* 
* 
*         ENTRY  NONE 
* 
*         EXIT   (X1) = .ZR. IF NEXT STATEMENT IS NOT C$-DEBUG
*                     = .NZ. IF NEXT STATEMENT IS C$-DEBUG
*                (B1) = 1 
* 
*         USES   ALL
* 
*         CALLS  PLO (SCANNER)
  
  
 DLO      SUBR               ** ENTRY/EXIT ** 
          CALL   PLO         PROCESS C/-LIST OPTION 
          SA1    C$STMT 
          SB1    1
          EQ     EXIT.
 DTABLE   SPACE  4,8
*** 
*         DTABLE - SET UP TABLES FOR DEBUG PACKET PROCESSING
* 
*         CALLING SEQUENCE
*         ENTRY     X2 = START OF TABLES TO BE MOVED SO THAT DEBUG
*                        TABLES CAN BE BUILT
*                        FOR EXTERNAL PACKET - SYMEND 
*                        FOR INTERNAL PACKET - LWAWORK
*         EXIT   B6 = 0, IF NO ROOM FOR DEBUG TABLES
*                   B6 = 1, ELSE
*                   X4 = LNGDVL + LNGDRL + 2
* 
  
 DTABLEX  SA1    D.NOGO       SET D.NOGO TO 'DO NOT PROCESS STMTS'
          SB6    B0           SET FLAG TO 'NO ROOM' 
          SA6    A1                SET NOT ENUF ROOM FLAG 
          NZ     X1,DTABLE   IF ERROR MESSAGE ALREADY ISSUED
          DBGERR   (MORE CORE NEEDED FOR DEBUG MODE)
  
 DTABLE   EQ     *+4S15      ** ENTRY/EXIT ** 
          SX1    DEBUG+501
          IX6    X2-X1
          NG     X6,DTABLEX   IF .LT. 500 WORDS AVAILABLE 
  
*         MOVE SYMTAB AND ELIST FOR DEBUG TABLES
  
          SA3    SYM1 
          SA4    LNGDRL 
          IX5    X3-X2
          SX1    X5+1 
          SA5    LNGDVL 
          SX3    X4+2 
          IX4    X3+X5        LENGTH DRL + LENGTH DVL +2
          IX3    X2-X4
          MOVE   X1,X2,X3 
  
*         RESET POINTERS AND SET DEBUG TABLE POINTERS 
  
          SA1    LNGIND       LENGTH OF INDEX 
          SA2    SYM1         ADDRESS OF START OF SYMTAB
          SX6    B1 
          IX7    X1+X6
          SA6    SDBGIND      SDBGIND = 1 
          SA7    D.SAREA      AREA LIST 
          SX1    DEBUG-1
          IX6    X2+X6
          SA7    D.EAREA
          SA3    LNGDRL       LENGTH DEBUG ROUTINE LIST 
          SA6    DBGRFMP      DBGRFMAP = SYM1+1 
          IX7    X6-X1
          SX3    X3+2 
          IX6    X7-X3
          SA7    D.RFMAP      D.RFMAP = DBGRFMP-DEBUG+1 
          SA6    D.SDRL       DEBUG ROUTINE LIST
          SA6    D.EDRL 
          SA1    LNGDVL 
          IX7    X6-X1
          SA5    SYMEND 
          IX4    X3+X1        LNGDRL+LNGDVL+2 
          SA7    D.SDVL 
          SB6    B1          (B6) = RETURN *ENOUGH ROOM* STATUS 
          IX6    X2-X4
          SA7    D.EDVL 
          SA6    A2           SYM1 = SYM1-LNGDVL-LNGDRL-2 
          IX7    X5-X4
          SA7    A5           SYMEND = SYMEND-LNGDVL-LNGDRL-2 
          EQ     DTABLE       RETURN
 MIA      SPACE  4,8
**        MIA - MISCELLANEOUS INITIALIZATION, PART A. 
* 
* 
*         ENTRY  (B2) = 0 IF EXTERNAL PACKET, = 1 IF INTERNAL PACKET
* 
*         EXIT   (B1) = 1 
* 
*         USES   X - 1, 2, 3, 6, 7
*                A - 1, 2, 3, 6, 7
*                B - 1
* 
*         CALLS  NONE 
  
  
 MIA      SUBR               ** ENTRY/EXIT ** 
          SA1    =XGL.IND 
          SA2    =XGL.DRL 
          SA3    =XLASTREC
          BX6    X1 
          LX7    X2 
          SA6    LNGIND 
          SA7    LNGDRL 
          MX1    42 
          BX7    X1*X3
          SX6    X3 
          LX7    -18
          SA6    RECORD 
          SA7    DISPOW 
          SA1    =XGL.DVL 
          SX6    X1+B2
          SA6    LNGDVL 
          SB1    1
          EQ     EXIT.
 D.RESET  SPACE  4,8
**        D.RESET - RESTORE TABLE POSITIONS AND TITLE LINE. 
* 
*                MOVES *SYMTAB* AND *E-LIST* TO ORIGINAL POSITIONS. 
*         CLEARS *DEBUG PACKET* FROM TITLE LINE.
* 
* 
*         ENTRY  (B1) = 1 
* 
*         EXIT   (B1) = 1 
* 
*         USES   X - 1, 2, 3, 4, 6, 7 
*                A - 1, 2, 3, 6, 7
*                B - NONE 
* 
*         CALLS  MOVE 
  
  
 D.RESET  SUBR               ** ENTRY/EXIT ** 
          SA3    D.NOGO 
          SA1    SYM1         ADDRESS OF START OF SYMTAB
          MI     X3,EXIT.    IF *DTABLE* DIDN-T MOVE TABLES, EXIT 
          SA2    =XLWAWORK   LAST WORD ADDRESS OF WORKING STORAGE 
          SA3    DBGRFMP     ADDRESS OF DEBUG"S REFMAP
          SX4    X1+B1
          IX6    X3-X4
          IX1    X4-X2       SYM1+1-LWAWORK 
          SA6    D.ELAST     D.ELAST = DBGRFMP-SYM1-1 
          IX3    X3-X1
          MOVE   X1,X2,X3 
  
*         RESET POINTERS
  
          SA1    D.ELAST     ADDRESS OF END OF ELIST
          SA2    SYM1        ADDRESS OF START OF SYMTAB 
          IX6    X2+X1
          SA3    SYMEND      ADDRESS OF END OF SYMTAB 
          SA6    A2          SYM1 = SYM1+D.ELAST
          IX7    X3+X1
          SA2    =XLWAWORK   LAST WORD ADDRESS OF WORKING STORAGE 
          SA7    A3          SYMEND = SYMEND+D.ELAST
          IX6    X2+X1
          SA3    SELIST      ADDRESS OF START OF ELIST
          SA6    A2          LWAWORK = LWAWORK+D.ELAST
          IX7    X3+X1
          SA7    A3          SELIST = SELIST+D.ELAST
          SA1    =1H         CLEAR *DEBUG PACKET* FROM TITLE LINE 
          NO
          BX6    X1 
          SA6    =XTL.PTYP
          SA6    A6+B1
          EQ     EXIT.
 POINTRS  SPACE  4,8
**        POINTRS - SET UP ADDRESSES FOR FORTRAN SUBROUTINES. 
* 
*         CALLING SEQUENCE
*         ENTRY     NONE
*         EXIT      A1,X1     LWAWORK, (LWAWORK)
*                   A6,X6     D.DOLAST, (D.DOLAST)
*                (B1) = 1 
* 
 POINTRS  SUBR   =           ** ENTRY/EXIT ** 
          SA2    SELIST       ADDRESS OF START OF ELIST 
          SX0    DEBUG-1      LOCATION OF BLANK COMMON
          SB1    1
          SA3    LELIST       ADDRESS OF END OF ELIST 
          IX7    X2-X0
          SA1    =XLWAWORK    LAST WORD ADDRESS OF WORKING STORAGE
          IX6    X3-X0
          SA7    D.ELIST      D.ELIST = SELIST-DEBUG+1
          SA2    SYM1         ADDRESS OF START OF SYMTAB
          SA3    SYMEND 
          SA6    D.LELST
          IX7    X1-X0
          IX6    X2-X0
          SA7    D.ELAST
          SA6    D.SSMTB      D.SSMTB = SYM1-DEBUG+1
          SA5    FWAWORK      FIRST WORD ADDRESS OF WORKING STORAGE 
          IX7    X3-X0
          SA7    D.ESMTB
          IX6    X5-X0
          SA6    D.DOLAST     D.DOLAST = FWAWORK-DEBUG+1
          EQ     EXIT.
 DMVWDS   SPACE  4,8
**        DMVWDS - CALL *MOVE* FOR A FORTRAN SUBROUTINE.
* 
*         CALLING SEQUENCE: 
*                CALL DMVWDS( WORDCT, FWA, DESTADD )
*                WORDCT = NO OF WDS TO MOVE 
*                FWA    = BEG ADDRESS OF WDS TO BE MOVED
*                DESTADD= NEW FWA 
* 
*         ON EXIT:  
*                WORDCT NO OF WDS WILL BEGIN AT DESTADD INSTEAD OF FWA
* 
 DMVWDS   SUBR   =           ** ENTRY/EXIT ** 
          SA2    A1+1         X2 = FWA
          SA3    A2+1         X3 = DESTADD
          SA1    X1           X1 = WORDCT 
          MOVE   X1,X2,X3 
          EQ     EXIT.
  
  
  
 D.TEMP   BSSZ   1                 .NE. 0 IF WAITING FOR EOR TO FLUSH BU
          EJECT 
 SNS      SPACE  4,8
**        SNS - SCAN NEXT STATEMENT.
* 
* 
*         ENTRY  NONE 
* 
*         EXIT   (B1) = 1 
*                (B2) = .GT. 0 IF GOOD DEBUG STATEMENT
*                     = .LT. 0 IF BAD DEBUG STATEMENT 
*                     =      0 IF NOT DEBUG STATEMENT 
*                (B6) = DBGFSTT (LOWEST DEBUG STATEMENT TYPE CODE)
*                (B7) = STATEMENT TYPE CODE AS RETURNED BY *SCANNER*
* 
*         USES   ALL
* 
*         CALLS  PLUG, SCANNER
  
  
 SNS      SUBR               ** ENTRY/EXIT ** 
 SNS1     SA1    D.COL
          MX6    0
          SA6    COUNTUP
          SA6    SCNUPDT
          SA6    TYPFLAG     CLEAR *BAD TYPE* STATUS
          NZ     X1,SNS3     IF EXTERNAL PACKET PROCESSED LAST
 SNS2     PLUG   AT=SNS2,TO=SNS4
 SNS3     SX6    =XCONSTOR
          SA6    D.STOR 
          SX1    DEBUG-1
          IX7    X6-X1
          MX6    0
          SA7    D.SCON1
          SA6    =XIDENTOK
 SNS4     CALL   SCANNER
          SA1    TYPE 
          SX2    X1-DBGEXTP 
          NZ     X2,SNS5     IF STATEMENT ALREADY TYPED 
          RJ     GETTYPE
 SNS5     SA1    TYPE 
          SA2    TYPFLAG
          SB1    1
          SB6    DBGFSTT
          SB2    X1          SET TYPE = *GOOD DEBUG*
          SB7    X1 
          GE     B7,B6,EXIT. IF GOOD DEBUG STATEMENT
          SB2    -1          SET TYPE = *BAD DEBUG* 
          NZ     X2,EXIT.    IF BAD DEBUG STATEMENT 
          SA1    =XCP.CARD
          AX3    1
          SB2    B0          SET TYPE = *NOT DEBUG* 
          EQ     EXIT.
 TDI      SPACE  4,8
**        TDI - TRANSFER DEBUG INFORMATION. 
* 
*                TRANSFERS STATEMENT TYPE, LABEL, LINE NUMBER AND UPDATE
*         IDENTIFIER INFORMATION FROM NORMAL WORKING LOCATIONS TO DEBUG 
*         COMMON BLOCKS.
* 
* 
*         ENTRY  (B1) = 1.
* 
*         EXIT   NONE 
* 
*         USES   X - 1, 2, 3, 4, 6, 7 
*                A - 1, 2, 3, 4, 6, 7 
*                B - NONE 
* 
*         CALLS  D.IDSAV
  
  
 TDI      SUBR   =           ** ENTRY/EXIT ** 
          SA1    D.NDUKE
          SA2    D.NLBEL
          SA3    DUKE1
          SA4    NLABEL 
          BX6    X1 
          LX7    X2 
          SA6    D.DUKE1     CURRENT STATEMENT LINE NUMBER (BINARY) 
          SA7    D.LABEL     CURRENT STATEMENT LABEL (DPC)
          MX1    30 
          BX6    X3 
          LX4    -30
          BX7    -X1*X4 
          SA6    A1          NEXT STATEMENT LINE NUMBER (BINARY)
          SA7    A2          NEXT STATEMENT LABEL (DPC) 
          SA1    D.NCURU
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    D.CURUD     CURRENT STATEMENT UPDATE IDENTIFIER
          SA7    A6+B1
          SB2    D.NCURU
          RJ     D.IDSAV     SAVE NEXT STATEMENT UPDATE IDENTIFIER
          SA1    TYPE 
          NO
          BX6    X1 
          SA6    D.TYPE 
          EQ     EXIT.
          TITLE  SUBROUTINES CALLED BY *SCANNER*. 
 DBGERR   SPACE  4,8
**        DBGERR - LIST DEBUG ERROR MESSAGE.
* 
*         ENTRY  (A5) = MESSAGE FWA 
* 
  
  
 DBGERR   SUBR   =           ** ENTRY/EXIT ** 
          MX6    -1 
          SX7    A5 
          SA6    TYPFLAG     SET *BAD DEBUG STATEMENT*
          SB1    1
          SA7    DERA        TEMP SAVE (A5) 
          CALL   LSL         LIST SAVED LINE(S) 
          SA1    DERA 
          MX0    -12
          SA5    X1 
 DER2     BX6    -X0*X5 
          SA5    A5+B1
          NZ     X6,DER2     IF NOT EOL TERMINATOR
          SB6    X1 
          SB2    A5-B6       (B2) = MESSAGE LENGTH
          SX1    A5-B6
          SX2    B6 
          SB2    B2+B1       INCR LINE LENGTH FOR WORD *DEBUG*
          SB6    DBGMSG      (B6) = MESSAGE BUFFER FWA
          SX3    B6+B1
          MOVE   X1,X2,X3    (DOES NOT USE B2 OR B6)
          LISTL  B6,B2
          EQ     EXIT.
  
  
  
 DERA     BSS    1           FOR TEMP SAVE OF (A5) = DEBUG ERR MSG FWA
 TYPFLAG  ENTRY. 0           .NZ. IF BAD DEBUG STATEMENT
  
  
  
*         DEBUG ERROR MESSAGE BUFFER. 
* 
 DBGMSG   DATA   10H   DEBUG- 
          BSSZ   9           DEBUG ERROR MSG MAX LENGTH IS 88 CHARS 
          EJECT 
 D.IDSAV  SPACE  4,8
**        D.IDSAV - SAVE UPDATE IDENT FROM NEW SOURCE LINE. 
* 
* 
*         ENTRY  (B2) = UPDATE IDENT DESTINATION ADDRESS. 
* 
*         EXIT   ((B2)) = IDENT NAME FROM COLUMNS 74-80, 8L FORMAT. 
*                ((B2)+1) = IDENT SEQUENCE NUMBER FROM COLUMNS 82-86, 
*                            PREFIXED WITH A PERIOD, 0L FORMAT. 
*                (B1) = 1 
* 
*         USES   X - 1, 2, 3, 4, 6, 7 
*                A - 3, 4, 6, 7.
*                B - 1
* 
*         CALLS  NONE.
  
  
 D.IDSAV  SUBR               ** ENTRY/EXIT ** 
          SB1    1
          SA3    =XCP.CARD+7
          SA4    A3+B1
          MX1    7*6
          SX2    1R 
          LX3    3*6         LEFT ADJUST COL 74 
          BX6    X1*X3       EXTRACT COLS 74-80 
          LX2    2*6
          IX6    X6+X2       SUFFIX BLANK 
          SA6    B2 
          MX1    5*6
          SX2    1R.
          LX1    -1*6 
          BX7    X1*X4       EXTRACT COLS 82-86 
          LX2    9*6
          IX7    X2+X7       PREFIX PERIOD
          SA7    A6+B1
          EQ     EXIT.
          EJECT 
 D.IDSP   SPACE  4,8
**        D.IDSPEC - SPECIAL EXTENSION OF 'D.IDSAVE' FOR COMMENT AND
*                    BLANK CARDS.  SINCE THESE CARDS ARE ESSENTIALLY
*                    TRANSPARENT TO FTN, THEIR UPDATE IDENTS MUST BE
*                    SAVED BY THIS SUBROUTINE.
* 
*  ON EXIT  - UPDATE IDENT IS SAVED IF TABLE SPACE WAS AVAILABLE (HOLDS 
*             20 IDENTS MAX).  DEBUG DIAGNOSTIC IS SENT IF THE TABLE
*             OVERFLOWED. 
* 
*         USES   ALL. 
  
  
 D.IDSP   SUBR   =           ** ENTRY/EXIT ** 
          SA1    NOACT
          SA2    SCNUPDT
          NZ     X1,EXIT.    IF NO DEBUG PACKET INFORMATION 
          MI     X2,EXIT.    IF SAVE TABLE FULL 
          SB2    D.CURUD
          RJ     D.IDSAV     SAVE UPDATE IDENT
          SX6    B1 
          SA6    SCNUPDT     SET *SPECIAL CALL* STATUS
          CALLF  PUTUPDT
          SA1    SCNUPDT
          SB1    1
          MX6    0
          SB5    B1+
          SA6    A1          CLEAR SCNUPDT
          PL     X1,EXIT.    IF SAVE TABLE DID NOT OVERFLOW 
          DBGERR (OVERFLOW OF SAVED UPDATE ID TABLE)
          EQ     EXIT.
          EJECT 
 ISITDBG  SPACE  4,8
**        ISITDBG - DETERMINE DEBUG STATEMENT TYPE. 
* 
*  THIS CLOSED SUBROUTINE SEARCHES A TABLE OF DEBUG KEYWORD PICTURES, 
*  SEEKING A MATCH WITH THE CURRENT STATEMENT.  IF A MATCH IS FOUND,
*  THE DEBUG STATEMENT TYPE NUMBER IS STORED IN 'TYPE' AND'D.TYPE'. 
*  IF NO MATCH IS FOUND, 'TYPE' AND 'D.TYPE' ARE SET TO ZERO, 'TYPFLAG' 
*  IS SET TO <NOT FOUND> (-1), AND A DEBUG DIAGNOSTIC MESSAGE IS SENT TO
*  THE SOURCE LISTING FILE. 
* 
*  ON ENTRY  -   NO REGISTER ASSUMPTIONS. 
* 
*  ON EXIT   -   X6 = DEBUG STATEMENT TYPE ( =0 IF UNIDENTIFIED). 
*                (B1) = 1 
*                B2 = NEXT NON-BLANK CHARACTER. 
*                B7 = X6
* 
*         USES   ALL
* 
*         CALLS  DBGERR, PACK7, PLUG
  
 ISIT2    SX6    B4+48       DEVELOP DEBUG STATEMENT TYPE 
          SA6    TYPE 
 ISIT3    SB7    X6 
          NO
          SA6    D.TYPE      SAVE STMT TYPE FOR DEBUG PROCESSOR 
  
 ISITDBG  SUBR   =           ** SCANNER ENTRY/COMMON EXIT **
          SX6    DBGEXTP
          SA6    TYPE 
          SB1    1
          CALL   PACK7       PACK DEBUG STATEMENT KEYWORD 
          SA1    TYPE 
          SX6    0
          NZ     X1,ISIT4    IF 'PACK7' DID NOT REPORT STRING > 7 CHARAC
          EQ     ISIT3
  
 GETTYPE  SUBR               ** DBGPHCT ENTRY **
  
          SB1    1
          PLUG   AT=ISITDBG,FROM=GETTYPE
 ISIT4    SA3    SELIST 
          SA2    D.STTYP     FIRST DEBUG KEYWORD PICTURE
          SA3    X3          DEBUG STMT KEYWORD 
          SB4    -D.LSTTP    KEYWORD PICTURE TABLE LENGTH (COMPLEMENT)
  
*  SEARCH DEBUG KEYWORD PICTURE TABLE FOR MATCH WITH STATEMENT KEYWORD. 
  
 ISIT5    BX0    X3-X2       STATEMENT - PICTURE
          SB4    B4+B1
          SA2    A2+1        NEXT PICTURE 
          ZR     X0,ISIT2    IF STATEMENT MATCHES PICTURE 
          LE     B4,B0,ISIT5 IF PICTURE TABLE NOT EXHAUSTED 
          BX6    X6-X6
          SA6    TYPE 
          DBGERR (UNRECOGNIZED DEBUG STATEMENT) 
          EQ     ISIT3
  
*         DEBUG STATEMENT PICTURE TABLE.
  
 D.STTYP  VFD    12/2001B,48/8HDEBUG
          VFD    12/2001B,48/8HAREA 
          VFD    12/2001B,48/8HARRAYS 
          VFD    12/2001B,48/8HCALLS
          VFD    12/2001B,48/8HFUNCS
          VFD    12/2001B,48/8HGOTOS
          VFD    12/2001B,48/8HNOGO 
          VFD    12/2001B,48/8HSTORES 
          VFD    12/2001B,48/8HTRACE
          VFD    12/2001B,48/8HOFF
 D.LSTTP  EQU    *-D.STTYP   NR OF DEBUG STMT TYPES 
          TITLE              WRTMS , RDMS - RANDOM I/O SUBROUTINES
 DLEN     =      129D        LENGTH OF CIO BUFFER FOR DEBUG RANDOM FILE 
  
**        WRTMS1 - INITIALIZE RANDOM FILE FET/FIT AND OPEN FILE.
* 
*         ENTRY  FROM FTN ROUTINE - CALL WRTMS1 
* 
*         EXIT   DEBUG FILE IS OPEN.
*                (B1) = 1 
* 
*         USES   X - 0 THRU 7 
*                A - 1 THRU 7 
*                B - 1, 3, 4
* 
*         CALLS  OPEN 
  
 WRTMS1   ENTRY. ** 
          SB1    1
  
 #RM      IFEQ   CP#RM,0
  
          RECALL F.DEBUG     WAIT FOR I/O TO COMPLETE 
  
*         SET UP FET FOR DEBUG FILE 
  
          SA1    DFET        FIRST WORD OF FET
          SA2    A1+B1       SECOND WORD
          BX7    X1 
          LX6    X2 
          SA7    F.DEBUG
          SA6    A7+B1       FIRST AND RANDOM BIT 
          SX6    X6 
          SA6    A6+B1       IN 
          SA6    A6+B1       OUT
          SX7    X6+DLEN
          SA7    A6+B1       LIMIT
  
 #RM      ENDIF 
  
          SX2    DEBUG-1
          SA1    =XL.DCON 
          SA4    SDBGIND     FWA OF DEBUG INDEX 
          SA3    D.OPEN 
          IX4    X4+X1
          BX6    X4 
          SA6    A4           ALLOW FOR LENGTH OF DCON
          PL     X3,WRTMS1A  IF CALL NOT FROM BUGPRO
          SA5    FWAWORK
          IX6    X5-X2
          SA6    A4          SET SDBGIND
          BX4    X6 
  
 WRTMS1A  IX0    X2+X4       FWA OF INDEX 
          MX6    0
          SA2    GL.IND      LENGTH 
          SB4    B0 
          SB3    X2 
 D.PHCLR  SA6    X0+B4        CLEAR OUT INDEX 
          SB4    B4+B1
          GT     B3,B4,D.PHCLR
  
 #RM      IFEQ   CP#RM,0
  
          LX2    18 
          BX6    X0+X2
          SX7    B1 
          SA6    F.DEBUG+I.RAN2 SET UP RANDOM FILE WORD 
          SA7    D.OPEN 
  
          OPEN   F.DEBUG,WRITENR,RECALL 
          EQ     WRTMS1 
  
 DFET     VFD    42/0L"OPT",18/3
          VFD    12/0,1/1,23/0,6/3,18/BUFF
  
          USE    BUFF 
 BUFF     BSS    DLEN        BUFFER OF THE DEBUG RANDOM FILE
          USE    *
  
 #RM      ELSE
  
          SX7    B1 
          SA7    D.OPEN      SET OPEN FLAG
          STORE  =XFI.DBG,MXL=X2  INDEX LENGTH
          STORE  =XFI.DBG,MXA=X0  INDEX ADDRESS 
  
          IFEQ   CP#RM,6,2
          STORE  =XFI.DBG,FWB=BUFF
          STORE  =XFI.DBG,BFS=DLEN
  
          OPENM  =XFI.DBG,I-O,N,WA
          FETCH  =XFI.DBG,CXA,X1   LOCATION (WA) OF MASTER INDEX ON FILE
          ZR     X1,WRTMS1B        IF A NEW FILE
          GETW   =XFI.DBG,X0,X2,,X1  GET INDEX FROM FILE
          EQ     WRTMS1 
  
 WRTMS1B  STORE  =XFI.DBG,NAA=1    PRESET NEXT AVAILABLE WRITE ADDR = 1 
          EQ     WRTMS1      EXIT 
  
 #RM      ENDIF 
  
          EJECT 
*** 
*         WRTMS2 - MOVE WORDS FROM AN AREA LIST TO DEBUG FILE BUFFER
*                FOR RECORD MANAGER I/O A RECORD IS WRITTEN TO
*                THE FILE.
* 
*         ENTRY  FROM FTN ROUTINE - 
*                CALL WRTMS2( FWA , LENGTH , RECORD NO )
*                (A1) = FWA OF PARAMETER LIST 
* 
*         EXIT   (B1) = 1 
* 
*         USES   X - 1 THRU 6 
*                A - 1 THRU 6 
*                B - 1, 4 
* 
*         CALLS  WRITEW 
  
 WRTMS2   ENTRY. ** 
  
 #RM      IFNE   CP#RM,0
          FETCH  =XFI.DBG,NAA,X7   NEXT AVAILABLE WRITE ADDRESS 
 #RM      ENDIF 
  
          SB1    1
          SA2    A1+B1
          SA3    A2+B1
          SA4    D.TEMP 
          SA2    X2                (X2) = TRANSFER LENGTH (WORDS) 
          NZ     X4,WRTMS21        IF NOT THE INITIAL WRITE 
          SA5    SDBGIND
          SB4    X5+DEBUG-1        ABSOLUTE ADDRE 
          SA3    X3                RECORD NUMBER
          SX6    X3+B4
          SA6    A4                SET FLAG FOR NEXT NOT INITIAL WRITE
  
 #RM      IFEQ   CP#RM,0
  
          SA6    F.DEBUG+I.RAN1    SET ADDRESS TO STORE DISK ADDR IN
 WRTMS21  WRITEW F.DEBUG,X1,X2
  
 #RM      ELSE
  
          SA7    X6          UPDATE INDEX CONTROL WORD
 WRTMS21  PUTW   =XFI.DBG,X1,X2,,X7 
          FETCH  =XFI.DBG,WA,X1 
          STORE  =XFI.DBG,NAA=X1   UPDATE NEXT AVAILABLE WRITE ADDRESS
  
 #RM      ENDIF 
  
          EQ     WRTMS2      EXIT 
          SPACE  3
*** 
*         WRTMS3 - TERMINATE RANDOM RECORD ON DEBUG FILE
*                    AND CLEAR FLAG TO INITIAL WRITE. 
*                    FOR RECORD MANAGER CLEAR THE FLAG ONLY.
* 
*         ENTRY  FROM FTN ROUTINE - CALL WRTMS3 
*                (A1) = FWA OF PARAMETER LIST 
* 
*         EXIT   DEBUG FILE BUFFER FLUSHED AND EOR WRITTEN. 
* 
*         USES   X - 6
*                A - 6
*                B - NONE 
* 
*         CALLS  WRITER 
  
 WRTMS3   ENTRY. ** 
          MX6    0
          SA6    D.TEMP            CLEAR FLAG 
  
 #RM      IFEQ   CP#RM,0
          WRITER F.DEBUG,RECALL    WRITE RECORD, FLUSH BUFFER 
 #RM      ENDIF 
  
          EQ     WRTMS3 
          SPACE  3
*** 
*         WRTMS4 - CLOSE DEBUG RANDOM FILE
* 
*         ENTRY  FROM FTN ROUTINE - CALL WRTMS4 
* 
*         EXIT   DEBUG FILE CLOSED. 
* 
*         USES   X - 6
*                A - 6
*                B - NONE 
* 
*         CALLS  CLOSE
  
 WRTMS4   ENTRY. ** 
          MX6    0
          SA6    D.OPEN            CLEAR FLAG 
  
 #RM      IFEQ   CP#RM,0
          CLOSE  F.DEBUG,NR,RECALL
 #RM      ELSE
          FETCH  =XFI.DBG,MXA,X0   INDEX ADDRESS
          FETCH  =XFI.DBG,MXL,X1   INDEX LENGTH 
          FETCH  =XFI.DBG,NAA,X2   NEXT AVAILABLE WRITE ADDRESS 
          STORE  =XFI.DBG,CXA=X2   SAVE FILE ADDRESS OF INDEX 
          PUTW   =XFI.DBG,X0,X1,,X2  PUT INDEX ON FILE
          CLOSEM =XFI.DBG,N,,WA 
 #RM      ENDIF 
  
          EQ     WRTMS4 
          EJECT 
*** 
*         RDMS1 - READMS ROUTINE FOR FTN DEBUG ROUTINES 
* 
*         THE CALLING SEQUENCE IS THE SAME AS FOR THE STANDARD FORTRAN
*         READMS ROUTINE. 
* 
*         CALL RDMS1 ( ARRAYS, NWDS, NUMBER ) 
* 
*         ENTRY  (A1) = FWA OF PARAMETER LIST 
* 
*         EXIT   (B1) = 1 
* 
*         USES   X - 0 THRU 7 
*                A - 1 THRU 7 
*                B - 1, 5 
* 
*         CALLS  READSKP
  
 RDMS1    ENTRY. ** 
  
 #RM      IFEQ   CP#RM,0
  
          SB1    1
          SA2    A1          FWA ARRAY
          SA3    A2+B1       (X3) = ADDRESS OF NWDS 
          MX0    -24
          SA4    A3+B1       (X4) = ADDRESS OF RECORD NUMBER
          SA5    =XF.DEBUG+I.RAN2  INDEX ADDRESS
          SA4    X4          (X4) = RECORD NUMBER 
          SB5    X4 
          SA1    X5+B5       EXTRACT APPROPRIATE INDEX WORD 
          BX6    -X0*X1       RETAIN PRU NUMBER 
          SX1    =XF.DEBUG
          SA6    A5-B1       STORE INTO DISK ADDRESS IN FET 
          SX7    X2          FWA
          MX0    -18
          SA3    X3          (X3) = NWDS
          SA2    X1+B1       FIRST
          BX6    X0*X2
          IX7    X6+X7        PRESERVE L FIELD AND RANDOM BIT 
          SA7    A2 
          SX6    X7 
          SA6    A2+B1       IN 
          IX5    X6+X3
          SA6    A6+B1       OUT
          SA3    A6+B1       OLD LIMIT WORD 
          SX5    X5+B1
          BX2    X0*X3
          IX7    X2+X5        NEW LIMIT 
          SA7    A3 
          READSKP F.DEBUG,RECALL
          EQ     RDMS1
  
 #RM      ELSE
  
          SB1    1
          FETCH  =XFI.DBG,MXA,X5  (X5)=FWA OF DEBUG INDEX 
          SA2    A1+B1       (X2)=ADDRESS OF NWDS 
          SA3    A2+B1       (X3) = ADDRESS OF RECORD NUMBER
          SA2    X2          (X2)=NWDS
          SA3    X3          (X3) = RECORD NUMBER 
          MX0    -24
          SB4    X3          (B4)=RECORD NUMBER 
          SA4    X5+B4       GET INDEX WORD 
          BX6    -X0*X4      FILE WA OF RECORD
          SB5    X2          (B5)=NWDS
          GETWP  =XFI.DBG,X1,X2,,X6,SKIP
          SB3    B0 
 RDMS1A   SB4    B5-B3       (B4)=WORDS REMAINING TO GET
          SB2    X2          (B2)=WORDS JUST GOTTEN 
          GE     B2,B4,RDMS1 IF READ TRANSFER COMPLETE, EXIT
          SB3    B2+B3       (B3)=WORDS READ SO FAR 
          SX2    B5-B3       (X2)=WORDS REMAINING TO GET
          SX1    X1+B2       (X1)=NEW ADDRESS IN ARRAYS TO READ INTO
          GETWP  =XFI.DBG,X1,X2 
          EQ     RDMS1A 
  
 #RM      ENDIF 
 CFO      TITLE  CFO - CHECK FIRST OCCURRENCE OF NAME 
**        CFO - CHECK FIRST OCCURRENCE OF A NAME IN A FORTRAN STATEMENT 
*         WHEN THE NAME HAS BEEN PREVIOUSLY MENTIONED IN A DEBUG
*         STATEMENT.  CHECKS SETTING OF DEBUG BITS AGAINST USEAGE IN
*         CONTEXT.
* 
*         ON ENTRY:   
*                A0-A2, X1,X2,X6,X7 AS SET BY SYMBOL AT FIRST OCCURANCE 
*                EXIT.
*                X0 = CONTEXT FLAG, 0 IF A VAR OR ARRAY , 1 IF EXTERNAL 
* 
*         ON EXIT:  
*                IF SETTING OF DEBUG BITS MATCHS PRESENT CONTEXT
*                 THEN X2 = X2+X7 
*                ELSE INFORMATIVE ERROR MESSAGE ISSUED, DEBUG BIT FIELD 
*                CLEARED, SYMBOL TABLE ENTRY UPDATED AND X1,X2,X6 
*                AS THEY WERE ON ENTRY ( ALONG WITH A0,B1,B2,A1,A2 )
  
  
 CFO      SUBR   =           ** ENTRY/EXIT ** 
          IX2    X2+X7             RESTORE DEBUG BITS 
          AX7    P.IF 
          SX3    1
          BX7    X3*X7             IF BIT 
          IX0    X0-X7
          ZR     X0,EXIT.          IF NO CONFLICT 
          RJ     DBGCUN            ISSUE ERROR MESSAGE
          EQ     EXIT.
 DBGCUN   SPACE  4,8
**        DBGCUN - ISSUE ERROR MESSAGE FOR ILLEGAL MENTION OF A NAME
*         IN A DEBUG STMT 
  
  
 DBGCUN   SUBR   =           ** ENTRY/EXIT ** 
          MX0    60-12
          BX7    -X0*X2            SAVE P- FIELD
          SA6    TEMP              SAVE X6 ( SAVED NATURAL TYPE ) 
          SA7    A2                UPDATE WORD B OF SYMTAB
          SX6    B1 
          BX2    X6 
          SA6    SAVORD      SAVE ORDINAL OF SYMBOL ENTRY 
          CALL   PSYM              FORMAT NAME FOR ERPRO
          POSTER SEV=INF,NR=E.DCUN,FMT=DPC,TXT=X3 
          SA3    SYM1              RESTORE REGISTERS
          SA4    TEMP 
          SA1    SAVORD 
          SA0    X3 
          SB1    X1 
          SB2    B1+B1             2*ORD
          SA1    A0-B2             WORD A OF SYMTAB ENTRY 
          SA2    A1-B5             WORD B 
          BX6    X4                RESTORE X6 
          EQ     EXIT.
          TITLE              DSYMTAB - FORTRAN LINKAGE TO SYMBOL TABLE
*** 
*         DSYMTAB - CALL SYMBOL FOR A FORTRAN DEBUG PROCESSOR ROUTINE 
* 
*         CALLING SEQUENCE: 
*                CALL DSYMTAB( NAME , ORD*2 ) 
*         OR     ORD*2 = DSYMTAB( NAME )
* 
  
  
*         FIRST OCCURRENCE. 
  
 DSYM1    SX0    T.DBG
          LX0    P.TYP
          BX2    X0+X2             SET TYPE T.UDV 
          LX6    P.SNT-P.TYP
          BX7    X6+X2             SAVE NATURAL TYPE
          SA7    A2 
 DSYMX    SA5    TEMPA0 
          SA2    SYMEND 
          SX6    DEBUG-1
          IX6    X2-X6
          SA6    D.ESMTB           UPDATE SYMEND FOR FTN ROUTINES 
          SA2    A5+B5             ADDR OF SECOND ARG OR 0
          SX6    B1+B1             X6 = 2*ORD 
          SA0    X5                RESTORE A0 
          ZR     X2,DSYMTAB        IF CALLED AS A FUNCTION
          SA6    X2 
  
 DSYMTAB  ENTRY.
          SA2    A1+1 
          SA1    X1                SYMBOL 
          BX7    X2 
          SX6    A0 
          SA6    TEMPA0            SAVE A0
          SA7    TEMP 
          SYMBOL                   ENTER IN SYMTAB
          ZR     X7,DSYM1          IF THE FIRST TIME
          EQ     DSYMX             REPEATED MENTION IN A DEBUG STMT 
  
*         NAME IN SYMBOL TABLE DUE TO FIRST OCCURRANCE IN A "FORTRAN" 
*         STATEMENT 
  
          BX3    X2 
          MX0    60-L.TYP 
          SX5    B1-1 
          NZ     X5,DSYM2          IF ORDINAL NOT PROGRAM UNIT NAME 
          SA4    =XVALUE. 
          ZR     X4,DSYMX          IF NOT A FUNCTION SUBPROGRAM 
          SB1    X4 
          EQ     DSYMX
 DSYM2    AX3    P.TYP
          BX4    -X0*X3            TYPE 
          SX5    X4-T.ECS 
          NG     X5,DSYMX          IF A LEGAL TYPE
          SX2    B1 
          CALL   PSYM              FORMAT THE NAME FOR ERPRO
          POSTER SEV=INF,NR=E.IMDS,FMT=DPC,TXT=X3,RETURN=DSYMX
 FIXPNTR  SPACE  4,8
**        FIXPNTR - RESET ADDRESSES FROM FORTRAN SUBROUTINE VALUES. 
  
  
 FIXPNTR  SUBR   =           ** ENTRY/EXIT ** 
          SB5    1
          SA2    D.SSMTB     ADDRESS OF START OF SYMBOL TABLE 
          SX1    DEBUG-1     LOCATION OF BLANK COMMON 
          IX6    X2+X1
          SA3    D.ESMTB
          SA4    D.ELAST     ADDRESS OF END OF ELIST
          SA6    SYM1        SYM1 = D.SSMTB+DEBUG-1 
          IX7    X3+X1
          IX6    X4+X1
          SA7    SYMEND 
          SA2    D.LELST
          SA3    D.ELIST
          SA6    =XLWAWORK    LWAWORK = D.ELAST+DEBUG-1 
          IX7    X2+X1
          IX6    X3+X1
          SA7    LELIST      LELIST = D.LELST+DEBUG-1 
          SA6    SELIST      SELIST = D.ELIST+DEBUG-1 
          EQ     EXIT.
 DINPH2   TITLE  DINPH2 - INITIALIZE DEBUG PROCESSOR FOR PHASE 2
**        DINPH2 - INITIALIZE DEBUG PROCESSOR FOR PHASE 2.
  
  
 DINPH2   SUBR   =           ** ENTRY/EXIT ** 
          SA5    L.DCON 
          ZR     X5,DINPH2A        IF NO CONSTANTS
  
*         MOVE CONSTANTS ENCOUNTERED DURING PHASE 1 TO THE CON TABLE
  
          ALLOC  CON,X5            GET SPACE
          SA1    L.DCON 
          SA2    O.DCON 
          SA3    O.CON
          BX6    X1 
          SA6    L.CON             SET LENGTH OF CON TABLE
          MOVE   X1,X2,X3 
  
 DINPH2A  SYMBOL =8RLABEL.         LABEL. TO SYMTAB 
          SA3    =XWB.CON 
          BX7    X3+X2             SET WORD B BITS
          SX6    B1 
          SA7    A2 
          SA6    =XLABEL.          SAVE ORDINAL 
          EQ     EXIT.
          TITLE              DCONV - CONVERT CONSTANT FOR DEBUG PROCESSO
,R
 TEMPA0   BSS    1                 SAVED VALUE OF A0
 TEMP     BSS    4                 MUST COME AFTER TEMPA0 
 SIGN     BSS    1                 0 OR -0
 WORDS    BSS    1                 WORD COUNT - 1 
 CONTYPE  BSS    1                 CONSTANT TYPE CODE 
 SAVORD   BSS    1           SAVED ORDINAL OF SYMBOL ENTRY (DBGCUN) 
  
*** 
*         DCONV - ENTER A CONSTANT IN THE CON TABLE FOR THE DEBUG 
*         OPTION PROCESSOR
* 
*         ON ENTRY: 
*                X1 = LOCF(ELIST) 
*                 = POINTER TO START OF CONSTANT
* 
*         ON EXIT:  
*                X6 = 42/0,3/TYPE,1/FLAG,14/ORDINAL 
*                WHERE FLAG = 1 IF CONSTANT IS ENTERED IN GLOBAL TABLE
*         OR X6 .LT. 0 IF AN ERROR OCCURED
*                ELIST IS ADVANCED TO POINT PAST THE CONSTANT 
* 
  
*         ERROR EXIT
  
 DCONV.E  MX6    1
          SA1    TEMPA0            RESTORE A0 
          SA0    X1 
          EQ     DCONV
  
*         NORMAL EXIT 
  
 DCONVX   SA2    CONTYPE
          LX2    15                POSITION TYPE
          BX6    X1+X2             42/0,3/TYPE,1/FLAG,14/ORDINAL
          SA5    TEMPA0 
          SA0    X5                RESTORE A0 
  
 DCONV    ENTRY.
          SA2    X1                RELATIVE ELIST POINTER 
          SB7    DEBUG-1
          SA4    X2+B7             FIRST ELEMENT
          UX1    B2,X4
          SB5    1
          SX6    A0 
          SA6    TEMPA0            SAVE A0
  
          MX7    0
          IF.EQ  EL.(,DCONV.C      IF A COMPLEX CONSTANT
          IF.EQ  CON,DCONV2        IF A CONSTANT
          IF.EQ  EL.PLUS,DCONV1    IF A + 
          IF.NE  EL.MINUS,DCONV.E  IF NOT - 
          MX7    60 
 DCONV1   NEXTE 
          IF.NE  CON,DCONV.E       IF NOT A CONSTANT
  
 DCONV2   SA7    SIGN              SAVE SIGN
          SB7    B7+B5
          SX6    A4-B7             UPDATE ELIST POINTER 
          SA6    A2 
  
          AX1    45 
          BX6    X1 
          SX2    X1-T.DBL 
          SA6    CONTYPE           SAVE CONSTANT TYPE 
          MX7    0
          NZ     X2,DCONV3         IF NOT DOUBLE
          SX7    B5 
 DCONV3   SA7    WORDS             SAVE WORD COUNT - 1
          BX1    X4 
          SB1    -B5
          CALL   CONVERT           CONVERT THE CONSTANT 
          BX6    X1 
          LX7    X2 
          SA6    TEMP 
          SA7    A6+B5             SAVE CONSTANT
  
 DCONV4   SA3    D.PACK 
          SX0    X3-1 
          ZR     X0,DCONV.G        IF PROCESSING A PACKET 
  
          SA5    =XPHASE
          ZR     X5,DCONV5         IF PHASE 1 
  
*         PHASE 2 - ENTER THE CONSTANT IN CONTAB
  
          SA4    WORDS
          SB1    X4+B5             WORD COUNT 
          CALL   CONVERT           ENTER CONSTANT IN CONTAB 
          AX1    30                POSITION CA
          EQ     DCONVX 
  
*         PHASE 1 - ENTER THE CONSTANT IN DCON
  
 DCONV5   SA4    O.DCON 
          SA5    L.DCON 
          MX0    0
          RJ     SRCH              SEARCH FOR A MATCH IN DCON 
          NG     B2,DCONVX         IF A MATCH 
  
          ADDWD  DCON,X1
          SA5    WORDS
          ZR     X5,DCONV5A        IF NOT 2 WORDS 
          ADDWD  A0,TEMP+1         ADD SECOND WORD
  
 DCONV5A  SA1    TEMP+2            ORDINAL
          EQ     DCONVX 
  
*         GLOBAL PACKET - SAVE THE CONSTANT THE THE GLOBAL CON TABLE
  
 DCONV.G  SA4    =XO.GCON 
          SA5    =XL.GCON 
          SX0    1S14              FLAG 
          RJ     SRCH              SEARCH FOR A MATCH 
          NG     B2,DCONVX         IF FOUND 
  
          RJ     ADDGCON           ADD FIRST WORD TO GCON 
          SA5    WORDS
          ZR     X5,DCONV5A        IF ONLY 1 WORD 
          SA1    TEMP+1 
          RJ     ADDGCON           ADD SECOND WORD
          EQ     DCONV5A
          SPACE  3
*         PROCESS COMPLEX CONSTANT
  
 DCONV.C  SB6    TEMP 
          RJ     CHC               CHECK THE REAL PART
          IF.NE  EL.COMMA,DCONV.E  IF NO COMMA
          SB6    TEMP+2 
          RJ     CHC               CHECK THE IMAGINARY PART 
          IF.NE  EL.),DCONV.E      IF NOT A ) 
          SB7    B7+B5
          SX7    A4-B7
          SA7    A2                UPDATE ELIST POINTER 
  
          SA1    TEMP 
          SB1    -B5
          CALL   CONVERT           CONVERT THE REAL PART
          SA2    TEMP+1            SIGN 
          BX6    X1-X2
          SA6    A2-B5             SAVE IN TEMP 
  
          SA1    A2+B5             ELIST FOR IMAGINARY PART 
          SB1    -B5
          CALL   CONVERT
          SA2    TEMP+3            SIGN OF IMAGINARY PART 
          BX6    X1-X2
          SA6    TEMP+1 
          SA1    A6-B5             REAL PART
          BX2    X6 
          SX7    B5 
          SA7    WORDS
          SX6    T.CPLX 
          SA6    CONTYPE           SET TYPE 
          EQ     DCONV4 
          EJECT 
*** 
*         CHC - CHECK HALF OF COMPLEX CONSTANT
* 
*         ON ENTRY: 
*                B6 = TWO WORD AREA TO STORE CONSTANT AND SIGN IN 
*                A4 = ITEM BEFORE CONSTANT
* 
*         ON EXIT:  
*                A4 POINTS PAST CONSTANT AND B2,X4 HOLD ELIST ITEM
* 
  
 CHC      SUBR                     ** ENTRY/EXIT ** 
          NEXTE 
          MX7    0
          IF.EQ  CON,CHC2          IF A CONSTANT
          IF.EQ  EL.PLUS,CHC1      IF + 
          MX7    60 
          IF.NE  EL.MINUS,DCONV.E  IF NOT - 
 CHC1     NEXTE 
          IF.NE  CON,DCONV.E       IF NOT A CONSTANT
 CHC2     BX6    X4 
          AX1    45 
          SA6    B6                SAVE ELIST FOR CONSTANT
          SA7    B6+B5             AND SIGN 
          SX2    X1-T.REAL
          NEXTE 
          ZR     X2,EXIT.          IF TYPE REAL 
          EQ     DCONV.E
          TITLE              ADDGCON - ADD A WORD TO GLOBAL CON TABLE 
*** 
*         ADDGCON - ADD A WORD TO THE GLOBAL CON TABLE
* 
*         ON ENTRY: 
*                X1 = WORD TO BE ADDED
* 
  
 ADDGCON1 IX0    X2+X3
          SX7    X3+B5             LEN = LEN+1
          SA6    X0                STORE WORD 
          SA7    A3 
  
 ADDGCON  SUBR                     ** ENTRY/EXIT ** 
          SA3    =XL.GCON          TABLE LENGTH 
          SA2    =XO.GCON          TABLE FWA
          SX7    X3-S.GCON
          BX6    X1 
          MI     X7,ADDGCON1       IF TABLE NOT FULL
          SA5    GCONF             OVERFLOW-MSG-ISSUED FLAG 
          NZ     X5,ADDGCON2       IF WE ISSUED IT ALREADY
          MX6    1
          SA6    A5                SET FLAG 
          SA1    =C/GLOBAL CON TABLE OVERFLOW/
          CALL   DBGERR 
 ADDGCON2 SX1    1S14 
          EQ     DCONVX 
  
  
  
 GCONF    BSSZ   1           .NZ. IF *GCON* OVERFLOW
          TITLE              SRCH - SEARCH A CON TABLE
*** 
*         SRCH - SEARCH A CON TABLE FOR A MATCH 
* 
*         ON ENTRY: 
*                X0 = FLAG ( 0 OR 1S14 )
*                X1,X2 = WORDS 1 AND 2 OF CONSTANT
*                X4,X5 = FWA AND LENGTH OF CON TABLE
* 
*         ON EXIT:  
*                IF A MATCH IS FOUND, THEN
*                 B2 .LT. 0 AND X1 = FLAG+ORDINAL 
*                ELSE 
*                 B2 .GE. 0 AND (TEMP+2) = FLAG+LENGTH OF TABLE 
*                AND X1,X2 INTACT 
* 
  
 SRCHX    SX1    X0+B1
          SB2    -B5
 SRCH 
          SA3    WORDS
          SB6    X3                WORD COUNT - 1 
          SA3    X4                X3 = CURRENT WORD
          SB2    X5                B2 = TABLE LENGTH
          IX6    X0+X5
          SB1    -B5               INITIALIZE INDEX 
 SRCH1    SB1    B1+B5
          BX7    X1-X3             WORD 1 - TABLE ENTRY 
          GE     B1,B2,SRCH2       IF END OF THE TABLE
          SA3    A3+B5
          NZ     X7,SRCH1          IF NO HIT
          NG     X7,SRCH1          IF COMPLEMENTS 
          ZR     B6,SRCHX          IF ONLY 1 WORD 
          SB3    B1+B5
          BX7    X2-X3             WORD 2 - TABLE ENTRY 
          GE     B3,B2,SRCH2       IF END OF THE TABLE
          NZ     X7,SRCH1          IF NO HIT
          PL     X7,SRCHX          IF NOT COMPLEMENTS 
          EQ     SRCH1
  
*         NOT FOUND EXIT
  
 SRCH2    SA6    TEMP+2            SAVE FLAG+ORDINAL
          EQ     SRCH 
          SPACE  4
          LIST   D
          END 
