C MAPS.FTN, SEGSRC, CEH-LSS, 10/18/78
C Map routines for SEG
C Copyright (c) 1981, Prime Computer, Inc., Natick, MA 01760
C
C      PRTMAP - ROUTINE TO PRINT MAPS
C
C      CALLING SEQUENCE: CALL PRTMAP(NBUFFR,NLENT,PARAM)
C
C      WHERE NBUFFR IS THE NAME OF THE FILE TO WHICH THE MAP IS DIRECTED
C            NLENT IS THE LENGTH OF NBUFFR
C            PARAM IS THE MAP OPTION
C
       SUBROUTINE PRTMAP(NBUFFR,NLENT,PARAM)
C
$INSERT SYSCOM>KEYS.INS.FTN
$INSERT SYSCOM>ERRD.INS.FTN
C
       INTEGER*2 NBUFFR(1),NLENT,PARAM,CPV(2),CODE,I,IARG
       INTEGER*2 HDR1(:31),HDR2(:12),HDR3(:10),HDR4(:10)
C
       LOGICAL TREE$A
C
        EXTERNAL EP1,EP2,ALPHMA,ECBMAP,DIRMAP,COMMAP,BASEOU,SYMOUT
        EXTERNAL EP1P,EP2P,CMMAPP,DRMAPP,SYMPRT
C
$INSERT LODCOM.INS.FTN
C
       DATA HDR1/'ROUTINE',3,' ECB',4,' PROCEDURE',2,
     +  ' ST. SIZE  LINK FR.',-1/
       DATA HDR2/'DIRECT ENTRY LINKS',-1/
       DATA HDR3/'COMMON BLOCKS',-1/
       DATA HDR4/'OTHER SYMBOLS',-1/
C
C      SEE IF MAP TO A FILE
C
       TTYCNT=0
       IF(NBUFFR(1).EQ.'  ') GO TO 100
C
C      OPEN MAP FILE
C
       TTYSW=1
       IF (TREE$A(NBUFFR,NLENT,IARG,CODE)) GO TO 20
       CALL SRCH$$(K$WRIT,NBUFFR,NLENT,WRITEU,IARG,CODE)
       GO TO 30
20     CPV(1)=0
       CPV(2)=NLENT
       CALL TSRC$$(K$WRIT,NBUFFR,WRITEU,CPV,IARG,CODE)
30     IF(CODE.EQ.0) GO TO 50
       IF(CODE.NE.E$UIUS) GO TO 20040
