C C P S 2 X T D C C PASS 2 EXTENDED INSTRUCTION HANDLER C C THIS ROUTINE GENERATES THE OBJECT CODE FOR THE EXTENDED C INSTRUCTION SET. C SUBROUTINE PS2XTD(IFLAG) INCLUDE 'BSUCOM.CMN' INCLUDE 'OUTLIN.CMN' INCLUDE 'PRMSYM.CMN' INCLUDE 'SRCLIN.CMN' INTEGER ABSIDX , INSIDX , CODWRD , $ REGSTR , RGISTR , ARGFLG INTEGER*4 IVAL , ADDRES C ABSIDX = 1 INSIDX = OPVALU(OPINDX) !GET INDEX TO XTDINX ENTRY D WRITE (4,1) INSIDX D 1 FORMAT (' PS2XTD LOOKING FOR ',I6) ADDRES = 0 RGISTR = 0 ARGFLG = 0 CALL XPRSIN(IFLAG,IVAL) !GET ADDRESS SPECIFICATION IF (IFLAG.LE.0) GO TO 10 ARGFLG = 1 ADDRES = IVAL CALL XPRSIN(IFLAG,IVAL) !GET REGISTER SPECIFICATION IF (IFLAG.LE.0) GO TO 10 ARGFLG = ARGFLG.OR.2 RGISTR = IVAL 10 CONTINUE CODWRD = XTDINS(INSIDX) D WRITE (4,4) OPINDX, INSIDX, CODWRD, CODWRD D 4 FORMAT (' PS2XTD, OPINDX, INSIDX, CODWRD, CODWRD = ',3I8,O8) IF (CODWRD.EQ.'F6'.OR.CODWRD.EQ.'FE') GO TO 50 IF (CODWRD.GT.0) GO TO 1500 IF (CODWRD.EQ.-300) GO TO 2500 CODWRD = -CODWRD IF (CODWRD.LT.256) GO TO 2000 IF (CODWRD.GT.400) GO TO 1900 CODWRD = CODWRD-300 GO TO (100, 200, 300), CODWRD C 50 CONTINUE D WRITE (4,5) CODWRD, ADDRES D 5 FORMAT (' PS2XTD WORKING ON SHIFTING CODE ',A2, I5,' TIMES') IF (ADDRES.LT.1.OR.ADDRES.GT.4) CALL FLGERR(15) DO 60 I=1,ADDRES ABSCOD(I) = CODWRD 60 CONTINUE ABSIDX = ADDRES+1 GO TO 2500 C 100 CONTINUE CALL BINHEX(ADDRES,ABSCOD(ABSIDX),2) GO TO 1000 200 CONTINUE ITEMP = ADDRES/256 IF (ADDRES.LT.0) ITEMP = (65536+ADDRES)/256 CALL BINHEX(ITEMP,ABSCOD(ABSIDX),2) ABSIDX = ABSIDX+1 IF (ABSIDX.GT.6) GO TO 250 210 CONTINUE CALL BINHEX(ADDRES,ABSCOD(ABSIDX),2) GO TO 1000 250 CONTINUE CALL PRTLIN(0) ABSIDX = 1 PCNTR = PCNTR+6 CALL TRIVIA(1,L) !BLANK FILL LINBUF AND ERRFLG CALL TRIVIA(5,L) !BLANK FILL ABSCOD GO TO 210 300 CONTINUE IVAL = ADDRES/256 IF (ADDRES.LT.0) IVAL = (65536+ADDRES)/256 CALL BINHEX(IVAL,ABSCOD(ABSIDX),2) GO TO 1000 1000 CONTINUE ABSIDX = ABSIDX+1 INSIDX = INSIDX+1 IF (ABSIDX.LE.6) GO TO 10 ABSIDX = 1 CALL PRTLIN(0) PCNTR = PCNTR+6 CALL TRIVIA(1,L) !BLANK FILL LINBUF AND ERRFLG CALL TRIVIA(5,L) !BLANK FILL ABSCOD GO TO 10 1500 CONTINUE CALL BINHEX(CODWRD,ABSCOD(ABSIDX),2) GO TO 1000 1900 CONTINUE D WRITE (4,3) ADDRES,CODWRD D 3 FORMAT (' PS2XTD AT 1900, ADDRES, CODWRD = ',2I6) REGSTR = ADDRES CODWRD = CODWRD-400 GO TO 2010 2000 CONTINUE D WRITE (4,2) ADDRES,RGISTR,ARGFLG D 2 FORMAT (' PS2XTD AT 2000, ADDRES, RGISTR, ARGFLG = ',3I6) REGSTR = RGISTR IF (ARGFLG.EQ.1) REGSTR = ADDRES !ONLY 1 ARGUMENT? 2010 IF (REGSTR.LT.0.OR.REGSTR.GT.15) GO TO 2050 CODWRD = CODWRD+REGSTR GO TO 1500 2050 CONTINUE CALL FLGERR(18) !R-ERROR, REGISTER NUMBER BAD GO TO 1500 2500 CONTINUE IF (ABSIDX.LE.1) RETURN CALL PRTLIN(0) PCNTR = PCNTR+ABSIDX-1 RETURN END