home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istds / DSLIB.MAC.f next >
Encoding:
Text File  |  1989-03-04  |  98.2 KB  |  2,741 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C
  5. C       D S   -   Declaration Standardise a program (parse tree).
  6. C
  7.  
  8.         SUBROUTINE DS(OPTSTR,CMTFD,DESC,NERRS,NWARNS)
  9.         INTEGER OPTSTR(*),CMTFD,DESC,NERRS,NWARNS
  10.  
  11. C---------------------------------------------------------
  12. C    TOOLPACK/1    Release: 2.5
  13. C---------------------------------------------------------
  14.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  15.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  16.      +          SDTYPE(5003),SCHLEN(5003),
  17.      +          SBITS(5003)
  18.  
  19.         SAVE /DSSYMS/
  20. C---------------------------------------------------------
  21. C    TOOLPACK/1    Release: 2.5
  22. C---------------------------------------------------------
  23.         COMMON/DSIO/IODCMT,TKDESC
  24.         INTEGER IODCMT,TKDESC
  25.  
  26.         SAVE /DSIO/
  27. C---------------------------------------------------------
  28. C    TOOLPACK/1    Release: 2.5
  29. C---------------------------------------------------------
  30.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  31.      +                STMTNO
  32.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  33.         LOGICAL DUMPED(22)
  34.  
  35.         SAVE /DSSTAT/
  36. C---------------------------------------------------------
  37. C    TOOLPACK/1    Release: 2.5
  38. C---------------------------------------------------------
  39. C
  40. C  TKLAST = LAST TOKEN NUMBER
  41. C
  42.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  43.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  44.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  45.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  46.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  47.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  48.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  49.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  50.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  51.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  52.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  53.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  54.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  55.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  56.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  57.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  58.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  59.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  60.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  61.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  62.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  63.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  64.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  65.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  66.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  67.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  68.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  69.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  70.  
  71. C---------------------------------------------------------
  72. C    TOOLPACK/1    Release: 2.5
  73. C---------------------------------------------------------
  74.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  75.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  76.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  77.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  78.      +          INCLPR
  79.  
  80.         SAVE /DSOPTS/
  81. C---------------------------------------------------------
  82. C    TOOLPACK/1    Release: 2.5
  83. C---------------------------------------------------------
  84.         COMMON/DSSPEC/SPECP
  85.         LOGICAL SPECP(132)
  86.  
  87.         SAVE /DSSPEC/
  88.  
  89.         INTEGER I,DUMMY(2)
  90.  
  91.         SAVE DUMMY
  92.  
  93.         INTEGER ZYROOT,ZYDOWN,ZYNEXT
  94.         EXTERNAL ZYROOT,ZYDOWN,ZYNEXT,ZTOKWR,ZYGSSI,ZYGDSD,ERROR,ZYCSDT
  95.  
  96.         DATA DUMMY(1)/129/
  97.  
  98.         PUROOT=ZYDOWN(ZYROOT())
  99.         PUNUM=0
  100.         SNUM=1
  101.         IODCMT=CMTFD
  102.         TKDESC=DESC
  103.         NERROR=0
  104.         NWARN=0
  105.         CALL DSOPT(OPTSTR)
  106.  
  107. C Change data-types to canonical forms if necessary
  108.         IF (DTFORM.NE.0) CALL ZYCSDT(DTFORM,.TRUE.)
  109.  
  110. C Initialise common block DSSPEC
  111.         DO 50 I=1,132
  112.             SPECP(I)=.FALSE.
  113.  50     CONTINUE
  114.         SPECP(30)=.TRUE.
  115.         SPECP(8)=.TRUE.
  116.         SPECP(16)=.TRUE.
  117.         SPECP(7)=.TRUE.
  118.         SPECP(19)=.TRUE.
  119.         SPECP(35)=.TRUE.
  120.         SPECP(20)=.TRUE.
  121.         SPECP(26)=.TRUE.
  122.         SPECP(37)=.TRUE.
  123.         SPECP(38)=.TRUE.
  124.         SPECP(24)=.TRUE.
  125.         SPECP(39)=.TRUE.
  126.         SPECP(41)=.TRUE.
  127.         SPECP(121)=.TRUE.
  128.         SPECP(32)=.TRUE.
  129.         SPECP(78)=.TRUE.
  130.         SPECP(18)=.TRUE.
  131.         SPECP(127)=.TRUE.
  132.         SPECP(128)=.TRUE.
  133.         SPECP(129)=.TRUE.
  134.         SPECP(130)=.TRUE.
  135.  
  136. C Preprocess whole file to set "include" status flags (if any)
  137.         IF (INCLPR .AND. PMODE.EQ.2) THEN
  138.  100        PUNUM=PUNUM+1
  139.             CALL PREPRO
  140.             PUROOT=ZYNEXT(PUROOT)
  141.             IF (PUROOT.GT.0) GOTO 100
  142.             PUROOT=ZYDOWN(ZYROOT())
  143.             PUNUM=0
  144.             SNUM=1
  145.         END IF
  146.  
  147.  200    DO 300 I=1,22
  148.             DUMPED(I)=.FALSE.
  149.  300    CONTINUE
  150.         PUNUM=PUNUM+1
  151.         IF (ICTWCB) THEN
  152.             DUMPED(6)=.TRUE.
  153.             DUMPED(7)=.TRUE.
  154.         END IF
  155.         CALL ZYGSSI(SYMIDX,NSYMS,PUNUM)
  156.         CALL ZYGDSD(SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS,NSYMS)
  157.         CALL SRTIDX
  158.         SECNUM=0
  159.         IF (PMODE.EQ.2) THEN
  160.             CALL PROPU1
  161.         ELSE IF (PMODE.EQ.1) THEN
  162.             CALL PROPU2
  163.         ELSE
  164.             CALL ERROR('DS Internal Error: incorrect value for PMODE')
  165.         END IF
  166.         PUROOT=ZYNEXT(PUROOT)
  167.         IF (PUROOT.GT.0) GOTO 200
  168.         CALL ZTOKWR(TZEOF,0,DUMMY,TKDESC)
  169.  
  170.         NERRS=NERROR
  171.         NWARNS=NWARN
  172.  
  173.         END
  174. C ----------------------------------------------------------------------
  175. C
  176. C       D S O P T   -   This routine decodes an ISTDS option string.
  177. C
  178.  
  179.         SUBROUTINE DSOPT(OPTSTR)
  180.  
  181.         INTEGER OPTSTR(*)
  182.  
  183.         INTEGER GETWRD,ZKWLUK,ZSCTOI,ZSPLIT
  184.         EXTERNAL GETWRD,ZCHOUT,PUTLIN,ZMESS,ZKWLUK,ZSCTOI,ZSPLIT,SCOPY
  185.  
  186. C---------------------------------------------------------
  187. C    TOOLPACK/1    Release: 2.5
  188. C---------------------------------------------------------
  189.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  190.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  191.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  192.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  193.      +          INCLPR
  194.  
  195.         SAVE /DSOPTS/
  196. C---------------------------------------------------------
  197. C    TOOLPACK/1    Release: 2.5
  198. C---------------------------------------------------------
  199.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  200.      +                STMTNO
  201.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  202.         LOGICAL DUMPED(22)
  203.  
  204.         SAVE /DSSTAT/
  205.  
  206.         INTEGER OPTTBL(123),STRING(134),POINT,I,LHS(134),
  207.      +          RHS(134),OPTION,YNCTBL(16),YNLTBL(12),
  208.      +          MODTBL(45),RHSPTR,CAFTBL(47)
  209.  
  210.         SAVE OPTTBL,YNCTBL,YNLTBL,MODTBL,CAFTBL
  211.  
  212.         DATA OPTTBL/13,
  213.      +      97,114,100,105,99,98,129,
  214.      +      99,104,108,98,114,107,129,
  215.      +      100,97,116,97,116,121,112,101,95,102,
  216.      +111,114,109,129,
  217.      +      101,120,101,104,100,114,129,
  218.      +      103,101,110,105,110,116,129,
  219.      +      105,99,116,119,99,98,129,
  220.      +      105,110,99,108,117,100,101,95,112,114,
  221.      +111,99,101,115,115,105,110,103,129,
  222.      +      109,111,100,101,129,
  223.      +      110,111,110,101,129,
  224.      +      110,111,116,114,97,105,108,101,114,115,129,
  225.      +      111,108,100,102,109,116,129,
  226.      +      111,114,100,101,114,129,
  227.      +      114,101,109,111,118,101,95,117,110,
  228.      +117,115,101,100,95,110,97,109,101,115,129/
  229.  
  230.         DATA YNCTBL/3,
  231.      +      99,111,110,118,101,114,116,129,
  232.      +      110,111,129,
  233.      +      121,101,115,129/
  234.  
  235.         DATA YNLTBL/3,
  236.      +      108,111,103,129,
  237.      +      110,111,129,
  238.      +      121,101,115,129/
  239.  
  240.         DATA MODTBL/2,
  241.      +      100,101,99,108,97,114,101,95,105,109,
  242.      +112,108,105,99,105,116,95,110,97,109,101,115,129,
  243.      +      114,101,98,117,105,108,100,95,100,101,
  244.      +99,108,97,114,97,116,105,118,101,115,129/
  245.  
  246.         DATA CAFTBL/3,
  247.      +      107,101,121,119,111,114,100,115,129,
  248.      +      108,101,110,103,116,104,95,115,112,101,99,
  249.      +105,102,105,101,114,115,129,
  250.      +      110,111,116,95,100,111,117,98,108,101,
  251.      +95,99,111,109,112,108,101,120,129/
  252.  
  253.         POINT=1
  254.  
  255.  100    IF (GETWRD(OPTSTR,POINT,STRING).EQ.0) RETURN
  256.         IF (ZSPLIT(STRING,LHS,RHS).NE.-2) THEN
  257.             CALL SCOPY(STRING,1,LHS,1)
  258.             RHS(1)=129
  259.         END IF
  260.         OPTION=ZKWLUK(LHS,OPTTBL)
  261.         IF (OPTION.LE.0) THEN
  262.             IF (OPTION.EQ.0) CALL ZCHOUT('Warning: Ambiguous',2)
  263.             IF (OPTION.EQ.-1)  CALL ZCHOUT('Warning: Unknown',2)
  264.             CALL ZCHOUT(' option "',2)
  265.             CALL PUTLIN(LHS,2)
  266.             CALL ZMESS('" ignored',2)
  267.             NWARN=NWARN+1
  268.         ELSE IF (OPTION.EQ.1) THEN
  269.             IF (RHS(1).NE.129)
  270.      +          CALL DSWARN('Superfluous argument to the ARDICB option')
  271.             ARDICB=.TRUE.
  272.         ELSE IF (OPTION.EQ.2) THEN
  273.             IF (RHS(1).NE.129)
  274.      +          CALL DSWARN('Superfluous argument to the CHLBRK option')
  275.             CHLBRK=.TRUE.
  276.         ELSE IF (OPTION.EQ.3) THEN
  277.             OPTION=ZKWLUK(RHS,CAFTBL)
  278.             IF (OPTION.LT.0) THEN
  279.                 CALL DSWARN('Unknown value for DATATYPE_FORM option')
  280.             ELSE IF (OPTION.EQ.0) THEN
  281.                 CALL DSWARN('Ambiguous value for DATATYPE_FORM option')
  282.             ELSE
  283.                 DTFORM=OPTION
  284.             END IF
  285.         ELSE IF (OPTION.EQ.4) THEN
  286.             IF (RHS(1).NE.129)
  287.      +          CALL DSWARN('Superfluous argument to the EXEHDR option')
  288.             EXEHDR=.TRUE.
  289.         ELSE IF (OPTION.EQ.5) THEN
  290.             IF (RHS(1).NE.129)
  291.      +          CALL DSWARN('Superfluous argument to the GENINT option')
  292.             CALL DSWARN('The GENINT option isn''t implemented')
  293.             GENINT=.TRUE.
  294.         ELSE IF (OPTION.EQ.6) THEN
  295.             IF (RHS(1).NE.129)
  296.      +          CALL DSWARN('Superfluous argument to the ICTWCB option')
  297.             ICTWCB=.TRUE.
  298.         ELSE IF (OPTION.EQ.7) THEN
  299.             IF (RHS(1).NE.129)
  300.      +          CALL DSWARN(
  301.      +'Superfluous argument to the INCLUDE_PROCESSING option')
  302.             INCLPR=.TRUE.
  303.         ELSE IF (OPTION.EQ.8) THEN
  304.             OPTION=ZKWLUK(RHS,MODTBL)
  305.             IF (OPTION.LT.0) THEN
  306.                 CALL DSWARN('Unknown value for MODE option')
  307.             ELSE IF (OPTION.EQ.0) THEN
  308.                 CALL DSWARN('Ambiguous value for MODE option')
  309.             ELSE
  310.                 PMODE=OPTION
  311.             END IF
  312.         ELSE IF (OPTION.EQ.10) THEN
  313.             IF (RHS(1).NE.129) CALL DSWARN(
  314.      +          'Superfluous argument to the NOTRAILERS option')
  315.             NOTRAI=.TRUE.
  316.         ELSE IF (OPTION.EQ.11) THEN
  317.             IF (RHS(1).NE.129) THEN
  318.                 OPTION=ZKWLUK(RHS,YNCTBL)
  319.                 IF (OPTION.EQ.1) THEN
  320.                     OLDFMT=.TRUE.
  321.                     CNVOLD=.TRUE.
  322.                 ELSE IF (OPTION.EQ.2) THEN
  323.                     OLDFMT=.FALSE.
  324.                     CNVOLD=.FALSE.
  325.                 ELSE IF (OPTION.EQ.3) THEN
  326.                     OLDFMT=.TRUE.
  327.                     CNVOLD=.FALSE.
  328.                 ELSE
  329.                     CALL DSWARN('Invalid argument to the OLDFMT option')
  330.                 END IF
  331.             ELSE
  332. C If nothing, default is to convert
  333.                 OLDFMT=.TRUE.
  334.                 CNVOLD=.TRUE.
  335.             END IF
  336.         ELSE IF (OPTION.EQ.12) THEN
  337.             RHSPTR=1
  338.             DO 200 I=1,7
  339.                 IF (RHS(RHSPTR).EQ.129 .AND. I.EQ.7)
  340.      +              CALL DSWARN('Insufficient values for ORDER option')
  341.                 DORDER(ZSCTOI(RHS,RHSPTR))=I
  342.                 IF (RHS(RHSPTR).NE.129) RHSPTR=RHSPTR+1
  343.  200        CONTINUE
  344.         ELSE IF (OPTION.EQ.13) THEN
  345.             OPTION=ZKWLUK(RHS,YNLTBL)
  346.             IF (OPTION.LE.0) THEN
  347.                 CALL DSWARN('Invalid value for REMOVE option')
  348.             ELSE
  349.                 VMODE=OPTION
  350.             END IF
  351.         END IF
  352.         GOTO 100
  353.  
  354.         END
  355. C ----------------------------------------------------------------------
  356. C
  357. C       P R E P R O   -   Preprocess program-unit checking for includes.
  358. C
  359.  
  360.         SUBROUTINE PREPRO
  361.  
  362. C---------------------------------------------------------
  363. C    TOOLPACK/1    Release: 2.5
  364. C---------------------------------------------------------
  365.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  366.      +                STMTNO
  367.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  368.         LOGICAL DUMPED(22)
  369.  
  370.         SAVE /DSSTAT/
  371. C---------------------------------------------------------
  372. C    TOOLPACK/1    Release: 2.5
  373. C---------------------------------------------------------
  374.         COMMON/DSIO/IODCMT,TKDESC
  375.         INTEGER IODCMT,TKDESC
  376.  
  377.         SAVE /DSIO/
  378. C---------------------------------------------------------
  379. C    TOOLPACK/1    Release: 2.5
  380. C---------------------------------------------------------
  381.         COMMON/COMMNT/CMTTXT
  382.         INTEGER CMTTXT(1310)
  383.  
  384.         SAVE /COMMNT/
  385. C---------------------------------------------------------
  386. C    TOOLPACK/1    Release: 2.5
  387. C---------------------------------------------------------
  388.         COMMON/DSSPEC/SPECP
  389.         LOGICAL SPECP(132)
  390.  
  391.         SAVE /DSSPEC/
  392.  
  393.         INTEGER SPTR,PTR,SYMBOL(8),NTYPE,BLANKC(8),
  394.      +          BIND,ID(3),TEXT(134),TXTPTR,VPTR,INCLVL
  395.         LOGICAL ISSED
  396.  
  397.         INTEGER SEC
  398.  
  399.         INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYPREV,ZYGTCM,ZYGNCM,ZSEDID,ZYFSYM
  400.         EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYPREV,ZYGTCM,ZYGNCM,ZSEDID,
  401.      +           ZYFSYM,ZYSABT,ZYCHNT
  402.  
  403.         DATA BLANKC/36,67,79,77,77,79,78,129/
  404.  
  405.         INCLVL=0
  406.         STMTNO=1
  407.  
  408. C =============================PART ONE [OPTIONAL]: P.U. HEADER
  409.  
  410.         IF (ZYNTYP(PUROOT).NE.2 .OR.
  411.      +      ZYNTYP(ZYDOWN(PUROOT)).EQ.7) THEN
  412. C There is a program header - skip it
  413.             SNUM=SNUM+1
  414.             SPTR=ZYNEXT(ZYDOWN(PUROOT))
  415.         ELSE
  416.             SPTR=ZYDOWN(PUROOT)
  417.         END IF
  418.  
  419. C =============================PART TWO: INCLUDE SPECIFICATIONS
  420.  
  421. C Procedure: Examine comments before each statement until we get to
  422. C            first executable
  423.  
  424.  300    IF (ZYGTCM(IODCMT,SNUM,CMTTXT).EQ.-2) THEN
  425.  400        ISSED=CMTTXT(1).EQ.42
  426.             IF (ISSED) ISSED=ZSEDID(CMTTXT,BIND,ID,TEXT).EQ.-2
  427.             IF (ISSED) THEN
  428.                 IF (ID(1).EQ.105 .AND. ID(2).EQ.110) THEN
  429.                     TXTPTR=1
  430.                     CALL SKIPBL(TEXT,TXTPTR)
  431.                     IF (TEXT(1).EQ.98 .OR. TEXT(1).EQ.66) THEN
  432.                         INCLVL=INCLVL+1
  433.                     ELSE IF (TEXT(1).EQ.101 .OR. TEXT(1).EQ.69) THEN
  434.                         IF (INCLVL.EQ.0)
  435.      +                     CALL DSERR('Unexpected "end of include" SED')
  436.                         INCLVL=MAX(0,INCLVL-1)
  437.                     ELSE
  438.                         CALL DSERR('Unrecognised "include" SED')
  439.                     END IF
  440.                 END IF
  441.             END IF
  442.             IF (ZYGNCM(IODCMT,CMTTXT).EQ.-2) GO TO 400
  443.         END IF
  444.  
  445. C End of comments for that statement -- see what to do
  446.  
  447.         NTYPE=ZYNTYP(SPTR)
  448.  
  449.         IF (INCLVL.NE.0) THEN
  450. C
  451. C INCLUDE checking:
  452. C   Mark things as "in_include" if:
  453. C       (A) COMMON blocks - the COMMON defn is in the INCLUDE
  454. C       (B) COMMON variables - the COMMON defn is in the INCLUDE
  455. C       (C) Typed variables - the type declaration is in the INCLUDE
  456. C           [This may overlap with (B)]
  457. C       (D) Implicit local arrays - the DIMENSION statement is in the INCLUDE
  458. C       (E) Typed parameters - the type stmt or parameter stmt in the incl
  459. C       (F) Untyped params - the PARAMETER stmt is in it
  460. C       (G) Statement functions - the defn/type is in the include.
  461. C
  462. C   NOT DONE:
  463. C       (1) Implicit local vars initialised by DATA in an include
  464. C       (2) Implicit local vars defined by an EQUIVALENCE in an include
  465. C       (3) Implicit local vars appearing only in a SAVE in an include
  466. C
  467. C   HOWEVER:
  468. C       The DATA/EQUIVALENCE/SAVE statements will not be output by ISTDS
  469. C       at all...
  470. C
  471.             IF (NTYPE.EQ.30 .OR. NTYPE.EQ.20) THEN
  472.                 PTR=ZYDOWN(SPTR)
  473.                 IF (NTYPE.EQ.30) PTR=ZYNEXT(PTR)
  474.  500            IF (ZYNTYP(PTR).EQ.108) THEN
  475.                     CALL ZYSABT(-ZYDOWN(PTR),6,2097152)
  476.                 ELSE
  477. C (Must be an array declarator)
  478.                     CALL ZYSABT(-ZYDOWN(ZYDOWN(PTR)),6,2097152)
  479.                 END IF
  480.                 PTR=ZYNEXT(PTR)
  481.                 IF (PTR.NE.0) GOTO 500
  482.             ELSE IF (NTYPE.EQ.26) THEN
  483.                 CALL ZYCHNT(SPTR,129)
  484.                 PTR=ZYDOWN(SPTR)
  485.  600            IF (ZYNTYP(PTR).EQ.28) THEN
  486.                     CALL ZYSABT(-ZYDOWN(ZYDOWN(PTR)),6,2097152)
  487.                     VPTR=ZYDOWN(ZYNEXT(ZYDOWN(PTR)))
  488.                 ELSE
  489.                     CALL ZYSABT(ZYFSYM(BLANKC,PUNUM,SYMBOL),
  490.      +                          6,2097152)
  491.                     VPTR=ZYDOWN(ZYDOWN(PTR))
  492.                 END IF
  493.  700            IF (ZYNTYP(VPTR).EQ.108) THEN
  494.                     CALL ZYSABT(-ZYDOWN(VPTR),6,2097152)
  495.                 ELSE
  496. C (Must be an array declarator)
  497.                     CALL ZYSABT(-ZYDOWN(ZYDOWN(VPTR)),6,2097152)
  498.                 END IF
  499.                 VPTR=ZYNEXT(VPTR)
  500.                 IF (VPTR.NE.0) GOTO 700
  501.                 PTR=ZYNEXT(PTR)
  502.                 IF (PTR.NE.0) GOTO 600
  503.             ELSE IF (NTYPE.EQ.35) THEN
  504.                 PTR=ZYDOWN(SPTR)
  505.  800            CALL ZYSABT(-ZYDOWN(ZYDOWN(PTR)),6,2097152)
  506.                 PTR=ZYNEXT(PTR)
  507.                 IF (PTR.NE.0) GOTO 800
  508.             ELSE IF (NTYPE.EQ.24) THEN
  509.                 CALL DSWARN('INCLUDEd EQUIVALENCE - Not fully checked')
  510.                 CALL ZYCHNT(SPTR,127)
  511.             ELSE IF (NTYPE.EQ.41) THEN
  512.                 CALL DSWARN('INCLUDEd DATA - Not fully checked')
  513.                 CALL ZYCHNT(SPTR,128)
  514.             ELSE IF (NTYPE.EQ.39) THEN
  515.                 CALL DSWARN('INCLUDEd SAVE - Not fully checked')
  516.                 CALL ZYCHNT(SPTR,130)
  517.             END IF
  518.         END IF
  519.  
  520. C Loop through all the specification statements
  521.  
  522.         IF (SPECP(NTYPE)) THEN
  523.             SPTR=ZYNEXT(SPTR)
  524.             SNUM=SNUM+1
  525.             STMTNO=STMTNO+1
  526.             GOTO 300
  527.         END IF
  528.  
  529.         IF (INCLVL.GT.0)
  530.      +      CALL DSWARN('INCLUDE''d file has 6 statements')
  531.  
  532. C =============================PART FOUR: Executable Statements
  533. C (This just keeps SNUM correct for comment fetching)
  534.  
  535.  900    SPTR=ZYNEXT(SPTR)
  536.         SNUM=SNUM+1
  537.         IF (SPTR.NE.0) GOTO 900
  538.  
  539.         END
  540. C ----------------------------------------------------------------------
  541. C
  542. C       P R O P U 1   -   Process Program-unit using mode=rebuild
  543. C
  544.  
  545.         SUBROUTINE PROPU1
  546.  
  547. C---------------------------------------------------------
  548. C    TOOLPACK/1    Release: 2.5
  549. C---------------------------------------------------------
  550.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  551.      +                STMTNO
  552.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  553.         LOGICAL DUMPED(22)
  554.  
  555.         SAVE /DSSTAT/
  556. C---------------------------------------------------------
  557. C    TOOLPACK/1    Release: 2.5
  558. C---------------------------------------------------------
  559.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  560.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  561.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  562.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  563.      +          INCLPR
  564.  
  565.         SAVE /DSOPTS/
  566. C---------------------------------------------------------
  567. C    TOOLPACK/1    Release: 2.5
  568. C---------------------------------------------------------
  569.         COMMON/DSIO/IODCMT,TKDESC
  570.         INTEGER IODCMT,TKDESC
  571.  
  572.         SAVE /DSIO/
  573. C---------------------------------------------------------
  574. C    TOOLPACK/1    Release: 2.5
  575. C---------------------------------------------------------
  576. C
  577. C  TKLAST = LAST TOKEN NUMBER
  578. C
  579.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  580.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  581.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  582.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  583.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  584.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  585.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  586.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  587.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  588.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  589.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  590.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  591.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  592.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  593.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  594.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  595.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  596.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  597.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  598.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  599.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  600.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  601.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  602.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  603.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  604.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  605.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  606.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  607.  
  608. C---------------------------------------------------------
  609. C    TOOLPACK/1    Release: 2.5
  610. C---------------------------------------------------------
  611.         COMMON/COMMNT/CMTTXT
  612.         INTEGER CMTTXT(1310)
  613.  
  614.         SAVE /COMMNT/
  615. C---------------------------------------------------------
  616. C    TOOLPACK/1    Release: 2.5
  617. C---------------------------------------------------------
  618.         COMMON/DSSPEC/SPECP
  619.         LOGICAL SPECP(132)
  620.  
  621.         SAVE /DSSPEC/
  622.  
  623.         LOGICAL T
  624.         PARAMETER (T=.TRUE.)
  625.  
  626.         INTEGER NXTSEC,SPTR,PTR,SYMBOL(8),NTYPE,BIND,ID(3),
  627.      +          TEXT(134),TXTPTR
  628.         LOGICAL MOVFMT,RAW
  629.  
  630.         INTEGER SEC
  631.         LOGICAL EXISTS
  632.  
  633.         INTEGER ZYNTYP,ZYDOWN,ZYNEXT,ZYPREV,ZYGTCM,ZYGNCM,LENGTH
  634.         EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYGTSY,YDTYPE,ZYPREV,ZYDELT,YLEAF,
  635.      +           YSTMT,ZTOKWR,ZYGTCM,ZYGNCM,LENGTH
  636.  
  637.         MOVFMT=.FALSE.
  638.         RAW=.TRUE.
  639.         STMTNO=1
  640. C First remove unused names if required of us
  641.         IF (VMODE.NE.2)  CALL REMUNU(VMODE.EQ.1)
  642.  
  643. C =============================PART ONE: [OPTIONAL] PROG UNIT HEADER
  644.  
  645.         IF (ZYNTYP(PUROOT).NE.2 .OR.
  646.      +      ZYNTYP(ZYDOWN(PUROOT)).EQ.7) THEN
  647. C There is a program header - output it with all its comments
  648.             IF (ZYGTCM(IODCMT,SNUM,CMTTXT).EQ.-2) THEN
  649.  100            CALL ZTOKWR(TCMMNT,LENGTH(CMTTXT),CMTTXT,TKDESC)
  650.                 IF (ZYGNCM(IODCMT,CMTTXT).EQ.-2) GO TO 100
  651.             END IF
  652. C Un-implicit the function header
  653.             IF (ZYNTYP(PUROOT).EQ.3) THEN
  654.                 PTR=ZYDOWN(ZYDOWN(PUROOT))
  655.                 IF (ZYNTYP(PTR).EQ.115) THEN
  656.                     CALL YLEAF(PTR,TKDESC)
  657.                     PTR=ZYNEXT(PTR)
  658.                     CALL ZYDELT(ZYPREV(PTR))
  659.                 END IF
  660.                 IF (ZYNTYP(PTR).EQ.108) THEN
  661.                     CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
  662.                     CALL YDTYPE(SYMBOL(4),SYMBOL(5),
  663.      +                          TKDESC)
  664.                 END IF
  665.             END IF
  666. C Output the program header
  667.             CALL YSTMT(ZYDOWN(PUROOT),TKDESC)
  668.             SNUM=SNUM+1
  669.             STMTNO=STMTNO+1
  670.             SPTR=ZYNEXT(ZYDOWN(PUROOT))
  671.         ELSE
  672.             SPTR=ZYDOWN(PUROOT)
  673.         END IF
  674.  
  675. C =============================PART TWO: DECLARATIVE SECTIONS
  676.  
  677. C Procedure: Output comments before each statement until we get to
  678. C            first executable or some other nasty type ...
  679.  
  680.  300    IF (ZYGTCM(IODCMT,SNUM,CMTTXT).EQ.-2) THEN
  681.  
  682.  400        NXTSEC=SEC()
  683.             IF (NXTSEC.EQ.-1) THEN
  684.                 IF (SECNUM.EQ.0) THEN
  685.                     CALL DSWARN('Unexpected End Of Section Marker')
  686.                 ELSE
  687.                     CALL PTDEC(SECNUM)
  688.                     SECNUM=-1
  689.                 END IF
  690.             ELSE IF (NXTSEC.GT.0) THEN
  691.                 IF (SECNUM.EQ.19) THEN
  692.                     CALL DSWARN('Unexpected section header removed')
  693.                     IF (.NOT.RAW) THEN
  694.                         CALL DSERR('Input sections in invalid order')
  695.                     ELSE IF (NXTSEC.EQ.19) THEN
  696.                         CALL DSWARN('Comments may be misplaced')
  697.                     ELSE
  698.                         CALL DSERR('Sections may be out of order')
  699.                     END IF
  700.                     NXTSEC=-2
  701.                 ELSE
  702.                     RAW=.FALSE.
  703.                     IF (SECNUM.GT.0 .AND. SECNUM.NE.19) THEN
  704.                         CALL PTDEC(SECNUM)
  705.                     END IF
  706.                     SECNUM=NXTSEC
  707.                 END IF
  708.             END IF
  709. C If we just hit stmtfns or data or exes, output remaining ordinary stuf
  710.             IF (NXTSEC.NE.0 .AND. (SECNUM.EQ.19 .OR.
  711.      +          SECNUM.EQ.18 .OR. SECNUM.EQ.22))
  712.      +          CALL DMPALL
  713. C Output data/stmtfns if just hit exes
  714.             IF (NXTSEC.NE.0 .AND.SECNUM.EQ.19) THEN
  715.                 IF (EXISTS(22).AND..NOT.DUMPED(22)) THEN
  716.                     CALL PUTHDR(22)
  717.                     CALL PTDEC(22)
  718.                 END IF
  719.                 IF (EXISTS(18) .AND..NOT.DUMPED(18)) THEN
  720.                     CALL PUTHDR(18)
  721.                     CALL PTDEC(18)
  722.                 END IF
  723.             END IF
  724. C Don't output (a) section trailers (already done by PTDEC)
  725. C              (b) exehdr if not wanted
  726. C              (c) misplaced (removed) section headers (same as (a))
  727.             IF (NXTSEC.GE.0  .AND. (NXTSEC.NE.19 .OR. EXEHDR))
  728.      +          CALL ZTOKWR(TCMMNT,LENGTH(CMTTXT),CMTTXT,TKDESC)
  729.             IF (NXTSEC.EQ.-1) SECNUM=0
  730.             IF (NXTSEC.EQ.-2) SECNUM=19
  731.             IF (ZYGNCM(IODCMT,CMTTXT).EQ.-2) GO TO 400
  732.         END IF
  733.  
  734. C End of comments for that statement type -- see what to do
  735.  
  736.         NTYPE=ZYNTYP(SPTR)
  737.  
  738. C Following is the paradigm for input without section headers:
  739. C   1)  Comments before the last specification statement will come
  740. C   immediately after the program-unit header;
  741. C   2)  Comments between the last specification statement and the
  742. C   first non-specification statement go into the section for that
  743. C   statement (i.e. DATA/SFDEF/EXE).  If there is no EXE section (i.e.
  744. C   the EXEHDR option is not used) comments for it will instead be
  745. C   placed with the other declarative comments (otherwise the ISTDS
  746. C   output may not be a fixed point - if the notrailers option is
  747. C   used, or the comment may be misplaced later if the program is
  748. C   changed such that another section is added).
  749. C   2)  If the first non-specification statement is a DATA statement,
  750. C   comments after the last specification statement and before the
  751. C   last consecutive DATA statement will be in the DATA section;
  752. C   3)  If the first non-specification statement is a statement function,
  753. C   comments are treated similarly to case 2 above but in the
  754. C   statement function definition section;
  755. C   4)  If case 2 applies, comments after the last DATA statement will
  756. C   either be placed in the SFDEF section (if existent) or in the EXE
  757. C   section.
  758. C   5) If there is no data or sfdef sections, comments after the last
  759. C   specification statement go into the EXE section.
  760. C
  761.         IF (RAW .AND. SPECP(NTYPE)) THEN
  762.             NTYPE=ZYNTYP(ZYNEXT(SPTR))
  763.             IF (SECNUM.EQ.0) THEN
  764.                 IF (NTYPE.EQ.41) THEN
  765.                     SECNUM=22
  766.                     CALL DMPALL
  767.                     CALL PUTHDR(22)
  768.                 ELSE IF (NTYPE.EQ.121) THEN
  769.                     SECNUM=18
  770.                     CALL DMPALL
  771.                     CALL PUTHDR(18)
  772.                 ELSE IF (EXEHDR .AND. .NOT.SPECP(NTYPE)) THEN
  773. C The DATA section may need to be forced out here...
  774.                     IF (EXISTS(22)) THEN
  775.                         CALL PUTHDR(22)
  776.                         CALL PTDEC(22)
  777.                     END IF
  778.                     SECNUM=19
  779.                     CALL DMPALL
  780.                     CALL PUTHDR(19)
  781.                 END IF
  782.             ELSE IF (SECNUM.EQ.22 .AND. NTYPE.EQ.121) THEN
  783.                 SECNUM=18
  784.                 CALL PTDEC(22)
  785.                 CALL PUTHDR(18)
  786.             ELSE IF (SECNUM.EQ.22 .AND. NTYPE.NE.41 .OR.
  787.      +          SECNUM.EQ.18 .AND. NTYPE.NE.121) THEN
  788.                 CALL PTDEC(SECNUM)
  789. C Again, the DATA section may need to be forced out...
  790.                 IF (EXISTS(22).AND..NOT.DUMPED(22)) THEN
  791.                     CALL PUTHDR(22)
  792.                     CALL PTDEC(22)
  793.                 END IF
  794.                 SECNUM=19
  795.                 IF (EXEHDR) CALL PUTHDR(19)
  796.             END IF
  797.             NTYPE=ZYNTYP(SPTR)
  798.         END IF
  799.  
  800. C The following loops through all the specification statements
  801.  
  802.         IF (SPECP(NTYPE)) THEN
  803.             IF (NTYPE.EQ.78) MOVFMT=.TRUE.
  804.             SPTR=ZYNEXT(SPTR)
  805.             SNUM=SNUM+1
  806.             STMTNO=STMTNO+1
  807.             GOTO 300
  808.         END IF
  809.  
  810. C We are now past the declarations bit
  811. C first output anything we were partway through
  812.  
  813.         IF (SECNUM.NE.0 .AND. SECNUM.NE.19) THEN
  814.             CALL PTDEC(SECNUM)
  815.             SECNUM=0
  816.         END IF
  817.  
  818. C Then check for anything left undone (unless we are within a section)
  819.  
  820.         IF (SECNUM.EQ.0) CALL DMPALL
  821.  
  822. C =============================PART THREE: Special Sections (SFDEF/DATA)
  823. C
  824. C (These are done in part two if the headers are already there).
  825.  
  826. C Check for DATA statements
  827.  
  828.         IF (EXISTS(22) .AND..NOT.DUMPED(22)) THEN
  829.             CALL PUTHDR(22)
  830.             CALL PTDEC(22)
  831.         END IF
  832.  
  833. C Ditto Statement Function Definitions
  834.  
  835.         IF (EXISTS(18) .AND..NOT.DUMPED(18)) THEN
  836.             CALL PUTHDR(18)
  837.             CALL PTDEC(18)
  838.         END IF
  839.  
  840. C =============================PART FOUR: Executable Statements
  841.  
  842. C Check to see if we need to put in an EXEHDR
  843.         IF (EXEHDR .AND. SECNUM.NE.19 .AND. NTYPE.NE.6)
  844.      +      CALL PUTHDR(19)
  845.  
  846.         PTR=SPTR
  847.  
  848.  500    NTYPE=ZYNTYP(SPTR)
  849.         IF (NTYPE.NE.41 .AND. NTYPE.NE.6 .AND.
  850.      +      NTYPE.NE.128) CALL YSTMT(SPTR,TKDESC)
  851.         SPTR=ZYNEXT(SPTR)
  852.         SNUM=SNUM+1
  853.         STMTNO=STMTNO+1
  854.         IF (SPTR.NE.0) THEN
  855.             IF (ZYGTCM(IODCMT,SNUM,CMTTXT).EQ.-2) THEN
  856.  600            CALL ZTOKWR(TCMMNT,LENGTH(CMTTXT),CMTTXT,TKDESC)
  857.                 IF (ZYGNCM(IODCMT,CMTTXT).EQ.-2) GO TO 600
  858.             END IF
  859.             GOTO 500
  860.         END IF
  861.  
  862. C Format statements are moved to the end
  863.         IF (MOVFMT) THEN
  864.             SPTR=ZYDOWN(PUROOT)
  865.  700        IF (ZYNTYP(SPTR).EQ.78) CALL YSTMT(SPTR,TKDESC)
  866.             SPTR=ZYNEXT(SPTR)
  867.             IF (SPTR.NE.PTR) GOTO 700
  868.         END IF
  869.  
  870. C Okay, now output the END statement
  871.         CALL YSTMT(ZYPREV(ZYDOWN(PUROOT)),TKDESC)
  872.  
  873.         END
  874. C ----------------------------------------------------------------------
  875. C
  876. C       P R O P U 2   -   Process program-unit using mode=declare
  877. C
  878.  
  879.         SUBROUTINE PROPU2
  880.  
  881. C---------------------------------------------------------
  882. C    TOOLPACK/1    Release: 2.5
  883. C---------------------------------------------------------
  884.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  885.      +                STMTNO
  886.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  887.         LOGICAL DUMPED(22)
  888.  
  889.         SAVE /DSSTAT/
  890. C---------------------------------------------------------
  891. C    TOOLPACK/1    Release: 2.5
  892. C---------------------------------------------------------
  893.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  894.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  895.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  896.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  897.      +          INCLPR
  898.  
  899.         SAVE /DSOPTS/
  900. C---------------------------------------------------------
  901. C    TOOLPACK/1    Release: 2.5
  902. C---------------------------------------------------------
  903.         COMMON/COMMNT/CMTTXT
  904.         INTEGER CMTTXT(1310)
  905.  
  906.         SAVE /COMMNT/
  907. C---------------------------------------------------------
  908. C    TOOLPACK/1    Release: 2.5
  909. C---------------------------------------------------------
  910.         COMMON/DSIO/IODCMT,TKDESC
  911.         INTEGER IODCMT,TKDESC
  912.  
  913.         SAVE /DSIO/
  914. C---------------------------------------------------------
  915. C    TOOLPACK/1    Release: 2.5
  916. C---------------------------------------------------------
  917. C
  918. C  TKLAST = LAST TOKEN NUMBER
  919. C
  920.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  921.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  922.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  923.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  924.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  925.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  926.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  927.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  928.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  929.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  930.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  931.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  932.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  933.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  934.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  935.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  936.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  937.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  938.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  939.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  940.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  941.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  942.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  943.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  944.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  945.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  946.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  947.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  948.  
  949.  
  950.         INTEGER NTYPE,NXTSEC,SPTR
  951.         LOGICAL INDECS
  952.  
  953.         INTEGER SEC
  954.         LOGICAL EXISTS
  955.  
  956.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYGTCM,ZYGNCM,LENGTH
  957.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYGTCM,ZYGNCM,LENGTH,YSTMT,
  958.      +           ZTOKWR
  959.  
  960.         SPTR=ZYDOWN(PUROOT)
  961.         INDECS=.TRUE.
  962.  100    IF (ZYGTCM(IODCMT,SNUM,CMTTXT).EQ.-2) THEN
  963.  200        CALL ZTOKWR(TCMMNT,LENGTH(CMTTXT),CMTTXT,TKDESC)
  964.             NXTSEC=SEC()
  965.             IF (NXTSEC.EQ.21) THEN
  966.                 CALL OUTDEC(21)
  967.             ELSE IF (NXTSEC.GT.0) THEN
  968.                 SECNUM=NXTSEC
  969.             END IF
  970.             IF (ZYGNCM(IODCMT,CMTTXT).EQ.-2) GO TO 200
  971.         END IF
  972.         IF (INDECS) THEN
  973.             NTYPE=ZYNTYP(SPTR)
  974.             IF (NTYPE.NE.30 .AND. NTYPE.NE.8 .AND.
  975.      +          NTYPE.NE.16 .AND. NTYPE.NE.7 .AND.
  976.      +          NTYPE.NE.19 .AND. NTYPE.NE.35 .AND.
  977.      +          NTYPE.NE.20 .AND. NTYPE.NE.26 .AND.
  978.      +          NTYPE.NE.37 .AND. NTYPE.NE.38 .AND.
  979.      +          NTYPE.NE.24 .AND. NTYPE.NE.39 .AND.
  980.      +          NTYPE.NE.32) THEN
  981.                 INDECS=.FALSE.
  982.                 IF (EXISTS(21) .AND. .NOT. DUMPED(21))
  983.      +          THEN
  984.                     CALL PUTHDR(21)
  985.                     CALL OUTDEC(21)
  986.                     CALL PUTEOS
  987.                 END IF
  988.                 IF (EXEHDR .AND. SECNUM.NE.19)
  989.      +              CALL PUTHDR(19)
  990.             END IF
  991.             IF (NTYPE.NE.32) CALL YSTMT(SPTR,TKDESC)
  992.         ELSE
  993.             CALL YSTMT(SPTR,TKDESC)
  994.         END IF
  995.         SNUM=SNUM+1
  996.         STMTNO=STMTNO+1
  997.         SPTR=ZYNEXT(SPTR)
  998.         IF (SPTR.NE.0) GOTO 100
  999.  
  1000.         END
  1001. C ----------------------------------------------------------------------
  1002. C
  1003. C       D M P A L L   -   Dump all declarative sections not yet done
  1004. C
  1005.  
  1006.         SUBROUTINE DMPALL
  1007.  
  1008. C---------------------------------------------------------
  1009. C    TOOLPACK/1    Release: 2.5
  1010. C---------------------------------------------------------
  1011.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  1012.      +                STMTNO
  1013.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  1014.         LOGICAL DUMPED(22)
  1015.  
  1016.         SAVE /DSSTAT/
  1017. C---------------------------------------------------------
  1018. C    TOOLPACK/1    Release: 2.5
  1019. C---------------------------------------------------------
  1020.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  1021.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  1022.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  1023.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  1024.      +          INCLPR
  1025.  
  1026.         SAVE /DSOPTS/
  1027.  
  1028.         INTEGER I
  1029.  
  1030.         LOGICAL EXISTS
  1031.  
  1032.         DO 100 I=1,17
  1033.             IF (.NOT.DUMPED(I)) THEN
  1034.                 IF (EXISTS(I)) THEN
  1035.                     CALL PUTHDR(I)
  1036.                     CALL OUTDEC(I)
  1037.                     IF (.NOT. NOTRAI) CALL PUTEOS
  1038.                 END IF
  1039.             END IF
  1040.  100    CONTINUE
  1041.  
  1042.         END
  1043. C ----------------------------------------------------------------------
  1044. C
  1045. C       P T D E C   -   Put a declarative section into the output
  1046. C
  1047.  
  1048.         SUBROUTINE PTDEC(N)
  1049.         INTEGER N
  1050.  
  1051. C---------------------------------------------------------
  1052. C    TOOLPACK/1    Release: 2.5
  1053. C---------------------------------------------------------
  1054.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  1055.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  1056.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  1057.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  1058.      +          INCLPR
  1059.  
  1060.         SAVE /DSOPTS/
  1061.  
  1062.         LOGICAL EXISTS
  1063.  
  1064.         EXTERNAL ZPTINT,ZCHOUT
  1065.  
  1066.         IF (EXISTS(N)) THEN
  1067.             CALL OUTDEC(N)
  1068.         ELSE
  1069.             CALL ZCHOUT('Warning: Empty declarative section requested'//
  1070.      +                  ' (section ',2)
  1071.             CALL ZPTINT(N,1,2)
  1072.             CALL ZCHOUT(')',2)
  1073.             CALL DSNAME
  1074.         END IF
  1075.         IF (.NOT.NOTRAI) CALL PUTEOS
  1076.  
  1077.         END
  1078. C ----------------------------------------------------------------------
  1079. C
  1080. C       S R T I D X   -   Sort symbol index
  1081. C
  1082. C       Sort key: Symbol type (then) Data type (then) Current position
  1083. C                 (Current position is as sorted by name)
  1084. C
  1085.  
  1086.         SUBROUTINE SRTIDX
  1087.  
  1088. C---------------------------------------------------------
  1089. C    TOOLPACK/1    Release: 2.5
  1090. C---------------------------------------------------------
  1091.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  1092.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  1093.      +          SDTYPE(5003),SCHLEN(5003),
  1094.      +          SBITS(5003)
  1095.  
  1096.         SAVE /DSSYMS/
  1097.  
  1098.         INTEGER I,J,K,T1,T2,T3,T4,T5
  1099.  
  1100.         LOGICAL LESS
  1101.  
  1102. C We will use a form of straight insertion
  1103.         DO 300 I=2,NSYMS
  1104.             J=I-1
  1105. C while J>1 and a(i).lt.a(j) do j=j-1
  1106.  100        IF (J.GE.1 .AND. LESS(I,J)) THEN
  1107.                 J=J-1
  1108.                 GOTO 100
  1109.             END IF
  1110.             J=J+1
  1111.             T1=STYPE(I)
  1112.             T2=SDTYPE(I)
  1113.             T3=SCHLEN(I)
  1114.             T4=SYMIDX(I)
  1115.             T5=SBITS(I)
  1116.             DO 200 K=I,J+1,-1
  1117.                 STYPE(K)=STYPE(K-1)
  1118.                 SDTYPE(K)=SDTYPE(K-1)
  1119.                 SCHLEN(K)=SCHLEN(K-1)
  1120.                 SBITS(K)=SBITS(K-1)
  1121.  200            SYMIDX(K)=SYMIDX(K-1)
  1122.             STYPE(J)=T1
  1123.             SDTYPE(J)=T2
  1124.             SCHLEN(J)=T3
  1125.             SYMIDX(J)=T4
  1126.             SBITS(J)=T5
  1127.  300    CONTINUE
  1128.         END
  1129. C ----------------------------------------------------------------------
  1130. C
  1131. C       L E S S   -   Return .TRUE. iff symbol[i].lt.symbol[j]
  1132. C
  1133.  
  1134.         LOGICAL FUNCTION LESS(I,J)
  1135.         INTEGER I,J,IDORD,JDORD
  1136.  
  1137. C---------------------------------------------------------
  1138. C    TOOLPACK/1    Release: 2.5
  1139. C---------------------------------------------------------
  1140.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  1141.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  1142.      +          SDTYPE(5003),SCHLEN(5003),
  1143.      +          SBITS(5003)
  1144.  
  1145.         SAVE /DSSYMS/
  1146. C---------------------------------------------------------
  1147. C    TOOLPACK/1    Release: 2.5
  1148. C---------------------------------------------------------
  1149.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  1150.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  1151.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  1152.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  1153.      +          INCLPR
  1154.  
  1155.         SAVE /DSOPTS/
  1156.  
  1157.         IF (J.LT.1) THEN
  1158.             LESS=.FALSE.
  1159.             RETURN
  1160.         ENDIF
  1161.         IF (SDTYPE(I).EQ.4 .AND. SCHLEN(I).EQ.16) THEN
  1162.             IDORD=DORDER(7)
  1163.         ELSE
  1164.             IDORD=DORDER(SDTYPE(I))
  1165.         ENDIF
  1166.         IF (SDTYPE(J).EQ.4 .AND. SCHLEN(J).EQ.16) THEN
  1167.             JDORD=DORDER(7)
  1168.         ELSE
  1169.             JDORD=DORDER(SDTYPE(J))
  1170.         ENDIF
  1171.         IF (STYPE(I).LT.STYPE(J)) THEN
  1172.             LESS=.TRUE.
  1173.         ELSE IF (STYPE(I).GT.STYPE(J)) THEN
  1174.             LESS=.FALSE.
  1175.         ELSE IF (STYPE(I).EQ.12) THEN
  1176.             LESS=.FALSE.
  1177.         ELSE IF (IDORD.LT.JDORD) THEN
  1178.             LESS=.TRUE.
  1179.         ELSE IF (IDORD.GT.JDORD) THEN
  1180.             LESS=.FALSE.
  1181.         ELSE IF (SDTYPE(I).EQ.6) THEN
  1182.             IF (SCHLEN(I).GE.0 .AND. SCHLEN(J).GE.0) THEN
  1183.                 LESS=SCHLEN(I).LT.SCHLEN(J)
  1184.             ELSE
  1185.                 LESS=SCHLEN(I).GT.SCHLEN(J)
  1186.             END IF
  1187.         ELSE IF (SCHLEN(I).EQ.SCHLEN(J)) THEN
  1188.             LESS=.FALSE.
  1189.         ELSE IF (SDTYPE(I).EQ.1 .OR.
  1190.      +           SDTYPE(I).EQ.3) THEN
  1191.             IF (SCHLEN(I).EQ.0) THEN
  1192.                 LESS=.TRUE.
  1193.             ELSE IF (SCHLEN(J).EQ.0) THEN
  1194.                 LESS=.FALSE.
  1195.             ELSE
  1196.                 LESS=SCHLEN(I).GT.SCHLEN(J)
  1197.             END IF
  1198.         ELSE
  1199.             LESS=SCHLEN(I).GT.SCHLEN(J)
  1200.         END IF
  1201.  
  1202.         END
  1203. C ======================================================================
  1204. C
  1205. C       D S   V I R T U A L   M A C H I N E   L E V E L   O N E
  1206. C
  1207. C ======================================================================
  1208. C ----------------------------------------------------------------------
  1209. C
  1210. C       O U T D E C   -   Output a declarative section
  1211. C
  1212.  
  1213.         SUBROUTINE OUTDEC(N)
  1214.         INTEGER N
  1215.  
  1216. C---------------------------------------------------------
  1217. C    TOOLPACK/1    Release: 2.5
  1218. C---------------------------------------------------------
  1219.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  1220.      +                STMTNO
  1221.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  1222.         LOGICAL DUMPED(22)
  1223.  
  1224.         SAVE /DSSTAT/
  1225. C---------------------------------------------------------
  1226. C    TOOLPACK/1    Release: 2.5
  1227. C---------------------------------------------------------
  1228. C
  1229. C  TKLAST = LAST TOKEN NUMBER
  1230. C
  1231.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1232.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1233.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1234.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1235.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1236.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1237.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1238.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1239.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1240.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1241.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1242.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1243.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1244.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1245.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1246.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1247.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1248.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1249.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1250.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1251.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1252.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1253.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1254.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1255.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1256.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1257.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1258.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1259.  
  1260.  
  1261.         EXTERNAL ZCHOUT,ZPTINT,ERROR
  1262.  
  1263.         IF (DUMPED(N)) THEN
  1264.             CALL ZCHOUT('Warning: Request for duplicate section ',2)
  1265.             CALL ZPTINT(N,1,2)
  1266.             CALL DSNAME
  1267.             RETURN
  1268.         END IF
  1269.  
  1270.         IF (N.EQ.11 .OR. N.EQ.5) THEN
  1271.             CALL OUTLST(TEXTER,N)
  1272.         ELSE IF (N.EQ.12) THEN
  1273.             CALL OUTLST(TINTRI,N)
  1274.         ELSE IF (N.EQ.1) THEN
  1275.             CALL OUTPAR
  1276.         ELSE IF (N.EQ.13) THEN
  1277.             CALL OUTCMN
  1278.         ELSE IF (N.LE.15) THEN
  1279.             CALL OUTSD(N)
  1280.             IF (N.EQ.10 .OR. N.EQ.4) CALL OUTLST(TEXTER,N)
  1281.             IF (N.EQ.15) CALL OUTSPD(18)
  1282.         ELSE IF (N.EQ.16) THEN
  1283.             CALL OUTSPD(24)
  1284.         ELSE IF (N.EQ.17) THEN
  1285.             CALL OUTSAV
  1286.         ELSE IF (N.EQ.21) THEN
  1287.             CALL OUTUND
  1288.         ELSE IF (N.EQ.18) THEN
  1289.             CALL OUTSPD(121)
  1290.         ELSE IF (N.EQ.22) THEN
  1291.             CALL OUTSPC(41)
  1292.         ELSE
  1293.             CALL ERROR('Internal Error: Invalid call to OUTDEC')
  1294.         END IF
  1295.  
  1296.         DUMPED(N)=.TRUE.
  1297.  
  1298.         END
  1299. C ----------------------------------------------------------------------
  1300. C
  1301. C       R E M U N U   -   Remove unused names from our internal symbols
  1302. C
  1303.  
  1304.         SUBROUTINE REMUNU(LOG)
  1305.         LOGICAL LOG
  1306.  
  1307. C---------------------------------------------------------
  1308. C    TOOLPACK/1    Release: 2.5
  1309. C---------------------------------------------------------
  1310.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  1311.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  1312.      +          SDTYPE(5003),SCHLEN(5003),
  1313.      +          SBITS(5003)
  1314.  
  1315.         SAVE /DSSYMS/
  1316. C---------------------------------------------------------
  1317. C    TOOLPACK/1    Release: 2.5
  1318. C---------------------------------------------------------
  1319.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  1320.      +                STMTNO
  1321.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  1322.         LOGICAL DUMPED(22)
  1323.  
  1324.         SAVE /DSSTAT/
  1325.  
  1326.         INTEGER I,J,TEXT(134),SYMBOL(8),SAVNUM
  1327.  
  1328.         INTEGER ZIAND
  1329.         EXTERNAL ZIAND,ZYGTSY,ZYGTST,ZCHOUT,PUTLIN
  1330.  
  1331.         SAVNUM=STMTNO
  1332.         STMTNO=0
  1333.         DO 200 I=NSYMS,1,-1
  1334.             IF ((STYPE(I).EQ.9 .OR. STYPE(I).EQ.8 .OR.
  1335.      +           STYPE(I).EQ.10 .OR. STYPE(I).EQ.11 .OR.
  1336.      +           STYPE(I).EQ.12 .OR. STYPE(I).EQ.1) .AND.
  1337.      +           ZIAND(SBITS(I),125936).EQ.0)
  1338.      +      THEN
  1339.                 IF (LOG) THEN
  1340.                     CALL ZCHOUT('Warning: Removing unu'//'sed name "',
  1341.      +                          2)
  1342.                     CALL ZYGTSY(SYMIDX(I),SYMBOL)
  1343.                     CALL ZYGTST(SYMBOL(2),TEXT)
  1344.                     CALL PUTLIN(TEXT,2)
  1345.                     CALL ZCHOUT('" ',2)
  1346.                     CALL DSNAME
  1347.                 END IF
  1348.                 DO 100 J=I+1,NSYMS
  1349.                     STYPE(J-1)=STYPE(J)
  1350.                     SDTYPE(J-1)=SDTYPE(J)
  1351.                     SYMIDX(J-1)=SYMIDX(J)
  1352.                     SCHLEN(J-1)=SCHLEN(J)
  1353.                     SBITS(J-1)=SBITS(J)
  1354.  100            CONTINUE
  1355.                 NSYMS=NSYMS-1
  1356.             END IF
  1357.  200    CONTINUE
  1358.         STMTNO=SAVNUM
  1359.  
  1360.         END
  1361. C ======================================================================
  1362. C
  1363. C       D S   V I R T U A L   M A C H I N E   L E V E L   Z E R O
  1364. C
  1365. C ======================================================================
  1366. C ----------------------------------------------------------------------
  1367. C
  1368. C       P U T E O S   -   Output an end-of-section marker
  1369. C
  1370.  
  1371.         SUBROUTINE PUTEOS
  1372.  
  1373. C---------------------------------------------------------
  1374. C    TOOLPACK/1    Release: 2.5
  1375. C---------------------------------------------------------
  1376.         COMMON/DSIO/IODCMT,TKDESC
  1377.         INTEGER IODCMT,TKDESC
  1378.  
  1379.         SAVE /DSIO/
  1380. C---------------------------------------------------------
  1381. C    TOOLPACK/1    Release: 2.5
  1382. C---------------------------------------------------------
  1383. C
  1384. C  TKLAST = LAST TOKEN NUMBER
  1385. C
  1386.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1387.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1388.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1389.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1390.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1391.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1392.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1393.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1394.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1395.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1396.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1397.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1398.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1399.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1400.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1401.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1402.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1403.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1404.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1405.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1406.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1407.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1408.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1409.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1410.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1411.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1412.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1413.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1414.  
  1415.  
  1416.         INTEGER EOSTXT(9)
  1417.  
  1418.         SAVE EOSTXT
  1419.  
  1420.         EXTERNAL ZTOKWR
  1421.  
  1422.         DATA EOSTXT/67,32,32,32,32,32,46,46,129/
  1423.  
  1424.         CALL ZTOKWR(TCMMNT,8,EOSTXT,TKDESC)
  1425.  
  1426.         END
  1427. C ----------------------------------------------------------------------
  1428. C
  1429. C       P U T H D R   -   Output a section header
  1430. C
  1431.  
  1432.         SUBROUTINE PUTHDR(N)
  1433.         INTEGER N
  1434.  
  1435. C---------------------------------------------------------
  1436. C    TOOLPACK/1    Release: 2.5
  1437. C---------------------------------------------------------
  1438.         COMMON/DSTEXT/ SHTEXT,OLDTXT
  1439.         INTEGER SHTEXT(43,0:22),OLDTXT(43,10:11)
  1440.  
  1441.         SAVE /DSTEXT/
  1442. C---------------------------------------------------------
  1443. C    TOOLPACK/1    Release: 2.5
  1444. C---------------------------------------------------------
  1445.         COMMON/DSIO/IODCMT,TKDESC
  1446.         INTEGER IODCMT,TKDESC
  1447.  
  1448.         SAVE /DSIO/
  1449. C---------------------------------------------------------
  1450. C    TOOLPACK/1    Release: 2.5
  1451. C---------------------------------------------------------
  1452. C
  1453. C  TKLAST = LAST TOKEN NUMBER
  1454. C
  1455.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1456.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1457.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1458.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1459.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1460.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1461.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1462.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1463.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1464.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1465.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1466.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1467.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1468.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1469.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1470.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1471.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1472.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1473.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1474.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1475.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1476.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1477.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1478.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1479.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1480.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1481.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1482.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1483.  
  1484. C---------------------------------------------------------
  1485. C    TOOLPACK/1    Release: 2.5
  1486. C---------------------------------------------------------
  1487.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  1488.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  1489.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  1490.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  1491.      +          INCLPR
  1492.  
  1493.         SAVE /DSOPTS/
  1494.  
  1495.         INTEGER LENGTH
  1496.         EXTERNAL LENGTH,ZTOKWR
  1497.  
  1498.         IF ((N.EQ.10 .OR. N.EQ.11) .AND.
  1499.      +      (OLDFMT .AND. .NOT. CNVOLD)) THEN
  1500.             CALL ZTOKWR(TCMMNT,LENGTH(OLDTXT(1,N)),OLDTXT(1,N),TKDESC)
  1501.         ELSE
  1502.             CALL ZTOKWR(TCMMNT,LENGTH(SHTEXT(1,N)),SHTEXT(1,N),TKDESC)
  1503.         END IF
  1504.  
  1505.         END
  1506. C ----------------------------------------------------------------------
  1507. C
  1508. C       S E C   -   Return section number or -1 for endsec or 0 o/w
  1509. C
  1510.  
  1511.         INTEGER FUNCTION SEC()
  1512.  
  1513. C---------------------------------------------------------
  1514. C    TOOLPACK/1    Release: 2.5
  1515. C---------------------------------------------------------
  1516.         COMMON/DSTEXT/ SHTEXT,OLDTXT
  1517.         INTEGER SHTEXT(43,0:22),OLDTXT(43,10:11)
  1518.  
  1519.         SAVE /DSTEXT/
  1520. C---------------------------------------------------------
  1521. C    TOOLPACK/1    Release: 2.5
  1522. C---------------------------------------------------------
  1523.         COMMON/COMMNT/CMTTXT
  1524.         INTEGER CMTTXT(1310)
  1525.  
  1526.         SAVE /COMMNT/
  1527. C---------------------------------------------------------
  1528. C    TOOLPACK/1    Release: 2.5
  1529. C---------------------------------------------------------
  1530.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  1531.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  1532.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  1533.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  1534.      +          INCLPR
  1535.  
  1536.         SAVE /DSOPTS/
  1537.  
  1538.         INTEGER PNTR,I,S
  1539.         LOGICAL EQUAL
  1540.  
  1541.         INTEGER ZUPPER
  1542.         EXTERNAL SKIPBL,ZCHOUT,PUTLIN,ZUPPER,SCOPY
  1543.  
  1544.         SEC=0
  1545.         IF (CMTTXT(1).EQ.129) RETURN
  1546.         PNTR=2
  1547.         CALL SKIPBL(CMTTXT,PNTR)
  1548.         IF (CMTTXT(PNTR).NE.46) RETURN
  1549.         IF (CMTTXT(PNTR+1).NE.46) RETURN
  1550.         IF (CMTTXT(PNTR+2).EQ.129) THEN
  1551.             SEC=-1
  1552.             CALL SCOPY(SHTEXT(1,0),1,CMTTXT,1)
  1553.             RETURN
  1554.         END IF
  1555.         DO 200 S=1,22
  1556.             I=0
  1557.  100        I=I+1
  1558.             EQUAL=(ZUPPER(SHTEXT(9+I,S)).EQ.ZUPPER(CMTTXT(PNTR+2+I)))
  1559.             IF (EQUAL .AND. CMTTXT(PNTR+2+I).NE.129) GOTO 100
  1560.             IF (EQUAL) THEN
  1561.                 CALL SCOPY(SHTEXT(1,S),1,CMTTXT,1)
  1562.                 SEC=S
  1563.                 RETURN
  1564.             END IF
  1565.  200    CONTINUE
  1566.         IF (OLDFMT) THEN
  1567.             DO 400 S=10,11
  1568.                 I=0
  1569.  300            I=I+1
  1570.                 EQUAL=(ZUPPER(OLDTXT(9+I,S)) .EQ.
  1571.      +                 ZUPPER(CMTTXT(PNTR+2+I)))
  1572.                 IF (EQUAL .AND. CMTTXT(PNTR+2+I).NE.129) GOTO 300
  1573.                 IF (EQUAL) THEN
  1574.                     IF (CNVOLD) THEN
  1575.                         CALL SCOPY(SHTEXT(1,S),1,CMTTXT,1)
  1576.                     ELSE
  1577.                         CALL SCOPY(OLDTXT(1,S),1,CMTTXT,1)
  1578.                     END IF
  1579.                     SEC=S
  1580.                     RETURN
  1581.                 END IF
  1582.  400        CONTINUE
  1583.         END IF
  1584.         CALL ZCHOUT('Warning: Unknown section header - "',2)
  1585.         CALL PUTLIN(CMTTXT(PNTR),2)
  1586.         CALL ZCHOUT('" - ignored',2)
  1587.         CALL DSNAME
  1588.         SEC=0
  1589.  
  1590.         END
  1591. C ----------------------------------------------------------------------
  1592. C
  1593. C       E X I S T S   -   Say whether a section exists or not
  1594. C
  1595.  
  1596.         LOGICAL FUNCTION EXISTS(N)
  1597.         INTEGER N
  1598.  
  1599. C---------------------------------------------------------
  1600. C    TOOLPACK/1    Release: 2.5
  1601. C---------------------------------------------------------
  1602.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  1603.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  1604.      +          SDTYPE(5003),SCHLEN(5003),
  1605.      +          SBITS(5003)
  1606.  
  1607.         SAVE /DSSYMS/
  1608. C---------------------------------------------------------
  1609. C    TOOLPACK/1    Release: 2.5
  1610. C---------------------------------------------------------
  1611.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  1612.      +                STMTNO
  1613.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  1614.         LOGICAL DUMPED(22)
  1615.  
  1616.         SAVE /DSSTAT/
  1617. C---------------------------------------------------------
  1618. C    TOOLPACK/1    Release: 2.5
  1619. C---------------------------------------------------------
  1620.         COMMON/DSSPEC/SPECP
  1621.         LOGICAL SPECP(132)
  1622.  
  1623.         SAVE /DSSPEC/
  1624.  
  1625.         LOGICAL T
  1626.         PARAMETER (T=.TRUE.)
  1627.  
  1628.         INTEGER I,PTR,REQTYP,NTYPE
  1629.         LOGICAL CHKALL
  1630.  
  1631.         LOGICAL EXIUND
  1632.  
  1633.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP
  1634.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ERROR
  1635.  
  1636.         IF (N.LE.15) THEN
  1637.             I=0
  1638.  100        I=I+1
  1639.             IF (STYPE(I).LT.N .AND. I.LT.NSYMS) GOTO 100
  1640.             EXISTS=STYPE(I).EQ.N
  1641.             IF (N.NE.15 .OR..NOT.EXISTS) RETURN
  1642. C ENTRY section exists either if function (sdtype>0) or an entry stmt
  1643. C occurs in the declaratives
  1644.             IF (SDTYPE(I).GT.0) RETURN
  1645.         END IF
  1646. C
  1647.         CHKALL=.FALSE.
  1648.         IF (N.EQ.16) THEN
  1649.             REQTYP=24
  1650.         ELSE IF (N.EQ.17) THEN
  1651.             REQTYP=39
  1652.         ELSE IF (N.EQ.18) THEN
  1653.             REQTYP=121
  1654.         ELSE IF (N.EQ.22) THEN
  1655.             REQTYP=41
  1656.             CHKALL=.TRUE.
  1657.         ELSE IF (N.EQ.15) THEN
  1658.             REQTYP=18
  1659.         ELSE IF (N.EQ.21) THEN
  1660.             EXISTS=EXIUND()
  1661.             RETURN
  1662.         ELSE
  1663.             CALL ERROR('Internal Error: Invalid EXISTS call')
  1664.             EXISTS=.FALSE.
  1665.             RETURN
  1666.         END IF
  1667.         PTR=ZYDOWN(PUROOT)
  1668.         EXISTS=.FALSE.
  1669.  
  1670.         IF (CHKALL) THEN
  1671.  200        IF (ZYNTYP(PTR).EQ.REQTYP) THEN
  1672.                 EXISTS=.TRUE.
  1673.             ELSE
  1674.                 PTR=ZYNEXT(PTR)
  1675.                 IF (PTR.NE.0) GOTO 200
  1676.             END IF
  1677.         ELSE
  1678.  300        NTYPE=ZYNTYP(PTR)
  1679.             IF (NTYPE.EQ.REQTYP) THEN
  1680.                 EXISTS=.TRUE.
  1681.             ELSE IF (SPECP(NTYPE)) THEN
  1682.                 PTR=ZYNEXT(PTR)
  1683.                 IF (PTR.NE.0) GOTO 300
  1684.             END IF
  1685.         END IF
  1686.  
  1687.         END
  1688. C ----------------------------------------------------------------------
  1689. C
  1690. C       E X I U N D   -   Any undeclared (untyped) names?
  1691. C
  1692.  
  1693.         LOGICAL FUNCTION EXIUND()
  1694.  
  1695. C---------------------------------------------------------
  1696. C    TOOLPACK/1    Release: 2.5
  1697. C---------------------------------------------------------
  1698.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  1699.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  1700.      +          SDTYPE(5003),SCHLEN(5003),
  1701.      +          SBITS(5003)
  1702.  
  1703.         SAVE /DSSYMS/
  1704.  
  1705.         INTEGER I
  1706.  
  1707.         INTEGER ZIAND
  1708.         EXTERNAL ZIAND
  1709.  
  1710.         DO 100 I=1,NSYMS
  1711.             IF (SDTYPE(I).GT.0 .AND. STYPE(I).NE.12 .AND.
  1712.      +          ZIAND(SBITS(I),8).EQ.0) THEN
  1713.                 EXIUND=.TRUE.
  1714.                 RETURN
  1715.             END IF
  1716.  100    CONTINUE
  1717.         EXIUND=.FALSE.
  1718.  
  1719.         END
  1720. C ----------------------------------------------------------------------
  1721. C
  1722. C       O U T L S T   -   Output a list of symbol names preceded by a
  1723. C                         token (TEXTER or TINTRI)
  1724. C
  1725.  
  1726.         SUBROUTINE OUTLST(TOKEN,N)
  1727.         INTEGER TOKEN,N
  1728.  
  1729. C---------------------------------------------------------
  1730. C    TOOLPACK/1    Release: 2.5
  1731. C---------------------------------------------------------
  1732.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  1733.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  1734.      +          SDTYPE(5003),SCHLEN(5003),
  1735.      +          SBITS(5003)
  1736.  
  1737.         SAVE /DSSYMS/
  1738. C---------------------------------------------------------
  1739. C    TOOLPACK/1    Release: 2.5
  1740. C---------------------------------------------------------
  1741.         COMMON/DSIO/IODCMT,TKDESC
  1742.         INTEGER IODCMT,TKDESC
  1743.  
  1744.         SAVE /DSIO/
  1745. C---------------------------------------------------------
  1746. C    TOOLPACK/1    Release: 2.5
  1747. C---------------------------------------------------------
  1748. C
  1749. C  TKLAST = LAST TOKEN NUMBER
  1750. C
  1751.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1752.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1753.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1754.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1755.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1756.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1757.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1758.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1759.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1760.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1761.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1762.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1763.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1764.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1765.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1766.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1767.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1768.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1769.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1770.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1771.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1772.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1773.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1774.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1775.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1776.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1777.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1778.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1779.  
  1780.  
  1781.         INTEGER I,DUMMY(2),SYMBOL(8),TEXT(134)
  1782.  
  1783.         INTEGER LENGTH
  1784.         EXTERNAL ZTOKWR,LENGTH,ZYGTSY,ZYGTST
  1785.  
  1786.         DATA DUMMY(1)/129/
  1787.  
  1788.         I=0
  1789.  
  1790.  100    I=I+1
  1791.         IF (I.LT.NSYMS .AND. STYPE(I).NE.N) GOTO 100
  1792.         IF (STYPE(I).NE.N .OR. I.GT.NSYMS) RETURN
  1793.         CALL ZTOKWR(TOKEN,0,DUMMY,TKDESC)
  1794.  
  1795.  200    CALL ZYGTSY(SYMIDX(I),SYMBOL)
  1796.         CALL ZYGTST(SYMBOL(2),TEXT)
  1797.         CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
  1798.         I=I+1
  1799.         IF (I.LE.NSYMS .AND. STYPE(I).EQ.N) THEN
  1800.             CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  1801.             GOTO 200
  1802.         END IF
  1803.         CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  1804.  
  1805.         END
  1806. C ----------------------------------------------------------------------
  1807. C
  1808. C       O U T S D   -   Output a simple (type) declaration
  1809. C
  1810.  
  1811.         SUBROUTINE OUTSD(N)
  1812.         INTEGER N
  1813.  
  1814. C---------------------------------------------------------
  1815. C    TOOLPACK/1    Release: 2.5
  1816. C---------------------------------------------------------
  1817.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  1818.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  1819.      +          SDTYPE(5003),SCHLEN(5003),
  1820.      +          SBITS(5003)
  1821.  
  1822.         SAVE /DSSYMS/
  1823. C---------------------------------------------------------
  1824. C    TOOLPACK/1    Release: 2.5
  1825. C---------------------------------------------------------
  1826.         COMMON/DSIO/IODCMT,TKDESC
  1827.         INTEGER IODCMT,TKDESC
  1828.  
  1829.         SAVE /DSIO/
  1830. C---------------------------------------------------------
  1831. C    TOOLPACK/1    Release: 2.5
  1832. C---------------------------------------------------------
  1833.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  1834.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  1835.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  1836.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  1837.      +          INCLPR
  1838.  
  1839.         SAVE /DSOPTS/
  1840. C---------------------------------------------------------
  1841. C    TOOLPACK/1    Release: 2.5
  1842. C---------------------------------------------------------
  1843. C
  1844. C  TKLAST = LAST TOKEN NUMBER
  1845. C
  1846.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1847.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1848.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1849.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1850.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1851.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1852.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1853.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1854.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1855.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1856.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1857.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1858.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1859.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1860.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1861.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1862.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1863.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1864.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1865.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1866.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1867.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1868.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1869.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1870.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1871.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1872.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1873.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1874.  
  1875.  
  1876.         SAVE DUMMY
  1877.  
  1878.         INTEGER I,LTYPE,DUMMY(2),LCHLEN,TEXT(134),SYMBOL(8)
  1879.  
  1880.         INTEGER LENGTH,ZYNTYP
  1881.         EXTERNAL ZTOKWR,LENGTH,ZYNTYP,ZYGTSY,ZYGTST,YDTYPE,YCHLEN,YARDCL
  1882.  
  1883.         DATA DUMMY(1)/129/
  1884.  
  1885.         LTYPE=0
  1886.         LCHLEN=0
  1887.         I=0
  1888.  
  1889.  100    I=I+1
  1890.         IF (I.LT.NSYMS .AND. STYPE(I).NE.N) GOTO 100
  1891.  
  1892.         IF (STYPE(I).NE.N .OR. I.GT.NSYMS) RETURN
  1893.  
  1894.  200    IF (LTYPE.NE.SDTYPE(I) .OR.
  1895.      +      (LCHLEN.NE.SCHLEN(I) .AND. (CHLBRK.OR.LTYPE.NE.6)))
  1896.      +  THEN
  1897.             IF (SDTYPE(I).EQ.-1) RETURN
  1898.             IF (LTYPE.NE.0) CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  1899.             IF (CHLBRK .OR. SDTYPE(I).NE.6) THEN
  1900.                 CALL YDTYPE(SDTYPE(I),SCHLEN(I),TKDESC)
  1901.                 LCHLEN=SCHLEN(I)
  1902.             ELSE
  1903.                 CALL YDTYPE(SDTYPE(I),0,TKDESC)
  1904.                 LCHLEN=0
  1905.             END IF
  1906.             LTYPE=SDTYPE(I)
  1907.         ELSE
  1908.             CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  1909.         END IF
  1910.         CALL ZYGTSY(SYMIDX(I),SYMBOL)
  1911.         CALL ZYGTST(SYMBOL(2),TEXT)
  1912.         CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
  1913.         IF (SYMBOL(1).EQ.5 .AND.
  1914.      +      SYMBOL(7).NE.0 .AND.
  1915.      +      (N.NE.7 .OR. .NOT. ARDICB))
  1916.      +      CALL YARDCL(SYMBOL(7),TKDESC)
  1917.         IF (SCHLEN(I).NE.LCHLEN) CALL YCHLEN(SCHLEN(I),TKDESC)
  1918.         I=I+1
  1919.         IF (STYPE(I).EQ.N .AND. I.LE.NSYMS) GOTO 200
  1920.         CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  1921.  
  1922.         END
  1923. C ----------------------------------------------------------------------
  1924. C
  1925. C       O U T S A V   -   Output a SAVE statement
  1926. C
  1927.  
  1928.         SUBROUTINE OUTSAV
  1929.  
  1930. C---------------------------------------------------------
  1931. C    TOOLPACK/1    Release: 2.5
  1932. C---------------------------------------------------------
  1933.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  1934.      +                STMTNO
  1935.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  1936.         LOGICAL DUMPED(22)
  1937.  
  1938.         SAVE /DSSTAT/
  1939. C---------------------------------------------------------
  1940. C    TOOLPACK/1    Release: 2.5
  1941. C---------------------------------------------------------
  1942.         COMMON/DSIO/IODCMT,TKDESC
  1943.         INTEGER IODCMT,TKDESC
  1944.  
  1945.         SAVE /DSIO/
  1946. C---------------------------------------------------------
  1947. C    TOOLPACK/1    Release: 2.5
  1948. C---------------------------------------------------------
  1949. C
  1950. C  TKLAST = LAST TOKEN NUMBER
  1951. C
  1952.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1953.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1954.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1955.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1956.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1957.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1958.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1959.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1960.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1961.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1962.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1963.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1964.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1965.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1966.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1967.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1968.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1969.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1970.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1971.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1972.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1973.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1974.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1975.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1976.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1977.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1978.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1979.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1980.  
  1981.  
  1982.         SAVE DUMMY
  1983.  
  1984.         INTEGER SPTR,PTR,DUMMY(2)
  1985.         LOGICAL FIRST
  1986.  
  1987.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP
  1988.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZTOKWR,ERROR,YLEAF
  1989.  
  1990.         DATA DUMMY(1)/129/
  1991.  
  1992.         SPTR=ZYDOWN(PUROOT)
  1993.         FIRST=.TRUE.
  1994.  
  1995.  100    IF (ZYNTYP(SPTR).EQ.39 .AND.
  1996.      +      ZYDOWN(SPTR).EQ.0) THEN
  1997. C Found a blank SAVE statement - so we don't need to make a list
  1998. C of everything mentioned in a SAVE
  1999.             CALL ZTOKWR(TSAVE,0,DUMMY,TKDESC)
  2000.             CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  2001.             RETURN
  2002.         END IF
  2003.         SPTR=ZYNEXT(SPTR)
  2004.         IF (SPTR.NE.0) GOTO 100
  2005.  
  2006.         SPTR=ZYDOWN(PUROOT)
  2007.  
  2008.  200    IF (ZYNTYP(SPTR).EQ.39) THEN
  2009.             IF (FIRST) CALL ZTOKWR(TSAVE,0,DUMMY,TKDESC)
  2010.             PTR=ZYDOWN(SPTR)
  2011.             IF (PTR.NE.0) THEN
  2012.                 IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
  2013.             END IF
  2014.             IF (PTR.EQ.0) CALL ERROR('ISTDS(OUTSAV): Internal Error')
  2015.  300        IF (.NOT.FIRST) CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  2016.             FIRST=.FALSE.
  2017.             CALL YLEAF(PTR,TKDESC)
  2018.             PTR=ZYNEXT(PTR)
  2019.             IF (PTR.NE.0) GOTO 300
  2020.         END IF
  2021.         SPTR=ZYNEXT(SPTR)
  2022.         IF (SPTR.NE.0) THEN
  2023.             IF (ZYNTYP(SPTR).NE.49) GOTO 200
  2024.         END IF
  2025.         IF (.NOT.FIRST) CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  2026.  
  2027.         END
  2028. C ----------------------------------------------------------------------
  2029. C
  2030. C       O U T P A R   -   Output Parameter Statements
  2031. C
  2032.  
  2033.         SUBROUTINE OUTPAR
  2034.  
  2035. C---------------------------------------------------------
  2036. C    TOOLPACK/1    Release: 2.5
  2037. C---------------------------------------------------------
  2038.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  2039.      +                STMTNO
  2040.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  2041.         LOGICAL DUMPED(22)
  2042.  
  2043.         SAVE /DSSTAT/
  2044. C---------------------------------------------------------
  2045. C    TOOLPACK/1    Release: 2.5
  2046. C---------------------------------------------------------
  2047.         COMMON/DSIO/IODCMT,TKDESC
  2048.         INTEGER IODCMT,TKDESC
  2049.  
  2050.         SAVE /DSIO/
  2051. C---------------------------------------------------------
  2052. C    TOOLPACK/1    Release: 2.5
  2053. C---------------------------------------------------------
  2054.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  2055.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  2056.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  2057.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  2058.      +          INCLPR
  2059.  
  2060.         SAVE /DSOPTS/
  2061. C---------------------------------------------------------
  2062. C    TOOLPACK/1    Release: 2.5
  2063. C---------------------------------------------------------
  2064. C
  2065. C  TKLAST = LAST TOKEN NUMBER
  2066. C
  2067.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  2068.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  2069.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  2070.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  2071.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  2072.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  2073.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  2074.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  2075.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  2076.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  2077.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  2078.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  2079.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  2080.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  2081.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  2082.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  2083.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  2084.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  2085.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  2086.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  2087.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  2088.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  2089.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  2090.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  2091.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  2092.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  2093.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  2094.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  2095.  
  2096.  
  2097.         SAVE DUMMY
  2098.  
  2099.         INTEGER SYMBOL(8),LDTYPE,LCHLEN,PTR,PTR2,DUMMY(2),
  2100.      +          TEXT(134),SAVNUM
  2101.  
  2102.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,LENGTH,ZIAND,ZYPREV
  2103.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,LENGTH,ZYGTSY,ZYGTST,ZTOKWR,
  2104.      +           YDTYPE,YSTMT,YCHLEN,ZIAND,ZYPREV,ZYDELT
  2105.  
  2106.         DATA DUMMY(1)/129/
  2107.  
  2108.         LDTYPE=0
  2109.         LCHLEN=0
  2110.         PTR=ZYDOWN(PUROOT)
  2111.         SAVNUM=STMTNO
  2112.         STMTNO=1
  2113.  
  2114.  100    IF (ZYNTYP(PTR).EQ.35) THEN
  2115.             PTR2=ZYDOWN(PTR)
  2116.  200        CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR2)),SYMBOL)
  2117.             CALL ZYGTST(SYMBOL(2),TEXT)
  2118.             IF (VMODE.NE.2 .AND.
  2119.      +          ZIAND(SYMBOL(6),125936).EQ.0) THEN
  2120.                 IF (VMODE.EQ.1) THEN
  2121.                     CALL ZCHOUT('Warning: Removing unu'//'sed name "',
  2122.      +                          2)
  2123.                     CALL PUTLIN(TEXT,2)
  2124.                     CALL ZCHOUT('" ',2)
  2125.                     CALL DSNAME
  2126.                 END IF
  2127.                 IF (ZYNEXT(PTR2).EQ.0) THEN
  2128.                     CALL ZYDELT(PTR2)
  2129.                     PTR2=0
  2130.                 ELSE
  2131.                     PTR2=ZYNEXT(PTR2)
  2132.                     CALL ZYDELT(ZYPREV(PTR2))
  2133.                 END IF
  2134.             ELSE
  2135.                 IF (SYMBOL(4).NE.LDTYPE) THEN
  2136.                     IF (LDTYPE.NE.0) CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  2137.                     LDTYPE=SYMBOL(4)
  2138.                     LCHLEN=SYMBOL(5)
  2139.                     CALL YDTYPE(LDTYPE,LCHLEN,TKDESC)
  2140.                 ELSE
  2141.                     CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  2142.                 END IF
  2143.                 CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
  2144.                 IF (SYMBOL(5).NE.LCHLEN)
  2145.      +              CALL YCHLEN(SYMBOL(5),TKDESC)
  2146.                 PTR2=ZYNEXT(PTR2)
  2147.             END IF
  2148.             IF (PTR2.GT.0) GOTO 200
  2149.             IF (ZYDOWN(PTR).NE.0) THEN
  2150.                 CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  2151.                 CALL YSTMT(PTR,TKDESC)
  2152.             END IF
  2153.             LDTYPE=0
  2154.             LCHLEN=0
  2155.         END IF
  2156.         PTR=ZYNEXT(PTR)
  2157.         STMTNO=STMTNO+1
  2158.         IF (PTR.GT.0) GOTO 100
  2159.         STMTNO=SAVNUM
  2160.  
  2161.         END
  2162. C ----------------------------------------------------------------------
  2163. C
  2164. C       O U T C M N   -   Output COMMON statements (one per block)
  2165. C
  2166.  
  2167.         SUBROUTINE OUTCMN
  2168.  
  2169. C---------------------------------------------------------
  2170. C    TOOLPACK/1    Release: 2.5
  2171. C---------------------------------------------------------
  2172.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  2173.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  2174.      +          SDTYPE(5003),SCHLEN(5003),
  2175.      +          SBITS(5003)
  2176.  
  2177.         SAVE /DSSYMS/
  2178. C---------------------------------------------------------
  2179. C    TOOLPACK/1    Release: 2.5
  2180. C---------------------------------------------------------
  2181.         COMMON/DSIO/IODCMT,TKDESC
  2182.         INTEGER IODCMT,TKDESC
  2183.  
  2184.         SAVE /DSIO/
  2185. C---------------------------------------------------------
  2186. C    TOOLPACK/1    Release: 2.5
  2187. C---------------------------------------------------------
  2188.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  2189.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  2190.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  2191.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  2192.      +          INCLPR
  2193.  
  2194.         SAVE /DSOPTS/
  2195. C---------------------------------------------------------
  2196. C    TOOLPACK/1    Release: 2.5
  2197. C---------------------------------------------------------
  2198.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  2199.      +                STMTNO
  2200.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  2201.         LOGICAL DUMPED(22)
  2202.  
  2203.         SAVE /DSSTAT/
  2204. C---------------------------------------------------------
  2205. C    TOOLPACK/1    Release: 2.5
  2206. C---------------------------------------------------------
  2207. C
  2208. C  TKLAST = LAST TOKEN NUMBER
  2209. C
  2210.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  2211.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  2212.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  2213.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  2214.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  2215.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  2216.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  2217.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  2218.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  2219.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  2220.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  2221.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  2222.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  2223.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  2224.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  2225.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  2226.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  2227.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  2228.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  2229.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  2230.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  2231.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  2232.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  2233.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  2234.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  2235.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  2236.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  2237.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  2238.  
  2239.  
  2240.         SAVE DUMMY
  2241.  
  2242.         INTEGER SYMBOL(8),TEXT(134),PTR,I,DUMMY(2),PTR2
  2243.         LOGICAL BLANK
  2244.  
  2245.         LOGICAL EXISTS
  2246.  
  2247.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP,LENGTH,ZYUP
  2248.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,LENGTH,ZYUP,ZTOKWR,ZYGTSY,ZYGTST,
  2249.      +           YARDCL,ZCHOUT,ZMESS,PUTLIN
  2250.  
  2251.         DATA DUMMY(1)/129/
  2252.  
  2253.         I=0
  2254.  100    I=I+1
  2255.         IF (STYPE(I).NE.13) GOTO 100
  2256.  
  2257.  200    CALL ZYGTSY(SYMIDX(I),SYMBOL)
  2258.         CALL ZYGTST(SYMBOL(2),TEXT)
  2259.         IF (SYMBOL(4).EQ.0) THEN
  2260.             NERROR=NERROR+1
  2261.             CALL ZCHOUT('Error: Common block /',2)
  2262.             CALL PUTLIN(TEXT,2)
  2263.             CALL ZMESS('/ is n'//'ot defined',2)
  2264.             I=I+1
  2265.             IF (I.LE.NSYMS) THEN
  2266.                 IF (STYPE(I).EQ.13) GOTO 200
  2267.             END IF
  2268.             GOTO 700
  2269.         END IF
  2270.         CALL ZTOKWR(TCOMMO,0,DUMMY,TKDESC)
  2271.         BLANK=TEXT(1).EQ.36
  2272.         IF (.NOT.BLANK) THEN
  2273.             CALL ZTOKWR(TSLASH,0,DUMMY,TKDESC)
  2274.             CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
  2275.             CALL ZTOKWR(TSLASH,0,DUMMY,TKDESC)
  2276.         END IF
  2277. C Output initial part of this common block
  2278.         PTR=SYMBOL(4)
  2279.  300    PTR2=ZYDOWN(PTR)
  2280.         IF (.NOT.BLANK) PTR2=ZYNEXT(PTR2)
  2281.         PTR2=ZYDOWN(PTR2)
  2282.  400    IF (ZYNTYP(PTR2).EQ.108) THEN
  2283.             CALL ZYGTSY(-ZYDOWN(PTR2),SYMBOL)
  2284.         ELSE
  2285.             CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR2)),SYMBOL)
  2286.         END IF
  2287.         CALL ZYGTST(SYMBOL(2),TEXT)
  2288.         CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
  2289.         IF (ARDICB .AND. SYMBOL(7).GT.0)
  2290.      +      CALL YARDCL(SYMBOL(7),TKDESC)
  2291.         PTR2=ZYNEXT(PTR2)
  2292.         IF (PTR2.NE.0) THEN
  2293.             CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  2294.             GOTO 400
  2295.         END IF
  2296. C Must search tree for further occurrences of this common block
  2297. C First search rest of this COMMON statement
  2298.         IF (ZYNEXT(PTR).EQ.0) THEN
  2299.             PTR=ZYNEXT(ZYUP(PTR))
  2300. C But not if there isn't any
  2301.             GOTO 600
  2302.         END IF
  2303.         PTR=ZYNEXT(PTR)
  2304.  500    IF ((BLANK .AND. ZYNTYP(PTR).EQ.27) .OR.
  2305.      +      (.NOT.BLANK .AND. -ZYDOWN(ZYDOWN(PTR)).EQ.SYMIDX(I))) THEN
  2306.             CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  2307.             GOTO 300
  2308.         END IF
  2309.         IF (ZYNEXT(PTR).NE.0) THEN
  2310.             PTR=ZYNEXT(PTR)
  2311.             GOTO 500
  2312.         END IF
  2313. C End of a COMMON statement, get back up to statement level and continue
  2314.         PTR=ZYNEXT(ZYUP(PTR))
  2315.  600    IF (ZYNTYP(PTR).EQ.26) THEN
  2316.             PTR=ZYDOWN(PTR)
  2317.             GOTO 500
  2318.         END IF
  2319.         PTR=ZYNEXT(PTR)
  2320.         IF (PTR.NE.0) GOTO 600
  2321. C Looks like we finally finished this COMMON statement - End it off
  2322.         CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  2323. C And step to the next symbol in the table
  2324.         I=I+1
  2325.         IF (I.LE.NSYMS) THEN
  2326.             IF (STYPE(I).EQ.13) GOTO 200
  2327.         END IF
  2328.  700    IF (ICTWCB) THEN
  2329.             IF (EXISTS(6)) CALL OUTSD(6)
  2330.             IF (EXISTS(7)) CALL OUTSD(7)
  2331.         END IF
  2332.  
  2333.         END
  2334. C ----------------------------------------------------------------------
  2335. C
  2336. C       O U T S P D   -   Output special declaration (stmt fns/entrys)
  2337. C
  2338.  
  2339.         SUBROUTINE OUTSPD(TYPE)
  2340.         INTEGER TYPE
  2341.  
  2342. C---------------------------------------------------------
  2343. C    TOOLPACK/1    Release: 2.5
  2344. C---------------------------------------------------------
  2345.         COMMON/DSIO/IODCMT,TKDESC
  2346.         INTEGER IODCMT,TKDESC
  2347.  
  2348.         SAVE /DSIO/
  2349. C---------------------------------------------------------
  2350. C    TOOLPACK/1    Release: 2.5
  2351. C---------------------------------------------------------
  2352.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  2353.      +                STMTNO
  2354.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  2355.         LOGICAL DUMPED(22)
  2356.  
  2357.         SAVE /DSSTAT/
  2358. C---------------------------------------------------------
  2359. C    TOOLPACK/1    Release: 2.5
  2360. C---------------------------------------------------------
  2361.         COMMON/DSSPEC/SPECP
  2362.         LOGICAL SPECP(132)
  2363.  
  2364.         SAVE /DSSPEC/
  2365.  
  2366.         INTEGER SPTR,NTYPE
  2367.  
  2368.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP
  2369.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,YSTMT
  2370.  
  2371.         SPTR=ZYDOWN(PUROOT)
  2372.  100    NTYPE=ZYNTYP(SPTR)
  2373.         IF (NTYPE.EQ.TYPE) CALL YSTMT(SPTR,TKDESC)
  2374.         IF (SPECP(NTYPE)) THEN
  2375.             SPTR=ZYNEXT(SPTR)
  2376.             IF (SPTR.NE.0) GOTO 100
  2377.         END IF
  2378.  
  2379.         END
  2380. C ----------------------------------------------------------------------
  2381. C
  2382. C       O U T S P C   -   Output special section (data)
  2383. C
  2384.  
  2385.         SUBROUTINE OUTSPC(TYPE)
  2386.         INTEGER TYPE
  2387.  
  2388. C---------------------------------------------------------
  2389. C    TOOLPACK/1    Release: 2.5
  2390. C---------------------------------------------------------
  2391.         COMMON/DSIO/IODCMT,TKDESC
  2392.         INTEGER IODCMT,TKDESC
  2393.  
  2394.         SAVE /DSIO/
  2395. C---------------------------------------------------------
  2396. C    TOOLPACK/1    Release: 2.5
  2397. C---------------------------------------------------------
  2398.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  2399.      +                STMTNO
  2400.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  2401.         LOGICAL DUMPED(22)
  2402.  
  2403.         SAVE /DSSTAT/
  2404.  
  2405.         INTEGER SPTR
  2406.  
  2407.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP
  2408.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,YSTMT
  2409.  
  2410.         SPTR=ZYDOWN(PUROOT)
  2411.  100    IF (ZYNTYP(SPTR).EQ.TYPE) CALL YSTMT(SPTR,TKDESC)
  2412.         SPTR=ZYNEXT(SPTR)
  2413.         IF (SPTR.NE.0) GOTO 100
  2414.  
  2415.         END
  2416. C ----------------------------------------------------------------------
  2417. C
  2418. C       O U T U N D   -   Output (previously) untyped names
  2419. C
  2420.  
  2421.         SUBROUTINE OUTUND
  2422.  
  2423. C---------------------------------------------------------
  2424. C    TOOLPACK/1    Release: 2.5
  2425. C---------------------------------------------------------
  2426.         COMMON/DSSYMS/NSYMS,SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS
  2427.         INTEGER NSYMS,SYMIDX(5003),STYPE(5003),
  2428.      +          SDTYPE(5003),SCHLEN(5003),
  2429.      +          SBITS(5003)
  2430.  
  2431.         SAVE /DSSYMS/
  2432. C---------------------------------------------------------
  2433. C    TOOLPACK/1    Release: 2.5
  2434. C---------------------------------------------------------
  2435.         COMMON/DSIO/IODCMT,TKDESC
  2436.         INTEGER IODCMT,TKDESC
  2437.  
  2438.         SAVE /DSIO/
  2439. C---------------------------------------------------------
  2440. C    TOOLPACK/1    Release: 2.5
  2441. C---------------------------------------------------------
  2442. C
  2443. C  TKLAST = LAST TOKEN NUMBER
  2444. C
  2445.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  2446.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  2447.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  2448.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  2449.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  2450.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  2451.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  2452.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  2453.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  2454.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  2455.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  2456.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  2457.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  2458.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  2459.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  2460.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  2461.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  2462.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  2463.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  2464.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  2465.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  2466.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  2467.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  2468.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  2469.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  2470.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  2471.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  2472.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  2473.  
  2474.  
  2475.         SAVE DUMMY
  2476.  
  2477.         INTEGER I,LTYPE,DUMMY(2),LCHLEN,TEXT(134),SYMBOL(8)
  2478.  
  2479.         INTEGER LENGTH,ZYNTYP,ZIAND
  2480.         EXTERNAL ZTOKWR,LENGTH,ZYNTYP,ZYGTSY,ZYGTST,YDTYPE,YCHLEN,ZIAND
  2481.  
  2482.         DATA DUMMY(1)/129/
  2483.  
  2484.         LTYPE=0
  2485.         LCHLEN=0
  2486.         I=0
  2487.  
  2488.  100    I=I+1
  2489.         IF (I.LE.NSYMS .AND. (STYPE(I).EQ.12 .OR. SDTYPE(I).LE.0
  2490.      +      .OR. ZIAND(SBITS(I),8).NE.0)) GOTO 100
  2491.  
  2492.         IF (I.GT.NSYMS) THEN
  2493.             CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  2494.             RETURN
  2495.         END IF
  2496.  
  2497.         IF (LTYPE.NE.SDTYPE(I)) THEN
  2498.             IF (LTYPE.NE.0) CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  2499.             CALL YDTYPE(SDTYPE(I),SCHLEN(I),TKDESC)
  2500.             LTYPE=SDTYPE(I)
  2501.             LCHLEN=SCHLEN(I)
  2502.         ELSE
  2503.             CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  2504.         END IF
  2505.         CALL ZYGTSY(SYMIDX(I),SYMBOL)
  2506.         CALL ZYGTST(SYMBOL(2),TEXT)
  2507.         CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
  2508.         IF (SCHLEN(I).NE.LCHLEN) CALL YCHLEN(SCHLEN(I),TKDESC)
  2509.         GOTO 100
  2510.  
  2511.         END
  2512. C ----------------------------------------------------------------------
  2513. C
  2514. C       D S W A R N   -   Issue a warning from DS
  2515. C
  2516.  
  2517.         SUBROUTINE DSWARN(STRING)
  2518.         CHARACTER*(*) STRING
  2519.  
  2520. C---------------------------------------------------------
  2521. C    TOOLPACK/1    Release: 2.5
  2522. C---------------------------------------------------------
  2523.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  2524.      +                STMTNO
  2525.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  2526.         LOGICAL DUMPED(22)
  2527.  
  2528.         SAVE /DSSTAT/
  2529.  
  2530.         EXTERNAL ZCHOUT,PUTCH
  2531.  
  2532.         CALL ZCHOUT('Warning: ',2)
  2533.         CALL ZCHOUT(STRING,2)
  2534.         IF (PUNUM.GT.0) THEN
  2535.             CALL DSNAME
  2536.         ELSE
  2537.             CALL PUTCH(10,2)
  2538.         END IF
  2539.         NWARN=NWARN+1
  2540.  
  2541.         END
  2542. C ----------------------------------------------------------------------
  2543. C
  2544. C       D S N A M E   -   Output the current program-unit name to stderr
  2545. C
  2546.  
  2547.         SUBROUTINE DSNAME
  2548.  
  2549. C---------------------------------------------------------
  2550. C    TOOLPACK/1    Release: 2.5
  2551. C---------------------------------------------------------
  2552.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  2553.      +                STMTNO
  2554.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  2555.         LOGICAL DUMPED(22)
  2556.  
  2557.         SAVE /DSSTAT/
  2558.  
  2559.         INTEGER NAME(134),SYMBOL(8)
  2560.  
  2561.         INTEGER ZYGPUS
  2562.         EXTERNAL ZCHOUT,ZYGTSY,ZYGTST,PUTLIN,PUTCH,ZPTINT,ZYGPUS
  2563.  
  2564.         IF (STMTNO.NE.0) THEN
  2565.             CALL ZCHOUT(' at statement ',2)
  2566.             CALL ZPTINT(STMTNO,1,2)
  2567.         END IF
  2568.         CALL ZCHOUT(' in ',2)
  2569.         CALL ZYGTSY(ZYGPUS(PUNUM),SYMBOL)
  2570.         CALL ZYGTST(SYMBOL(2),NAME)
  2571.         CALL PUTLIN(NAME,2)
  2572.         CALL PUTCH(10,2)
  2573.  
  2574.         END
  2575. C ----------------------------------------------------------------------
  2576. C
  2577. C       D S E R R   -   Issue an error message from DS
  2578. C
  2579.  
  2580.         SUBROUTINE DSERR(STRING)
  2581.         CHARACTER*(*) STRING
  2582.  
  2583. C---------------------------------------------------------
  2584. C    TOOLPACK/1    Release: 2.5
  2585. C---------------------------------------------------------
  2586.         COMMON/DSSTAT/SECNUM,PUNUM,PUROOT,DUMPED,NWARN,NERROR,SNUM,
  2587.      +                STMTNO
  2588.         INTEGER SECNUM,PUNUM,PUROOT,NWARN,NERROR,SNUM,STMTNO
  2589.         LOGICAL DUMPED(22)
  2590.  
  2591.         SAVE /DSSTAT/
  2592.  
  2593.         EXTERNAL ZCHOUT,PUTCH
  2594.  
  2595.         CALL ZCHOUT('Error: ',2)
  2596.         CALL ZCHOUT(STRING,2)
  2597.         IF (PUNUM.GT.0) THEN
  2598.             CALL DSNAME
  2599.         ELSE
  2600.             CALL PUTCH(10,2)
  2601.         END IF
  2602.         NERROR=NERROR+1
  2603.  
  2604.         END
  2605. C ----------------------------------------------------------------------
  2606. C
  2607. C       D S B D   -   Block data to initialise /dstext/ SHTEXT
  2608. C
  2609.  
  2610.         BLOCK DATA DSBD
  2611.  
  2612. C---------------------------------------------------------
  2613. C    TOOLPACK/1    Release: 2.5
  2614. C---------------------------------------------------------
  2615.         COMMON/DSTEXT/ SHTEXT,OLDTXT
  2616.         INTEGER SHTEXT(43,0:22),OLDTXT(43,10:11)
  2617.  
  2618.         SAVE /DSTEXT/
  2619. C---------------------------------------------------------
  2620. C    TOOLPACK/1    Release: 2.5
  2621. C---------------------------------------------------------
  2622.         COMMON/DSOPTS/DORDER,ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,
  2623.      +                PMODE,VMODE,NOTRAI,CHLBRK,INCLPR,DTFORM
  2624.         INTEGER DORDER(-3:15),PMODE,VMODE,DTFORM
  2625.         LOGICAL ICTWCB,ARDICB,GENINT,EXEHDR,OLDFMT,CNVOLD,NOTRAI,CHLBRK,
  2626.      +          INCLPR
  2627.  
  2628.         SAVE /DSOPTS/
  2629.  
  2630.         INTEGER I
  2631.  
  2632.         DATA (SHTEXT(I,0),I=1,9)/67,32,32,32,32,32,
  2633.      +46,46,129/
  2634.         DATA (SHTEXT(I,1),I=1,23)/67,32,32,32,32,32,
  2635.      +46,46,32,80,97,114,97,109,101,116,101,114,
  2636.      +115,
  2637.      +32,46,46,129/
  2638.         DATA (SHTEXT(I,2),I=1,29)/67,32,32,32,32,32,
  2639.      +46,46,32,83,99,97,108,97,114,32,65,114,
  2640.      +103,117,109,101,110,116,115,32,46,46,129/
  2641.         DATA (SHTEXT(I,3),I=1,28)/67,32,32,32,32,32,
  2642.      +46,46,32,65,114,114,97,121,32,65,114,
  2643.      +103,117,109,101,110,116,115,32,46,46,129/
  2644.         DATA (SHTEXT(I,4),I=1,31)/67,32,32,32,32,32,
  2645.      +46,46,32,70,117,110,99,116,105,111,110,
  2646.      +32,65,114,103,117,109,101,110,116,115,
  2647.      +32,46,46,129/
  2648.         DATA (SHTEXT(I,5),I=1,33)/67,32,32,32,32,32,
  2649.      +46,46,32,83,117,98,114,111,117,116,105,110,
  2650.      +101,32,65,114,103,117,109,101,110,116,115,
  2651.      +32,46,46,129/
  2652.         DATA (SHTEXT(I,6),I=1,30)/67,32,32,32,32,32,
  2653.      +46,46,32,83,99,97,108,97,114,115,32,
  2654.      +105,110,32,67,111,109,109,111,110,
  2655.      +32,46,46,129/
  2656.         DATA (SHTEXT(I,7),I=1,29)/67,32,32,32,32,32,
  2657.      +46,46,32,65,114,114,97,121,115,32,
  2658.      +105,110,32,67,111,109,109,111,110,
  2659.      +32,46,46,129/
  2660.         DATA (SHTEXT(I,8),I=1,26)/67,32,32,32,32,32,
  2661.      +46,46,32,76,111,99,97,108,32,83,99,
  2662.      +97,108,97,114,115,
  2663.      +32,46,46,129/
  2664.         DATA (SHTEXT(I,9),I=1,25)/67,32,32,32,32,32,
  2665.      +46,46,32,76,111,99,97,108,32,65,114,114,
  2666.      +97,121,115,
  2667.      +32,46,46,129/
  2668.         DATA (SHTEXT(I,10),I=1,31)/67,32,32,32,32,32,
  2669.      +46,46,32,69,120,116,101,114,110,97,108,32,
  2670.      +70,117,110,99,116,105,111,110,115,
  2671.      +32,46,46,129/
  2672.         DATA (SHTEXT(I,11),I=1,33)/67,32,32,32,32,32,
  2673.      +46,46,32,69,120,116,101,114,110,97,108,32,
  2674.      +83,117,98,114,111,117,116,105,110,101,115,
  2675.      +32,46,46,129/
  2676.         DATA (SHTEXT(I,12),I=1,32)/67,32,32,32,32,32,
  2677.      +46,46,32,73,110,116,114,105,110,115,105,99,
  2678.      +32,70,117,110,99,116,105,111,110,115,
  2679.      +32,46,46,129/
  2680.         DATA (SHTEXT(I,13),I=1,26)/67,32,32,32,32,32,
  2681.      +46,46,32,67,111,109,109,111,110,32,98,108,
  2682.      +111,99,107,115,
  2683.      +32,46,46,129/
  2684.         DATA (SHTEXT(I,14),I=1,32)/67,32,32,32,32,32,
  2685.      +46,46,32,83,116,97,116,101,109,101,110,116,
  2686.      +32,70,117,110,99,116,105,111,110,115,
  2687.      +32,46,46,129/
  2688.         DATA (SHTEXT(I,15),I=1,25)/67,32,32,32,32,32,
  2689.      +46,46,32,69,110,116,114,121,32,80,111,105,
  2690.      +110,116,115,
  2691.      +32,46,46,129/
  2692.         DATA (SHTEXT(I,16),I=1,25)/67,32,32,32,32,32,
  2693.      +46,46,32,69,113,117,105,118,97,108,101,110,
  2694.      +99,101,115,
  2695.      +32,46,46,129/
  2696.         DATA (SHTEXT(I,17),I=1,27)/67,32,32,32,32,32,
  2697.      +46,46,32,83,97,118,101,32,115,116,97,116,
  2698.      +101,109,101,110,116,
  2699.      +32,46,46,129/
  2700.         DATA (SHTEXT(I,18),I=1,43)/67,32,32,32,32,32,
  2701.      +46,46,32,83,116,97,116,101,109,101,110,116,
  2702.      +32,70,117,110,99,116,105,111,110,32,100,101,
  2703.      +102,105,110,105,116,105,111,110,115,
  2704.      +32,46,46,129/
  2705.         DATA (SHTEXT(I,19),I=1,34)/67,32,32,32,32,32,
  2706.      +46,46,32,69,120,101,99,117,116,97,98,108,
  2707.      +101,32,83,116,97,116,101,109,101,110,116,115,
  2708.      +32,46,46,129/
  2709. C The following is currently unused but is here in case we ever want it
  2710. C (and so we don't forget about it and reuse section number 20 !!)
  2711.         DATA (SHTEXT(I,20),I=1,19)/67,32,32,32,32,32,
  2712.      +46,46,32,76,97,98,101,108,115,
  2713.      +32,46,46,129/
  2714.         DATA (SHTEXT(I,21),I=1,37)/67,32,32,32,32,32,
  2715.      +46,46,32,80,114,101,118,105,111,117,115,108,
  2716.      +121,32,117,110,116,121,112,101,100,32,110,97,109,
  2717.      +101,115,32,46,46,129/
  2718.         DATA (SHTEXT(I,22),I=1,28)/67,32,32,32,32,32,
  2719.      +46,46,32,68,97,116,97,32,115,116,97,116,
  2720.      +101,109,101,110,116,115,
  2721.      +32,46,46,129/
  2722.  
  2723.         DATA (OLDTXT(I,10),I=1,32)/67,32,32,32,32,32,
  2724.      +46,46,32,70,117,110,99,116,105,111,110,32,
  2725.      +82,101,102,101,114,101,110,99,101,115,
  2726.      +32,46,46,129/
  2727.         DATA (OLDTXT(I,11),I=1,34)/67,32,32,32,32,32,
  2728.      +46,46,32,83,117,98,114,111,117,116,105,110,
  2729.      +101,32,114,101,102,101,114,101,110,99,101,115,
  2730.      +32,46,46,129/
  2731.  
  2732. C Default order: Double Precision, Complex, Real, Integer, Logical,
  2733. C                Character
  2734.  
  2735.         DATA DORDER/0,0,0,0,5,4,6,3,2,7,0,1,0,0,0,0,0,0,0/,
  2736.      +       GENINT,ICTWCB,ARDICB,EXEHDR,OLDFMT,CNVOLD/6*.FALSE./,
  2737.      +       PMODE/2/,VMODE/2/,
  2738.      +       NOTRAI,CHLBRK,INCLPR/3*.FALSE./,DTFORM/0/
  2739.  
  2740.         END
  2741.