50     CALL ATCH$$(K$HOME,0,0,0,0,CODE)     /*ATTACH TO HOME UFD
       IF(CODE.NE.0) GO TO 20040
       MAPFLG=MAPFLG+1                 /*IF WE OPEN IS WE CLOSE IT
C
100    IF(PARAM.EQ.0) PARAM=4
       GO TO (1000,2000,3000,4000,5000,6000,7000,8000,9000), PARAM
       CALL TNOUA('CM',2)
       RETURN
C
C      MAP 1, MAP RANGES ONLY
C
1000   CALL RNGOUT
       GO TO 20000                     /*DONE
C
C      MAP RANGES PLUS BASE AREAS
C
2000   CALL RNGOUT
       CALL HILOWA(2,BASEOU)
       GO TO 20000                     /*DONE
C
C      UNDEFINED SYMBOLS ONLY
C
C3000   CALL HILOW(1,EP2)
3000   CALL MAPCPY
       CALL MAPOUT(LOC(EP2P))
       CALL MAPCU
       CALL TYPE2(0)
       GO TO 20000                     /*DONE
C
C      FULL MAP
C
4000   CALL RNGOUT                     /*DO RANGES
       CALL HILOWA(2,BASEOU)           /*BASE AREAS
       CALL WRDOUT(HDR1)               /*PRINT HEADER
       CALL HILOWA(:20,ECBMAP)         /*LIST PROCEDURES ON PROCEDURE ADDRESS
       CALL WRDOUT(HDR2)               /*HEADER FOR DIRECT ENTRY CALLS
       CALL MAPCPY                     /*PRINT DIRECT ENTRY CALLS
       CALL MAPOUT(LOC(DRMAPP))
       CALL WRDOUT(HDR3)               /*HEADER FOR COMMON REFERENCES
       CALL MAPOUT(LOC(CMMAPP))        /*PRINT COMMON REFERENCES
       CALL WRDOUT(HDR4)               /*HEADER FOR OTHER SYMBOLS
       CALL MAPOUT(LOC(EP1P))          /*PRINT OTHER SYMBOLS
       CALL MAPCU
       CALL INITNE(POINT1,1,0)         /*CLEAN UP SYMBOL TABLE
4010   IF(NEXT(POINT1).EQ.0) GO TO 20000
       IF(MAP1(P1SUBS).LT.0) MAP1(P1SUBS)=AND(MAP1(P1SUBS),:77777)
       GO TO 4010
C
C      SYSTEM PROGRAMMERS MAP (MA 5)
C
5000   IF(SYMLOW.EQ.0) GO TO 20000
       DO 5100 I=1,SYMLOW
       MAPSBC = -SYMSIZ * I
       CALL LINOUT(MAP1(MAPSBC),SYMSIZ)
5100   CONTINUE
       GO TO 20000
C
C      UNDEFINED SYMBOLS, SORTED ALPHABETICALLY
C
C
6000   CALL HILOWA(1,EP2)
       GO TO 20000
C
C      FULL MAP SORTED ALPHABETICALLY
C
7000   CALL RNGOUT                     /*DO RANGES
       CALL HILOWA(2,BASEOU)           /*BASE AREAS
       CALL WRDOUT(HDR1)               /*PRINT HEADER
       CALL HILOWA(1,ALPHMA)           /*LIST PROCEDURES ON PROCEDURE ADDRESS
       CALL WRDOUT(HDR2)               /*HEADER FOR DIRECT ENTRY CALLS
       CALL HILOWA(1,DIRMAP)           /*PRINT DIRECT ENTRY CALLS
       CALL WRDOUT(HDR3)               /*HEADER FOR COMMON REFERENCES
       CALL HILOWA(1,COMMAP)           /*PRINT COMMON REFERENCES
       CALL WRDOUT(HDR4)               /*HEADER FOR OTHER SYMBOLS
       CALL HILOWA(1,EP1)              /*PRINT OTHER SYMBOLS
       GO TO 20000
C
C
C8000    CALL HILOW(1,SYMOUT)
8000    CALL MAPCPY
        CALL MAPOUT(LOC(SYMPRT))
        CALL MAPCU
        GO TO 20000
C
9000    CALL HILOWA(1,SYMOUT)
        GO TO 20000
C
20000  IF(TTYSW.EQ.0) RETURN
       TTYSW=0
       CALL PRWF$$(K$TRNC,WRITEU,0,0,000000,I,CODE)   /*TRUNCATE
20040  CALL ERRPR$(K$NRTN,CODE,0,0,'PRTMAP',6)
       RETURN
       END
C      ECBMAP - ROUTINE TO PRINT A PROCEDURE SYMBOL
C
C      CALLING SEQUENCE:  CALL ECBMAP
C
       SUBROUTINE ECBMAP
C
       INTEGER*2 SUBSCE,ECBTM1(5)
C
C      LODCOM.INS.FTN IS LISTED IN PRTMAP
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       DATA ECBTM1/'  ####',3,0/
C
       SUBSCE=MAPSBC                   /*NEED MAPSBC FOR NAMEPR
       CALL INITNE(POINT2,1,0)         /*INIT SYMBOL TABLE SEARCH
C
1000   IF(NEXT(POINT2).EQ.0) GO TO 2000
       MAPSBC=P2SUBS                   /*POINT INTO MAP1
       IF(MAP1(MAPSBC+2).NE.MAP1(SUBSCE+3)) GO TO 1000
       IF(AND(MAP1(SUBSCE),:7777)-MAP1(MAPSBC+1).NE.0) GO TO 1000
       MAP1(MAPSBC)=OR(MAP1(MAPSBC),:100000) /*KILL ENTRY TEMPORARILY
       CALL TYPE2(1)
       CALL NAMEPR
1500   CALL ECBOUT(MAP1(SUBSCE))
       RETURN
C
2000   CALL WRDOUT(ECBTM1)             /*PRINT '####    '
       =MAP1(SUBSCE)
       CALL SEGOUT                     /*PRINT SEGMET NUMBER
       CALL TOCT(MAP1(SUBSCE+3),1)
       GO TO 1500
C
       END
C      ALPHMA - ROUTINE TO DO ALPHA MAP THING FOR ECB'S
C
C      CALLING SEQUENCE:  CALL ALPHMA
C
C      DEPENDS ON POINT1 AND POINT2 BEING SET UP IN COMMON
C
       SUBROUTINE ALPHMA
C
C
C
C      LODCOM.INS.FTN IS LISTED IN PRTMAP
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       CALL INITNE(POINT2,:20,0)       /*INIT SYMBOL TABLE SEARCH
C
100    IF(NEXT(POINT2).EQ.0) RETURN
       IF(MAP1(P2SUBS+3).NE.MAP1(MAPSBC+2)) GO TO 100 /*NOT THIS ONE
       IF(MAP1(MAPSBC+1)-AND(MAP1(P2SUBS),:7777).NE.0) GO TO 100
C
C      PRINT THIS ONE
C
       MAP1(MAPSBC)=OR(MAP1(MAPSBC),:100000)
       CALL NAMEPR
       CALL ECBOUT(MAP1(P2SUBS))
       RETURN
C
       END
C      ECBOUT - ROUTINE TO PRINT THE ECB PART OF A PROCEDURE ENTRY
C
C      CALLING SEQUENCE:  CALL ECBOUT(SYMPT)
C
C      WHERE SYMPT IS THE CURRENT ENTRY IN MAP
C
       SUBROUTINE ECBOUT(SYMPT)
C
       INTEGER*2 SYMPT(1)
C
C
C      LODCOM.INS.FTN IS LISTED IN PRTMAP
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       CALL TYPE2(1)                   /*A PAIR OF BLANKS
       =SYMPT(2)
       CALL SEGOUT
       CALL TOCT(SYMPT(3),2)
       CALL TOCT(SYMPT(5),1)
       IF(SYMPT(8).EQ.0) GO TO 100
       CALL TOCT(SYMPT(7),1)
       =SYMPT(8)
       CALL SEGOUT
100    CALL TOCT(SYMPT(6),-1)
       RETURN
C
       END
C      SEGOUT - ROUTINE TO PRINT THE SEGMENT NUMBER
C
C      CALLING SEQUENCE:  =LOCSEG
C                         CALL SEGOUT
C
C      WHERE LOCSEG IS THE SEG # TO BE PRINTED
C
       SUBROUTINE SEGOUT
C
       INTEGER*2 LOCSEG
C
       LOCSEG=
       CALL TYPE2(
     +  RS(AND(LOCSEG,:7000),1)+RS(AND(LOCSEG,:700),6)+'00')
       CALL TYPE2(
     +  AND(LOCSEG,:7)+LS(AND(LOCSEG,:70),5)+'00')
       CALL TYPE2(1)
       RETURN
       END
C      DIRMAP - ROUTINE TO PRINT DIRECT ENTRY LINKS
C
C      CALLING SEQUENCE:  CALL DIRMAP
C
C      POINT1 MUST BE SET UP
C      TE3 MUST BE INITIALIZED (TO TE$SET), DIRMAP THEN KEEPS IT
C      GOING.  TE3 IS THE NUMBER OF ENTRIES PER LINE.
C
       SUBROUTINE DIRMAP
C
C
C      LODCOM.INS.FTN IS LISTED IN PRTMAP
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       IF(MAP1(MAPSBC+1).GE.0) RETURN
       CALL TYPE2(1)                   /*PRINT A PAIR PF BLANKS
       CALL NAMEPR
       TE3=TE3+1
       IF(TE3.NE.0) RETURN
       CALL TYPE2(0)                   /*WRITE OUT STUFF
       TE3=TE$SET
       RETURN
       END
C      RNGOUT - ROUTINE TO PRINT THE 'MAP 1' PART OF THE MAP
C
C      CALLING SEQUENCE:  CALL RNGOUT
C
       SUBROUTINE RNGOUT
C
       INTEGER*2 MAPNAM(5),STAKNA(5),SYMPS(4),HEADER(17),IJ
       INTEGER*2 DATA(3),PROC(3),BOTH(3)
C
C      LODCOM.INS.FTN IS LISTED IN PRTMAP
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       DATA MAPNAM/'*START',1,0/,STAKNA/'*STACK',1,0/,SYMPS/'*SYM',2,0/
       DATA HEADER /'SEG. #',2,'TYPE',4,'LOW',2,' HIGH ',2,' TOP',-1/
       DATA DATA/'DATA',0/,PROC/'PROC',0/,BOTH/'BOTH',0/
C
       CALL WRDOUT(MAPNAM)             /*PRINT '*START'
       = ISAVE(1)                      /*START SEGMENT
       CALL SEGOUT
       CALL TOCT(ISAVE(2),1)           /*START WORD ADDRESS
       CALL WRDOUT(STAKNA)             /*'*SAVE'
       = ISAVE(3)                      /*STACK SEGMENT
       CALL SEGOUT
       CALL TOCT(ISAVE(4),1)           /*STACK WORD ADDRESS
       CALL WRDOUT(SYMPS)              /*'*SYM'
       CALL TOCT(SYMLOW,-1)            /*NUMBER OF SYMBOLS (OCTAL)
       CALL TYPE2(-1)                  /*PRINT A CRLF
C
       CALL INITNE(POINT1,:21,0)       /*START LOOKING FOR SEGMENT SYMBOLS
       IF(POINT1(PT$FOR).EQ.0) RETURN  /*NO SEGMENTS
       CALL WRDOUT(HEADER)             /*PRINT HEADER FOR PROC. MAP
C
1000   IF(NEXT(POINT1).EQ.0) GO TO 2000    /*DONE
       MAPSBC=P1SUBS
       CALL TYPE2(1)
       = MAP1(MAPSBC+A$SEGM)               /*SEGMENT NUMBER
       CALL SEGOUT
       CALL TYPE2(1)
       IJ=RT(RS(MAP1(MAPSBC),12),2)   /*SEGMENT TYPE ISOLATED
       GO TO (1100,1200,1400), IJ
C
1100   CALL WRDOUT(DATA)               /*PRINT 'DATA' - DATA ONLY SEGMENT
       GO TO 1400
C
1200   CALL WRDOUT(PROC)               /*'PROC' - PROCEDURE ONLY SEGMENT
       GO TO 1400
C
C
1400   IF(MAP1(MAPSBC+A$SEGM).EQ.ISAVE(3)) GO TO 1500 /*STACK SEGMENT
       CALL TYPE2(1)                   /*NOT STACK, PRINT BLANKS
       GO TO 1600
C
1500   CALL TYPE2('##')                /*INDICATE STACK
C
1600   CALL TYPE2(2)                   /*PRINT SOME BLANKS
       CALL TOCT(MAP1(MAPSBC+A$LOW),2)      /*PRINT LOW
       CALL TOCT(MAP1(MAPSBC+A$HIGH),2)      /*HIGH
       CALL TOCT(MAP1(MAPSBC+A$TOP),2)      /*TOP
       CALL TYPE2(0)                   /*CLOSE LINE
       GO TO 1000
C
2000   CALL TYPE2(0)                   /*PRINT A BLANK LINE
       RETURN
       END
C      SYMOUT - ROUTINE TO MIX THE SYMBOLS
C
C      SYMOUT IS CALLED FROM HILOW OR HILOWA
C
       SUBROUTINE SYMOUT
C
       INTEGER*2 COMMON(4),DIRECT(7),OTHER(4),UNDEF(6)
C      LODCOM.INS.FTN IS LISTED IN PRTMAP
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
       DATA COMMON/'COMMON',-1/,DIRECT/'DIRECT ENTRY',-1/,
     +  OTHER/'OTHER',-1/,UNDEF/'UNDEFINED',-1/
       CALL ALPHMA                     /*IF THIS GET PRINTED WE CAN TELL
       IF(MAP1(MAPSBC).GE.0) GO TO 100 /*NOT PRINTED
       MAP1(MAPSBC)=XOR(MAP1(MAPSBC),:100000)
       RETURN
C
C      LOOK FOR OTHER TYPES
C
100    TE3=1
       IF(AND(MAP1(MAPSBC),:10).EQ.0) GO TO 200 /*NOT COMMON
       CALL COMMAP
       CALL WRDOUT(COMMON)
       RETURN
C
200    IF(AND(MAP1(MAPSBC),:100).NE.0) GO TO 300
       CALL EP2
       CALL WRDOUT(UNDEF)
       RETURN
C
300    IF(MAP1(MAPSBC+1).GT.0) GO TO 400
       CALL DIRMAP
       CALL WRDOUT(DIRECT)
       RETURN
C
400    CALL EP1
       CALL WRDOUT(OTHER)
       RETURN
C
       END