C LD4SUB.FTN,SEGSRC,CEH-LSS-KJC, 04/05/79 C FTN subroutines INITIT, STACK, and EA for SEG C Copyright (c) 1981, Prime Computer, Inc., Natick, MA 01760 C C INITIT - FUNCTION TO INITIALIZE A P400 LOAD FILE C C CALLING SEQUENCE: VALUE = INITIT(NAME,NAMLNT,NUM) C WHERE: NAME IS THE FILENAME SUPPLIED BY THE USER - IF ANY C NAMLNT IS ITS LENGTH C NUM IS A FLAG, 0 - INIT ALL, 1 - USE OLD RUN FILE. C VALUE = :100000 UPON NO OPENT$ ERROR (OTHERWISE, 0) C FUNCTION INITIT(NAME,NAMLNT,NUM) C INTEGER I,IERROR,IPOS,IFLAG,ISUB,OPENT$,NAME,NAMLNT,IARG,CODE INTEGER ISUB1,INITIT C C $INSERT SYSCOM>KEYS.INS.FTN $INSERT SYSCOM>ERRD.INS.FTN $INSERT LODCOM.INS.FTN C INTEGER CRRPAG,CURTOP,LSTPAG,LSTTOP,AIGPAG,AIGWRD COMMON /DBGCOM/CRRPAG,CURTOP,LSTPAG,LSTTOP,AIGPAG,AIGWRD INITIT = 0 ISUB=SEGS*2 C C SET UP BUFTBL C BUFEND=-1 /*FLAG FOR RDGLOB IFLAG=1000 /*FLAG TO HELP STOP THE LOOP BELOW DO 400 I=1,128,4 BUFTBL(I)=0 BUFTBL(I+1)=0 BUFTBL(I+3)=0 IF(IFLAG.GT.0) GO TO 350 IF(IFLAG+:4000.GT.0) GO TO 410 350 IFLAG=BUFTBL(I+2)+:4000 BUFTBL(I+6)=IFLAG 400 CONTINUE I=I+4 410 BUFTBL(I)=-1 C DO 500 I=1,SEGS SEGTBL(I)=0 500 CONTINUE C IF(NUM.EQ.0) GO TO 420 CALL SRCH$$(K$CACC+K$RDWR,0,0,SEGDIR,IARG,CODE) /*CHANGE ACCESS RIGHTS IF(CODE.NE.0) GO TO 9000 C IF (OFFSET .EQ. 0) CALL FIXDIR /* THIS IS A PRE-REV17 RUNFILE, /* CREATE A DBG SLOT FORIT OFFSET = 1 /* FILE DEFINITELY HAS DBG SLOT NOW C CALL SGDR$$(K$SPOS,SEGDIR,1,IARG,CODE) /*POSITION SEGDIR TO SEGMENT 1 FOR OPEN IF (CODE.NE.0) GO TO 9000 CALL SRCH$$(K$GETU+K$NDAM+K$ISEG+K$RDWR,SEGDIR,0,SEG1,IARG,CODE) /*OPEN SEGMENT 1 IF (CODE.NE.0) GO TO 9000 CALL PRWF$$(K$POSN+K$PREA,SEG1,LOC(0),0,000000,IARG,CODE) IF (CODE .NE. 0) GO TO 9000 CRRPAG = 0 800 CALL PRWF$$(K$READ,SEG1,:1000400000,:4000,000000,CURTOP,CODE) IF (CODE .EQ. E$EOF) GO TO 700 IF (CODE .NE. 0) GO TO 9000 CRRPAG = CRRPAG + 1 GO TO 800 700 LSTTOP = CURTOP LSTPAG = CRRPAG GO TO 7000 C 420 IERROR=OPENT$(K$RDWR,NAME,NAMLNT,IARG) /*BE SURE FILE OPEN AND THERE IF (IARG.NE.0) GO TO 8000 C BUFCNT=SEGS REVFLG = -1 /*REV 16 FLAG ADDED TO BUFCTL DO 300 I=1,ISUB /*ZERO BUFCTL BUFCTL(I)=0 300 CONTINUE CALL PRWF$$(K$TRNC,SGUNIT,LOC(BUFCTL),0,000000,IARG,CODE) /*TRUNCATE IT IF(CODE.NE.0) GO TO 9000 CALL PRWF$$(K$WRIT,SGUNIT,LOC(BUFCTL),ISUB+2,000000,IARG,CODE) /*WRITE IT IF(CODE.NE.0) GO TO 9000 C IF(IERROR.LT.0) GO TO 600 CALL SRCH$$(K$CLOS,0,0,SEG1,IARG,CODE) IF (CODE.NE.E$UNOP.AND.CODE.NE.0) GO TO 9000 ISUB=ISUB*16 ISUB1 = ISUB + OFFSET /*FOR SEG 1 HAVING DEBUGGER INFO DO 100 I=1,ISUB1 CALL SGDR$$(K$SPOS,SEGDIR,I,IPOS,CODE) IF(CODE.NE.0) GO TO 9000 IF(IPOS.LT.0) GO TO 600 /*END OF SEGDIR IF(IPOS.EQ.0) GO TO 100 CALL SRCH$$(K$ISEG+K$DELE,SEGDIR,0,16,IPOS,CODE) /*DELETE SEGMENT IF(CODE.NE.0) GO TO 9000 100 CONTINUE C 600 CALL SGDR$$(K$SPOS,SEGDIR,1,IARG,CODE) /*POSITION TO SEGMENT 1 TO OPEN IT IF (CODE.NE.0) GO TO 9000 C OPEN SEGMENT 1 FOR DEBUG INFO, USE A DAM FILE FOR EASY ACCESS C USE ANY AVAILABLE FILE UNIT GOTTEN FROM SYSTEM CALL SRCH$$(K$GETU+K$NDAM+K$ISEG+K$RDWR,SEGDIR,0,SEG1,IARG,CODE) /*OPEN SEGMENT 1 FOR DEBUG IF (CODE.NE.0) GO TO 9000 CALL SRCH$$(K$CLOS,0,0,SGUNIT,IARG,CODE) /*CLOSE SEGMENT 0 IF(CODE.NE.0) GO TO 9000 CURTOP = 0 CRRPAG = 0 LSTTOP = 0 LSTPAG = 0 7000 INITIT = :100000 /*ALL IS OK OFFSET = 1 /* DBG SLOT HAS BEEN CREATED OR ALREADY EXISTED 8000 RETURN C 9000 CALL ERRPR$(K$NRTN,CODE,0,0,'INITIT',6) C C END C STACK - ROUTINE TO LOCATE A PLACE FOR THE STACK C C CALLING SEQUENCE: CALL STACK(ISTACK) C C WHERE ISTACK IS THE SIZE OF THE STACK TO BE ASSIGNED C SUBROUTINE STACK(ISTACK) C INTEGER ISTACK C C LODCOM.INS.FTN IS LISTED IN LOCPAG NOLIST $INSERT LODCOM.INS.FTN LIST C ITIME(25)=:4000 CALL INITNE(POINT1,:21,0) /*INIT SYMBOL TABLE SEARCH C 1000 IF(NEXT(POINT1).EQ.0) GO TO 2000 /*NEED NEW SEGMENT ISAVE(3)=MAP1(P1SUBS+A$SEGM) IF(MAP1(P1SUBS+A$SEGM).LT.:4000) GO TO 1000 /*NO STACK IN SHARED SEGS IF(AND(MAP1(P1SUBS),:40000).NE.0) GO TO 1000 /*FULL IF(AND(MAP1(P1SUBS),:4000).EQ.0) GO TO 1100 /*NOT SPLIT SEGMNT IF(AND(MAP1(P1SUBS),:20000).NE.0) GO TO 1000 /*PROCEDURE PART GO TO 1200 /*SEE IF STACK WILL FIT C 1100 IF(AND(MAP1(P1SUBS),:20000).EQ.0) GO TO 1000 /*SECTOR 0 NOT FREE C 1200 IF(MAP1(P1SUBS+A$SEGM).LT.:6000) ITIME(25)=MAP1(P1SUBS+A$SEGM) IF(IUCAS(ISTACK,-1-MAP1(P1SUBS+A$TOP)).GE.0) GO TO 1000 /*WON'T FIT C ISAVE(4)=OR(MAP1(P1SUBS+A$TOP),1)+1 /*WORD ADDRESS RETURN C C NEED A NEW SEGMENT C 2000 ISAVE(3)=ISAVE(3)+1 /*POINT TO NEXT FREE SEGMET IF(ISAVE(3).LT.:4000)ISAVE(3)=:4001 /*DON'T CREATE IN SHARED SEGS OR 4000 ISAVE(4)=4 RETURN END C EA - SUBROUTINE TO COMPUTE OFFSETS FOR SYMBOL COMMAND FROM VLOAD C ADAPTED FOR SEG BY KJC 10/04/78 C INTEGER FUNCTION EA(CODE) COMMON /NAMES/ NAME1(3),NAME2(3),NAME3(3),PAR(9) INTEGER *2 TEST,NAME1,NAME2,NAME3,PAR INTEGER *2 INFO(8), CODE LOGICAL QMINUS IF( NAME2(1) .EQ. '+' .OR. NAME2(1) .EQ. '-' ) NAME2(1) = ' ' IF( NAME3(1) .EQ. '+' .OR. NAME3(1) .EQ. '-' ) NAME3(1) = ' ' EA = 0 TEST = 0 QMINUS = .FALSE. CALL RDTK$$(3,INFO,0,0,CODE) CALL RDTK$$(1,INFO,0,0,CODE) /* SY */ IF (INFO(1) .GE. 6) RETURN CALL RDTK$$(1,INFO,0,0,CODE) /* SYMBOL */ IF (INFO(1) .GE. 6) RETURN CALL RDTK$$(1,INFO,TEST,1,CODE) /* OLDSYMBOL,*,SEGNO */ IF (INFO(1) .GE. 6) RETURN IF (AND(INFO(3),:40000) .NE. 0 .OR. TEST .EQ. '* ') + CALL RDTK$$(1,INFO,0,0,CODE) /* ADDR OR SEGNO */ IF (INFO(1) .GE. 6) RETURN 10 CALL RDTK$$(1,INFO,0,0,CODE) IF( INFO(1) .GE. 6 ) RETURN IF( AND(INFO(3),:40000) .NE. 0 ) GO TO 20 IF( AND(INFO(3),:20000) .EQ. 0 ) GO TO 10 QMINUS = .TRUE. GO TO 10 20 IF( .NOT. QMINUS ) EA = EA + INFO(5) IF( QMINUS ) EA = EA - INFO(5) QMINUS = .FALSE. GO TO 10 END