C VAX/VMS Executable Image File Disassembler, V0.0 (26-MAY-1982) C rebuilt to V1.0 on 6-JAN-1984 C rebuilt to V2.0 on 6-FEB-1986 C rebuilt to V3.0 on 30-JUN-1986 C rebuilt to V3.1 on 21-JUL-1986 C rebuilt to V3.2 on 24-JUL-1986 C rebuilt to V3.3 on 28-JUL-1986 C rebuilt to V3.4 on 6-NOV-1986 C rebuilt to V3.5 on 18-DEC-1986 C rebuilt to V3.6 on 3-FEB-1987 (fix typos in table processing, stack ISD, C undef and HALT opcode processing) C rebuilt to V3.7 on 6-FEB-1987 (add .ADDRESS fixup processing, add GST C dumping, fix some RMS bugs) C rebuilt to V4.0 on 1-APR-1987 (add extended symbol table processing, C recognition of shareable image transfer C vectors, P-sect table analysis, change C format of made-up symbol names, fix bugs C in DST analysis, fix filename source C for .SYM file read, add logic to detect C some condition code symbols, optimize) C rebuilt to V4.1 on 31-JUL-1987 (finish transfer vector processing, fix C bugs, change RMS block symbol naming to C use type of block for name, finish code C for symbolically using condition code C names, add code to recognize BASIC C preambles and interpret BASIC subprogram C arglists) C C written by Andrew Pavlin, C General Electric Company C Military Electronic Systems Organization C Syracuse, NY 13221 C C This program, implemented as a VMS foreign command, will accept C an executable or shareable image file (filetype assumed to be .EXE), C and generate an ASCII text file of filetype .MAR containing an assembly C source listing of the contents of the executable or shareable image. C Symbols will be extracted from any debugger or global symbol tables C embedded in the image file and used to label the source listing; C symbols will be created by the program to fill any undefined names. C C********************************************************************** C C declare variables C IMPLICIT NONE C INCLUDE 'DISMSYMTBL.INC' INCLUDE 'DISMMODTBL.INC' INCLUDE 'DISMLINTBL.INC' INCLUDE 'DISMISDTBL.INC' INCLUDE 'DISMMISC.INC' C BYTE HDR_BUF(0:8191) BYTE TAB,REC_TYP,REC_SUBTYP,form_feed,FACILITY_NAMLEN, MSG_NAMLEN, + DISPL_BYT, BASIC_ENTRY(2:21), BASIC_ENTRY_CMP(2:21), + BASIC_ENTRY_DEF(2:17) CHARACTER*1 DTYP_C(0:15) CHARACTER*3 C_ROP_CODES(0:31), C_FAB_FAC_CODES(0:7), + C_FAB_FOP_CODES(0:30), C_FAB_RAT_CODES(0:3), + C_FAB_SHR_CODES(0:6) CHARACTER*4 PROT_NAME(0:15), ADAPTER_NAME(0:6) CHARACTER*5 IMG_LNK_TYP(1:3) /'BPA','ALIAS','CLI'/, + C_FAB_RFM_CODES(0:6) CHARACTER*6 BLOCK_TYPE(73), C_ISDTYP(0:4), C_MATCH_TYPE(0:3) CHARACTER*7 LANGUAGE_NAME(0:10), RMS_TYPNAM('23'X) CHARACTER*8 STR_DELIM, SPECIAL_MACRO(20) CHARACTER*16 BASIC_ENTRY_DEF_C CHARACTER*20 BASIC_ENTRY_C, BASIC_ENTRY_CMP_C CHARACTER*23 DT_STR, FACILITY_NAM CHARACTER*16 EDIT_NAM(17) CHARACTER*31 ROUTINE_NAME, BLOCK_NAME CHARACTER*64 OUT_FIL, FACILITY_BUF CHARACTER*256 CMD_LIN CHARACTER*512 S_TMP, MESSAGE_BUF INTEGER*2 LN,LN2,LN3,LN4, FACILITY_NUMBER, DISPL_WRD, + RMS_TYPNAMLEN('23'X) INTEGER*4 I,J,K,ADDR,OP_MODE,I_FLT(4),EDIT_MASK(17),EDIT_OPC(17), + EDIT_ARG(17),DTYP_SIZE(0:25),LIBRARY_INDEX, I2, I3, I8, I9, + ICODE, OFFSET_VEC(0:1), CURRENT_LINE, CURRENT_STMT, CURRENT_INCR, + CURRENT_PC, DBG_RECS, AUX_SYM_TBL(-1:256), MSG_USERVALUE, + MSG_FAOCOUNT, MSG_NUMFAC, MSG_FACDESCR(0:4,30), MOD_PTR, + BASIC_ENTRY_ARGLIST, BASIC_ENTRY_INIT, BASIC_DEF_ARGLIST, + BASIC_DEF_INIT LOGICAL*1 ISD_PRESENT,OK,OK2, CURRENT_STMT_MODE, CURRENT_MARK, + DTYP_CONTINUE(0:25), LLV_CODEMODE REAL*4 X_FLT REAL*8 X_DFL ! GFL has to be done by a separate subroutine REAL*16 X_HFL EXTERNAL RMS$_EOF,DISM__ISDTBLOVF,DISM__INVINITAB, + DISM__UNKIMGTYP,DISM__FORTIORD,DISM__BADSYSSTB, + DISM__BADSHRIMG,DISM__INVOPCODE,DISM__BADUSRSFL, + DISM__SYMTBLOVF,DISM__INVSYMSRC,DISM__UNRECVEC, + DISM__COMPATIMG,DISM__NONSTDIMG,DISM__NOIMGHDR, + DISM__CORDTSTRUC,DISM__DIFINTNAM, DISM__MODTBLOVF, + DISM__LINTBLOVF EXTERNAL SS$_BADIMGHDR, DYN$C_DPT, DYN$C_DDB, DYN$C_UCB, + DYN$C_CRB, DYN$C_IDB INTEGER*4 DISM_INSTR, ANALYZE_SYM_REC, FIND_P2_SYMBOL, + CONVERT_F_FLOAT, CONVERT_D_FLOAT, + CONVERT_G_FLOAT, CONVERT_H_FLOAT EXTERNAL FIX_BUFR_OVRFL,FIX_BUF_1,FIX_BUF_3, DISM_INSTR, + ANALYZE_SYM_REC, FIND_P2_SYMBOL, + CONVERT_F_FLOAT, CONVERT_D_FLOAT, + CONVERT_G_FLOAT, CONVERT_H_FLOAT INTEGER*4 LIB$INIT_TIMER, LIB$GET_FOREIGN, LIB$FFS, + LBR$INI_CONTROL, LBR$OPEN, LBR$LOOKUP_KEY, + LBR$GET_RECORD, LBR$CLOSE, SYS$ADJWSL, + STR$FIND_FIRST_NOT_IN_SET EXTERNAL LIB$INIT_TIMER, LIB$GET_FOREIGN, LIB$FFS, + LBR$INI_CONTROL, LBR$OPEN, LBR$LOOKUP_KEY, + LBR$GET_RECORD, LBR$CLOSE, SYS$ADJWSL, + STR$FIND_FIRST_NOT_IN_SET COMMON/CMDLINPRS/CMD_LIN, OUT_FIL DATA TAB/9/, form_feed/12/ DATA DTYP_C/'B','B','W','L','Q','F','D','G','H','B','B','B','B', + 'B','B','O'/ DATA C_ROP_CODES/'ASY','TPT','REA','RRL','UIF','MAS','FDL','HSH', + 'EOF','RAH','WBH','BIO','LV2','LOA','LIM','***','LOC','WAT', + 'ULK','RLK','NLK','KGE','KGT','NXR','RNE','TMO','CVT','RNF', + 'ETO','PTA','PMT','CCO'/ DATA C_FAB_FAC_CODES/'PUT','GET','DEL','UPD','TRN','BIO','BRO', + 'EXE'/ DATA C_FAB_FOP_CODES/'ASY','MXV','SUP','TMP','TMD','DFW','SQO', + 'RWO','POS','WCK','NEF','RWC','DMO','SPL','SCF','DLT','NFS', + 'UFO','PPF','INP','CTG','CBT','***','RCK','NAM','CIF','***', + 'ESC','TEF','OFP','KFO'/ DATA C_FAB_RAT_CODES/'FTN','CR','PRN','BLK'/ DATA C_FAB_RFM_CODES/'UDF','FIX','VAR','VFC','STM','STMLF', + 'STMCR'/ DATA C_FAB_SHR_CODES/'PUT','GET','DEL','UPD','MSE','NIL','UPI'/ DATA C_ISDTYP/'NORMAL','SHRFXD','PRVFXD','SHRPIC','PRVPIC'/ DATA C_MATCH_TYPE/'MATALL','MATEQU','MATLEQ','unsupt'/ DATA ADAPTER_NAME/'MBA','UBA','DR','MPM','CI','NULL','BDA'/ DATA BLOCK_TYPE/'ADP','ACB','AQB','CEB','CRB','DDB','FCB','FRK', + 'IDB','IRP','LOG','PCB','PQB','RVT','TQE','UCB', + 'VCB','WCB','BUFIO','TYPAHD','GSD','MVL','NET', + 'KFE','MTL','BRDCST','CXB','NDB','SSB','DPT','JPB', + 'PBH','PDB','PIB','PFL','JNLWCB','PTR','KFRH','DCCB', + 'EXTGSD','SHMGSD','SHB','MBX','IRPE','SLAVCEB', + 'SHMCEB','JIB','TWP','RBM','VCA','CDB','LPD','LKB', + 'RSB','LKID','RSHT','CDRP','ERP','CIDG','CIMSG','XWB', + 'WQE','ACL','LNM','FLK','RIGHTSLIST','KFD','KFPB', + 'CIA','PMB','PFB','CHIP','ORB'/ DATA STR_DELIM/'"/\%#@'''/ DATA LANGUAGE_NAME/'MACRO32','FORTRAN','BLISS','COBOL','BASIC', + 'PL/I','Pascal','C','RPG II','Ada','unknown'/ DATA DTYP_SIZE/4,1,2,4,8,4,8,8,16,1,1,1,1,1,1,16,4*1, + 1,44,42,1,1,4/ DATA DTYP_CONTINUE/16*.TRUE.,4*.FALSE.,.FALSE.,.FALSE.,.FALSE., + .TRUE.,.TRUE.,.TRUE./ DATA EDIT_MASK/'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'FF'X, + 'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'F0'X,'F0'X,'F0'X,0/ DATA EDIT_OPC/0,1,2,3,4,'40'X,'41'X,'42'X,'43'X,'44'X,'45'X, + '46'X,'47'X,'80'X,'90'X,'A0'X,0/ DATA EDIT_ARG/0,0,0,0,0,3,3,3,3,3,2,2,2,1,1,1,0/ DATA EDIT_NAM/'EO$END','EO$END_FLOAT','EO$CLEAR_SIGNIF', + 'EO$SET_SIGNIF','EO$STORE_SIGN','EO$LOAD_FILL','EO$LOAD_SIGN', + 'EO$LOAD_PLUS','EO$LOAD_MINUS','EO$INSERT','EO$BLANK_ZERO', + 'EO$REPLACE_SIGN','EO$ADJUST_INPUT','EO$FILL','EO$MOVE', + 'EO$FLOAT',' '/ DATA PROT_NAME/'n/a','rsrv','KW','KR','UW','EW','ERKW','ER','SW', + 'SREW','SRKW','SR','URSW','UREW','URKW','UR'/ DATA SPECIAL_MACRO/'$TPADEF','$TPADEF','$TPADEF','$DVIDEF', + '$JPIDEF','$QUIDEF','$SYIDEF','$SJCDEF', + '$ACLDEF','$CHPDEF','$LNMDEF','$PQLDEF', + '$FSCNDEF','$LKIDEF','$UAIDEF','$MNTDEF', + 4*' '/ DATA RMS_TYPNAM/'RAB_','NAM_','FAB_', ! 1-3 + 14*'***', ! 4-17 + 'XABDAT_','XABPRO_','XABALL_','XABKEY_', ! 18-21 + 'XABSUM_',6*'***', ! 22-28 + 'XABFHC_','XABRDT_','XABTRM_','XABCXF_', ! 29-32 + 'XABCXR_','XABJNL_','XABRU_'/ ! 33-35 DATA RMS_TYPNAMLEN/3*4,14*0,5*7,6*0,6*7,6/ DATA BASIC_ENTRY_CMP/'9E'X,'AF'X,'FB'X,'52'X,'9E'X,'EF'X,0,0,0,0, + '50'X,'D0'X,'50'X,'51'X,'16'X,'FF'X,0,0,0,0/ DATA BASIC_ENTRY_DEF/'9E'X,'EF'X,0,0,0,0,'50'X,'D0'X,'50'X,'51'X, + '16'X,'FF'X,0,0,0,0/ EQUIVALENCE (I_FLT(1),X_FLT,X_DFL,X_HFL) EQUIVALENCE (FACILITY_BUF(1:2), FACILITY_NUMBER), + (FACILITY_BUF(3:3), FACILITY_NAMLEN), + (FACILITY_BUF(4:4), FACILITY_NAM(1:1)) EQUIVALENCE (MESSAGE_BUF(1:4), MSG_USERVALUE), + (MESSAGE_BUF(5:8), MSG_FAOCOUNT), + (MESSAGE_BUF(9:9), MSG_NAMLEN) EQUIVALENCE (BASIC_ENTRY, BASIC_ENTRY_C), + (BASIC_ENTRY(4), BASIC_DEF_ARGLIST), + (BASIC_ENTRY(8), BASIC_ENTRY_ARGLIST), + (BASIC_ENTRY(14), BASIC_DEF_INIT), + (BASIC_ENTRY(18), BASIC_ENTRY_INIT), + (BASIC_ENTRY_CMP, BASIC_ENTRY_CMP_C), + (BASIC_ENTRY_DEF, BASIC_ENTRY_DEF_C) INCLUDE '($FSCNDEF)' INCLUDE '($JPIDEF)' INCLUDE '($LBRDEF)' C STRUCTURE /BASIC/ UNION MAP BYTE ARGLIST(0:71) END MAP MAP INTEGER*4 LEN BYTE VERSION BYTE PROC_TYP INTEGER*2 FLAGS INTEGER*4 OFS_NAME BYTE PACKED_SCALEF BYTE DFL_SCALEF BYTE %FILL(2) INTEGER*4 NUM_NSCALARS INTEGER*4 NUM_FARG INTEGER*4 NUM_BYT_DESCR ! +24 INTEGER*4 OFS_TEMPLATE INTEGER*4 NUM_MOD_DESCR INTEGER*4 OFS_MOD_DESCR INTEGER*2 NUM_DYN_DESCR INTEGER*2 NUM_FIX_STRTMP INTEGER*4 NUM_BYT_ARRAY INTEGER*4 NUM_STMP_DESCR INTEGER*4 NUM_BYT_NTMP INTEGER*4 OFS_BGN_DATA ! +56 INTEGER*4 OFS_END_DATA INTEGER*4 LEN_RTA_DESCR INTEGER*4 V1_FILL END MAP END UNION END STRUCTURE RECORD /BASIC/ BASIC C STRUCTURE /IHD/ INTEGER*2 W_SIZE INTEGER*2 W_ACTIVOFF INTEGER*2 W_SYMDBGOFF INTEGER*2 W_IMGIDOFF INTEGER*2 W_PATCHOFF BYTE %FILL (2) INTEGER*2 W_MAJORID INTEGER*2 W_MINORID BYTE B_HDRBLKCNT BYTE B_IMGTYPE BYTE %FILL (2) INTEGER*4 Q_PRIVREQS(2) INTEGER*2 W_IOCHANCNT INTEGER*2 W_IMGIOCNT INTEGER*4 L_LNKFLAGS INTEGER*4 L_IDENT INTEGER*4 L_SYSVER INTEGER*4 L_IAFVA END STRUCTURE INTEGER*4 IHD$S_SIZE PARAMETER(IHD$S_SIZE=48) RECORD /IHD/ IHD, SHR_IHD STRUCTURE /IHA/ INTEGER*4 L_TFRADR(3) INTEGER*4 %FILL END STRUCTURE INTEGER*4 IHA$S_SIZE PARAMETER(IHA$S_SIZE=16) RECORD /IHA/ IHA STRUCTURE /IHI/ BYTE B_IMGNAMLEN UNION MAP CHARACTER*39 T_IMGNAM BYTE B_IMGIDLEN CHARACTER*15 T_IMGID INTEGER*4 Q_LINKTIME(2) BYTE B_LINKIDLEN CHARACTER*15 T_LINKID END MAP MAP CHARACTER*15 T_IMGNAM_V3 BYTE B_IMGIDLEN_V3 CHARACTER*15 T_IMGID_V3 INTEGER*4 Q_LINKTIME_V3(2) BYTE B_LINKIDLEN_V3 CHARACTER*15 T_LINKID_V3 END MAP END UNION END STRUCTURE INTEGER*4 IHI$S_SIZE, IHI$S_SIZE_V3 PARAMETER(IHI$S_SIZE=80, + IHI$S_SIZE_V3=50) RECORD /IHI/ IHI STRUCTURE /IHP/ INTEGER*4 L_ECO1 INTEGER*4 L_ECO2 INTEGER*4 L_ECO3 INTEGER*4 L_ECO4 INTEGER*4 L_RW_PATSIZ INTEGER*4 L_RW_PATADR INTEGER*4 L_RO_PATSIZ INTEGER*4 L_PATADR INTEGER*4 L_PATCOMTXT INTEGER*4 Q_PATDATE(2) END STRUCTURE INTEGER*4 IHP$S_SIZE PARAMETER(IHP$S_SIZE=44) RECORD /IHP/ IHP STRUCTURE /IHS/ INTEGER*4 L_DSTVBN INTEGER*4 L_GSTVBN INTEGER*2 W_DSTBLKS INTEGER*2 W_GSTRECS END STRUCTURE INTEGER*4 IHS$S_SIZE PARAMETER(IHS$S_SIZE=12) RECORD /IHS/ IHS, SHR_IHS STRUCTURE /IAF/ INTEGER*4 L_IAFLINK INTEGER*4 L_FIXUPLNK INTEGER*2 W_SIZE INTEGER*2 W_FLAGS INTEGER*4 L_G_FIXOFF INTEGER*4 L_DOTADROFF INTEGER*4 L_CHGPRTOFF INTEGER*4 L_SHLSTOFF INTEGER*4 L_SHRIMGCNT INTEGER*4 L_SHREXTRA INTEGER*4 L_PERMCTX BYTE %FILL (24) END STRUCTURE INTEGER*4 IAF$M_SHR PARAMETER(IAF$M_SHR='1'X) INTEGER*4 IAF$S_SIZE PARAMETER(IAF$S_SIZE=64) RECORD /IAF/ IAF STRUCTURE /SHL/ INTEGER*4 L_BASEVA INTEGER*4 L_SHLPTR INTEGER*4 L_IDENT INTEGER*4 L_PERMCTX BYTE B_SHL_SIZE BYTE %FILL (7) BYTE B_IMGNAMLEN CHARACTER*39 T_IMGNAM END STRUCTURE INTEGER*4 SHL$S_SIZE, SHL$S_SIZE_V3 PARAMETER(SHL$S_SIZE=64, + SHL$S_SIZE_V3=56) RECORD /SHL/ FIX_SHL(0:15) STRUCTURE /DPT/ INTEGER*4 %FILL (2) ! FLINK, BLINK INTEGER*2 W_SIZE BYTE B_TYPE BYTE %FILL ! REFC BYTE B_ADPTYPE BYTE B_FLAGS INTEGER*2 W_UCBSIZE INTEGER*2 W_INITTAB INTEGER*2 W_REINITTAB INTEGER*2 W_UNLOAD INTEGER*2 W_MAXUNITS INTEGER*2 W_VERSION INTEGER*2 W_DEFUNITS INTEGER*2 W_DELIVER INTEGER*2 W_VECTOR BYTE B_NAMELEN CHARACTER*11 T_NAME END STRUCTURE INTEGER*4 DPT$S_SIZE PARAMETER(DPT$S_SIZE=44) RECORD /DPT/ DPT STRUCTURE /DDT/ INTEGER*4 L_START INTEGER*4 L_UNSOLINT INTEGER*4 L_FDT INTEGER*4 L_CANCEL INTEGER*4 L_REGDUMP INTEGER*2 W_DIAGBUF INTEGER*2 W_ERRORBUF INTEGER*4 L_UNITINIT INTEGER*4 L_ALTSTART INTEGER*4 L_MNTVER INTEGER*4 L_CLONEDUCB INTEGER*2 W_FDTSIZE INTEGER*2 %FILL INTEGER*4 L_MNTV_SSSC INTEGER*4 L_MNTV_FOR INTEGER*4 L_MNTV_SQD END STRUCTURE INTEGER*4 DDT$S_SIZE PARAMETER(DDT$S_SIZE=56) RECORD /DDT/ DDT STRUCTURE /DPT_STORE/ BYTE B_STRUCTYPE BYTE B_STRUCOFFSET BYTE B_OPERATION UNION MAP BYTE B_BYTEVAL END MAP MAP INTEGER*2 W_WORDVAL END MAP MAP INTEGER*4 L_LONGVAL END MAP MAP INTEGER*4 L_FIELDVAL BYTE B_FIELDPOS BYTE B_FIELDSIZ END MAP END UNION END STRUCTURE INTEGER*4 DPT_STORE$S_SIZE PARAMETER(DPT_STORE$S_SIZE=9) RECORD /DPT_STORE/ DPT_STORE INTEGER*4 DDT_ADR STRUCTURE /PLV/ INTEGER*4 L_TYPE INTEGER*4 L_VERSION UNION MAP INTEGER*4 L_KERNEL END MAP MAP INTEGER*4 L_MSGDSP END MAP END UNION INTEGER*4 L_EXEC INTEGER*4 L_USRUNDWN INTEGER*4 %FILL INTEGER*4 L_RMS INTEGER*4 L_CHECK END STRUCTURE RECORD /PLV/ PLV C C********************************************************************* C C begin the code: C C get random statistical stuff C CALL SYS$ASCTIM(,DT_STR,,) ICODE=LIB$INIT_TIMER() IF(.NOT.ICODE)CALL LIB$SIGNAL(%VAL(ICODE)) C C get the input command line C ICODE=LIB$GET_FOREIGN(CMD_LIN,'$_File_: ',LN) IF(ICODE.EQ.%LOC(RMS$_EOF))THEN CALL EXIT ELSEIF(.NOT.ICODE)THEN CALL LIB$SIGNAL(%VAL(ICODE)) ENDIF C C analyze the command line C OUT_FIL=' ' C C open the input file C OPEN(UNIT=1,FILE=CMD_LIN(1:LN),ACCESS='DIRECT',READONLY, + FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL',BUFFERCOUNT=16, + RECL=128,RECORDTYPE='FIXED',STATUS='OLD',DEFAULTFILE='.EXE') C C read in the image header record from the input file C READ(1,REC=1) (HDR_BUF(I),I=0,511) C C abort if not a native-mode image C IF(HDR_BUF(511).EQ.0.AND.HDR_BUF(510).EQ.0)THEN CALL SYS$EXIT(DISM__COMPATIMG) ELSEIF(HDR_BUF(511).EQ.'FF'X.AND.HDR_BUF(510).EQ.'FF'X)THEN CONTINUE ! normal image ELSEIF(HDR_BUF(511).EQ.0.AND.HDR_BUF(510).GE.1.AND. + HDR_BUF(510).LE.3)THEN CALL LIB$SIGNAL(DISM__NONSTDIMG,%VAL(1),IMG_LNK_TYP(HDR_BUF(510))) ELSE CALL LIB$SIGNAL(DISM__NOIMGHDR) CMD_LIN=' ' CALL LIB$GET_INPUT(CMD_LIN,'Is this a system image (Y/N) ? ') IF(CMD_LIN(1:1).EQ.'Y'.OR.CMD_LIN(1:1).EQ.'y')THEN CALL LIB$GET_INPUT(CMD_LIN,'Base address of image (hex) > ',LN) READ(CMD_LIN(1:LN),'(Z)') ISD_BASEVA(1) ISD_NUM=1 ISD(1).W_SIZE=16 J=1 ICODE=0 DO WHILE (ICODE.EQ.0) J=J+1 READ(1,REC=J,IOSTAT=ICODE) ENDDO ISD(1).W_PAGCNT=J-1 ISD(1).L_VPNPFC=JISHFT(ISD_BASEVA(1),-9) ISD(1).L_FLAGS='38A'X ! ISD$M_BASED, ISD$M_COPYALWAYS, ! ISD$M_LASTCLUSTER, ISD$M_WRT, ISD$M_CRF ISD(1).L_VBN=1 ISD(1).L_IDENT=0 ISD(1).B_GBLNAMLEN=0 ISD(1).T_GBLNAM=' ' ISD_PGEND(1)=ISD_BASEVA(1)-1+512*JZEXT(ISD(1).W_PAGCNT) ISD_NAM(1)=' ' ISD_LAST_P0PAGE=ISD_PGEND(1) IHD.W_SIZE=0 IHD.W_ACTIVOFF=0 IHD.W_SYMDBGOFF=0 IHD.W_IMGIDOFF=0 IHD.W_PATCHOFF=0 IHD.W_MAJORID=0 IHD.W_MINORID=0 IHD.B_HDRBLKCNT=0 IHD.B_IMGTYPE=1 IHD.Q_PRIVREQS(1)=0 IHD.Q_PRIVREQS(2)=0 IHD.W_IOCHANCNT=0 IHD.W_IMGIOCNT=0 IHD.L_LNKFLAGS='32'X ! LNK$M_DBGDMT, LNK$M_P0IMAGE, LNK$M_LNKNOTFR IHD.L_IDENT=0 IHD.L_SYSVER=0 IHD.L_IAFVA=0 INQUIRE(UNIT=1,NAME=OUT_FIL) CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) I=INDEX(OUT_FIL(1:LN),']') I=I+1 J=INDEX(OUT_FIL(I:LN),'.')+I-2 IHI.T_IMGNAM=OUT_FIL(I:J) OUT_FIL=' ' IHI.B_IMGNAMLEN=J-I+1 IHI.T_IMGID='?SYSTEM?' IHI.B_IMGIDLEN=8 IHI.T_LINKID='??.??' IHI.B_LINKIDLEN=5 GOTO 10 ! skip normal image header crunching ELSE CALL SYS$EXIT(SS$_BADIMGHDR) ENDIF ENDIF C C copy image header's header from buffer to structure C CALL LIB$MOVC3(IHD$S_SIZE,HDR_BUF(0),IHD) C C copy any additional blocks of header to header buffer C DO I=1,IHD.B_HDRBLKCNT-1 READ(1,REC=I+1) (HDR_BUF(I*512+J),J=0,511) ENDDO C C copy image activation address vector from buffer to structure C CALL LIB$MOVC3(IHA$S_SIZE,HDR_BUF(IHD.W_ACTIVOFF),IHA) C C copy image header symbol table pointers from buffer to structure C CALL LIB$MOVC3(IHS$S_SIZE,HDR_BUF(IHD.W_SYMDBGOFF),IHS) C C copy identification section from buffer to structure C CALL LIB$MOVC3(IHI$S_SIZE,HDR_BUF(IHD.W_IMGIDOFF),IHI) C C if patch offset specified then copy patch data from buffer to structure C IF(IHD.W_PATCHOFF.NE.0)THEN CALL LIB$MOVC3(IHP$S_SIZE,HDR_BUF(IHD.W_PATCHOFF),IHP) ENDIF C C begin transferring image section descriptors to arrays C I=IHD.W_SIZE ! get beginning of ISD list ISD_PRESENT=.TRUE. ISD_NUM=0 ISD_LAST_P0PAGE=-1 DO WHILE (ISD_PRESENT) ISD_NUM=ISD_NUM+1 IF(ISD_NUM.GT.ISD_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__ISDTBLOVF) ENDIF CALL LIB$MOVC3(ISD$S_SIZE,HDR_BUF(I),ISD(ISD_NUM)) IF(ISD(ISD_NUM).W_SIZE .EQ. 0)THEN ISD_NUM=ISD_NUM-1 ISD_PRESENT=.FALSE. ELSEIF(ISD(ISD_NUM).W_SIZE .EQ. 'FFFF'X)THEN ! end of block wrap-around I=IAND(I+511,.NOT.'1FF'X) ! advance to beginning of next block ISD_NUM=ISD_NUM-1 ! back up ISD counter ELSE ! this is where all work actually gets done in this loop ISD_NAM(ISD_NUM)=' ' ISD_BASEVA(ISD_NUM)=512*(ISD(ISD_NUM).L_VPNPFC .AND. '007FFFFF'X) ISD_PGEND(ISD_NUM)=ISD_BASEVA(ISD_NUM)-1+ + 512*JZEXT(ISD(ISD_NUM).W_PAGCNT) IF(JISHFT(ISD(ISD_NUM).L_FLAGS ,-24).NE.-3.AND. + JISHFT(ISD(ISD_NUM).L_FLAGS ,-24).NE.253)THEN ISD_LAST_P0PAGE=ISD_PGEND(ISD_NUM) ENDIF IF(ISD(ISD_NUM).W_SIZE .LE.16)THEN ISD(ISD_NUM).L_IDENT=0 ISD(ISD_NUM).B_GBLNAMLEN=0 ISD(ISD_NUM).T_GBLNAM=' ' IF(ISD(ISD_NUM).W_SIZE .LE.12)THEN ISD(ISD_NUM).L_VBN=0 ENDIF ENDIF I=I+ISD(ISD_NUM).W_SIZE ENDIF ENDDO C C calculate approximate allocation size for output file C 10 I2=3+ISD_NUM ! allow space for image header and I-sect text DO I=1,ISD_NUM IF(JISHFT(ISD(I).L_FLAGS ,-24).EQ.-3.OR. + JISHFT(ISD(I).L_FLAGS ,-24).EQ.253.OR. ! skip stack + (ISD(I).L_FLAGS .AND.1).NE.0)THEN ! skip referenced shrimg's CONTINUE ELSEIF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)THEN ! add vector sections I2=I2+2*ISD(I).W_PAGCNT ELSEIF((ISD(I).L_FLAGS .AND.4).NE.0)THEN ! add demand-zero sections I2=I2+ISD(I).W_PAGCNT/2 ELSE ! add other types of sections I2=I2+6*ISD(I).W_PAGCNT ENDIF ENDDO C C generate name for output file C IF(OUT_FIL(1:1).EQ.' ')THEN INQUIRE(UNIT=1,NAME=OUT_FIL) CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) I=INDEX(OUT_FIL(1:LN),']') I=I+1 J=INDEX(OUT_FIL(I:LN),'.')+I-2 ELSE I=1 CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) J=LN ENDIF C C open output file C OPEN(UNIT=2,FILE=OUT_FIL(I:J),STATUS='NEW', + FORM='FORMATTED',CARRIAGECONTROL='LIST', + DEFAULTFILE='.MAR',INITIALSIZE=I2, + BLOCKSIZE=MIN(I2*512,16384)) C C print initial information to the output file C IF(OUT_FIL(I:J) .NE. IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN))THEN CALL LIB$SIGNAL(DISM__DIFINTNAM,%VAL(2),OUT_FIL(I:J), + IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)) ENDIF INQUIRE(UNIT=1,NAME=CMD_LIN) CALL STR$TRIM(CMD_LIN,CMD_LIN,LN) 9000 FORMAT(A1,'.TITLE',A1,A,' ',A,' Disassembly') 9001 FORMAT(A1,'.IDENT',A1,'/',A,'/') 9002 FORMAT(';') 9003 FORMAT('; Disassembly of ',A/ + ';',A1,'on ',A,' by VAX/VMS DISM32 V4.1') 9004 FORMAT('; as linked by LINK-32 V',A,' on ',A23) IF((IHD.L_LNKFLAGS .AND.'20'X).EQ.0)THEN ! VMS V3- version of linker WRITE(2,9000) TAB, TAB, IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN), + CMD_LIN(1:LN) WRITE(2,9001) TAB, TAB, IHI.T_IMGID_V3(1:IHI.B_IMGIDLEN_V3) WRITE(2,9002) WRITE(2,9003) CMD_LIN(1:LN), TAB, DT_STR WRITE(2,9002) CALL SYS$ASCTIM(,S_TMP,IHI.Q_LINKTIME_V3,) WRITE(2,9004) IHI.T_LINKID_V3(1:IHI.B_LINKIDLEN_V3), S_TMP(1:23) ELSE ! VMS V4+ version of link WRITE(2,9000) TAB, TAB, IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN), + CMD_LIN(1:LN) WRITE(2,9001) TAB, TAB, IHI.T_IMGID(1:IHI.B_IMGIDLEN) WRITE(2,9002) WRITE(2,9003) CMD_LIN(1:LN), TAB, DT_STR WRITE(2,9002) CALL SYS$ASCTIM(,S_TMP,IHI.Q_LINKTIME,) WRITE(2,9004) IHI.T_LINKID(1:IHI.B_LINKIDLEN), S_TMP(1:23) ENDIF WRITE(2,9002) IF(IHD.B_IMGTYPE.EQ.1)THEN S_TMP='executable (IHD$K_EXE)' ELSEIF(IHD.B_IMGTYPE.EQ.2)THEN S_TMP='shareable (IHD$K_LIM)' ELSE CLOSE(UNIT=1) CLOSE(UNIT=2,DISP='DELETE') CALL SYS$EXIT(DISM__UNKIMGTYP) ENDIF IF((IHD.L_LNKFLAGS .AND.'20'X).EQ.0)THEN ! VMS V3- version of linker WRITE(2,9005) IHI.T_IMGID_V3(1:IHI.B_IMGIDLEN_V3), S_TMP(1:22), + ISD_NUM, IHD.B_HDRBLKCNT, IHS.W_DSTBLKS, IHS.W_GSTRECS ELSE ! VMS V4+ version of link WRITE(2,9005) IHI.T_IMGID(1:IHI.B_IMGIDLEN), S_TMP(1:22), + ISD_NUM, IHD.B_HDRBLKCNT, IHS.W_DSTBLKS, IHS.W_GSTRECS ENDIF 9005 FORMAT('; image ID = ',A,', type ',A/ + '; contains ',I5,' image sections'/ + ';'/ + '; header contains',I2,' blocks'/ + '; image contains ',I5,' blocks of debug symbol table data,'/ + '; and ',I5,' records of global symbol table data') IF(IHD.B_IMGTYPE .EQ.2)THEN LN=ISHFT(IHD.L_LNKFLAGS,-24).AND.'FF'X WRITE(2,9022) ISHFT(IHD.L_IDENT,-24), IAND(IHD.L_IDENT,'FFFFFF'X), + C_MATCH_TYPE(LN) 9022 FORMAT(';'/ + '; global section major ID: %X''',Z2.2, + ''', minor ID: %X''',Z6.6,''''/ + '; match control: ISD$K_',A) ENDIF LN=1 S_TMP=' ' IF((IHD.L_LNKFLAGS.AND.1).NE.0)THEN S_TMP='LNKDEBUG' LN=9 ENDIF IF((IHD.L_LNKFLAGS.AND.2).NE.0)THEN S_TMP(LN+1:)='LNKNOTFR' LN=LN+10 ENDIF IF((IHD.L_LNKFLAGS.AND.4).NE.0)THEN S_TMP(LN+1:)='NOP0BUFS' LN=LN+10 ENDIF IF((IHD.L_LNKFLAGS.AND.8).NE.0)THEN S_TMP(LN+1:)='PICIMG' LN=LN+8 ENDIF IF((IHD.L_LNKFLAGS.AND.'10'X).NE.0)THEN S_TMP(LN+1:)='P0IMAGE' LN=LN+9 ENDIF IF((IHD.L_LNKFLAGS.AND.'20'X).NE.0)THEN S_TMP(LN+1:)='DBGDMT (V4+)' LN=LN+14 ENDIF IF((IHD.L_LNKFLAGS.AND.'40'X).NE.0)THEN S_TMP(LN+1:)='INISHR' LN=LN+8 ENDIF WRITE(2,9017) S_TMP(1:LN), IHD.W_IOCHANCNT, IHD.W_IMGIOCNT 9017 FORMAT('; linker flags: ',A/ + '; I/O channel count =',I4,', image I/O count =',I4) IF(IHD.L_SYSVER .NE.0)THEN WRITE(2,9021) IHD.L_SYSVER 9021 FORMAT('; system version: ',A4) ENDIF WRITE(2,9006) IHD.Q_PRIVREQS(2), IHD.Q_PRIVREQS(1) 9006 FORMAT('; requested privilege mask = ',Z8,' ',Z8) WRITE(2,9002) S_TMP='; uses shareable images' LN=24 DO I=1,ISD_NUM IF((ISD(I).L_FLAGS .AND.1).NE.0)THEN ! ISD$M_GBL LN2=ISD(I).B_GBLNAMLEN IF(ISD(I).T_GBLNAM(LN2-3:LN2).EQ.'_001')THEN LN2=LN2-4 ENDIF IF(ISD(I).T_GBLNAM(LN2-3:LN2-1).NE.'_00')THEN S_TMP(LN+1:)=' '//ISD(I).T_GBLNAM(1:LN2) LN=LN+LN2+1 ENDIF ENDIF ENDDO IF(LN.GT.24)THEN WRITE(2,'(A)') S_TMP(1:LN) ENDIF IF(IHD.W_PATCHOFF.EQ.0)THEN WRITE(2,9007) 9007 FORMAT('; no patches made to this image') ELSE S_TMP='; image has been patched to ECO levels ' LN=40 DO I=0,127 ICODE=LIB$FFS(I,1,IHP.L_ECO1,J) ! test next bit in ECO mask IF(ICODE)THEN CALL SYS$FAO('!UL,',LN2,S_TMP(LN+1:),%VAL(I+1)) LN=LN+LN2 IF(LN.GT.72)THEN WRITE(2,'(A)') S_TMP(1:LN) S_TMP=';' LN=40 ENDIF ENDIF ENDDO IF(LN.GT.41)THEN LN=LN-1 WRITE(2,'(A)') S_TMP(1:LN) ENDIF CALL SYS$ASCTIM(,S_TMP,IHP.Q_PATDATE,) WRITE(2,9009)S_TMP(1:23) 9009 FORMAT('; date of last patch is ',A23) WRITE(2,9016) IHP.L_RW_PATSIZ, IHP.L_RW_PATADR, + IHP.L_RO_PATSIZ, IHP.L_PATADR 9016 FORMAT('; read/write patch area has length',I5,', address',Z9.8/ + '; read-only patch area has length',I5,', address',Z9.8) WRITE(2,9010) 9010 FORMAT('; PATCH journal text for patches starts next page:') WRITE(2,9002) WRITE(2,9012)form_feed,TAB,TAB 9012 FORMAT(A1/ + A1,'.SBTTL',A1,'Image Patch Journals') WRITE(2,9002) WRITE(2,9013) 9013 FORMAT('; PATCH journal text:') WRITE(2,9002) CALL LIB$ESTABLISH(FIX_BUF_1) I=0 CUR_VBN=IHP.L_PATCOMTXT OK=.TRUE. READ(1,REC=CUR_VBN) REC_BUF DO WHILE (OK) CALL COPY_WORD(I,K) ! get length of text I=I+2 IF(K.NE.0.AND.(CUR_VBN+1.LT.INP_FIL_SIZ.OR.K+I.LT.512))THEN DO J=1,K CALL COPY_BYTE(I,I2) ! read in line S_TMP(J:J)=CHAR(I2) I=I+1 ENDDO WRITE(2,9015)TAB,S_TMP(1:K) 9015 FORMAT(';',A1,A) IF(MOD(I,2).NE.0)I=I+1 ELSE OK=.FALSE. ENDIF ENDDO CALL LIB$REVERT ENDIF C C put initial entry(s) into symbol table C SYM_TBL_PTR=0 MOD_TBL_PTR=0 OLD_MODTB_PTR=0 LIN_TBL_PTR=0 OLD_LINTB_PTR=1 J=0 DO I=1,3 IF(IHA.L_TFRADR(I).NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=IHA.L_TFRADR(I) SYM_TYP(SYM_TBL_PTR)=SYM_PROC IF(IHA.L_TFRADR(I).GE.0)THEN J=J+1 IF((IHD.L_LNKFLAGS.AND.2).EQ.0)THEN S_TMP='$MAIN' LN=5 ELSE S_TMP='$ENTRY' LN=6 ENDIF IF(J.NE.1)THEN S_TMP(LN+1:)='_'//CHAR(J+ICHAR('0')) LN=LN+2 ENDIF IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN ! VMS V3- linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN) + //S_TMP(1:LN) ELSE ! VMS V4+ linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)// + S_TMP(1:LN) ENDIF ENDIF ENDIF ENDDO C C IF no transfer addresses found THEN C IF(SYM_TBL_PTR.EQ.0)THEN C C test if we have a device driver image C IF(ISD(1).L_VBN .NE.0)THEN CUR_VBN=ISD(1).L_VBN CUR_VA=(ISD_BASEVA(1).AND..NOT.'1FF'X) READ(1,REC=ISD(1).L_VBN) REC_BUF CALL LIB$ESTABLISH(FIX_BUFR_OVRFL) IF(REC_BUF(10).EQ.%LOC(DYN$C_DPT))THEN CALL LIB$PUT_OUTPUT('Assuming a device driver image...') CALL LIB$MOVC3(DPT$S_SIZE,REC_BUF(0),DPT) WRITE(2,9020) form_feed, TAB, TAB, TAB, TAB, TAB, TAB, TAB, + TAB, TAB, TAB, TAB, TAB, TAB, TAB 9020 FORMAT(A1/ + A1,'.SBTTL',A1,'External symbol definitions'/ + ';'/ + '; External symbols'/ + ';'/ + A1,'.LIBRARY',A1,'/SYS$LIBRARY:LIB/'/ + A1,'$CRBDEF ; Channel request block'/ + A1,'$DCDEF ; Device classes and types'/ + A1,'$DDBDEF ; Device data block'/ + A1,'$DYNDEF ; Dynamic-data-structure types'/ + A1,'$IDBDEF ; Interrupt data block'/ + A1,'$IRPDEF ; I/O request packet'/ + A1,'$IODEF ; I/O function codes'/ + A1,'$SSDEF ; system condition codes'/ + A1,'$UCBDEF ; Unit control block'/ + A1,'$VECDEF ; Interrupt vector block') SYM_VAL(1)=0 ! end of device driver SYM_TYP(1)=SYM_D_DPT+SYM_NOTDEF SYM_NAM(1)='DPT$TAB' SYM_VAL(2)=DPT.W_SIZE ! end of device driver SYM_TYP(2)=SYM_D_QUD SYM_NAM(2)=DPT.T_NAME(1:2)//'$END_OF_DRIVER' SYM_VAL(3)=DPT.W_INITTAB ! initialization table SYM_TYP(3)=SYM_D_INITAB+SYM_NOTDEF SYM_NAM(3)='DPT$INITAB' SYM_VAL(4)=DPT.W_REINITTAB ! reinitialization table SYM_TYP(4)=SYM_D_REINITAB+SYM_NOTDEF SYM_NAM(4)='DPT$REINITAB' SYM_TBL_PTR=4 IF(DPT.W_UNLOAD .NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(4)=DPT.W_UNLOAD ! unload routine SYM_TYP(4)=SYM_SUBR SYM_NAM(4)=DPT.T_NAME(1:2)//'$UNLOAD' ENDIF IF(DPT.W_DELIVER .NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DPT.W_DELIVER ! deliver routine SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$DELIVER' ENDIF IF(DPT.W_VECTOR .NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DPT.W_VECTOR ! driver vector SYM_TYP(SYM_TBL_PTR)=SYM_D_LNG SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$VECTOR' ENDIF ADDR=DPT.W_INITTAB CALL LIB$MOVC3(DPT_STORE$S_SIZE,REC_BUF(ADDR),DPT_STORE) DO WHILE (DPT_STORE.B_STRUCTYPE .NE.0) IF(DPT_STORE.B_OPERATION .EQ.0)THEN ! B ADDR=ADDR+4 ELSEIF(DPT_STORE.B_OPERATION .EQ.1.OR. + DPT_STORE.B_OPERATION .EQ.2)THEN ! W, D ADDR=ADDR+5 ELSEIF((DPT_STORE.B_OPERATION .AND.'7F'X).EQ.4)THEN ! V ADDR=ADDR+9 ELSEIF(DPT_STORE.B_OPERATION .EQ.3.OR. + (DPT_STORE.B_OPERATION .AND.'80'X).NE.0)THEN ! L, @ ADDR=ADDR+7 ELSE CALL LIB$SIGNAL(DISM__INVINITAB,%VAL(2),%VAL(ADDR), + %VAL(DPT_STORE.B_OPERATION)) ENDIF IF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_DDB).AND. + DPT_STORE.B_STRUCOFFSET .EQ.12.AND. + DPT_STORE.B_OPERATION .EQ.2)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL ! DDT address SYM_TYP(SYM_TBL_PTR)=SYM_D_DDT+SYM_NOTDEF SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$DDT' CALL LIB$MOVC3(DDT$S_SIZE,REC_BUF(DPT_STORE.W_WORDVAL),DDT) DDT_ADR=DPT_STORE.W_WORDVAL ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND. + DPT_STORE.B_STRUCOFFSET .EQ.'28'X.AND. + DPT_STORE.B_OPERATION .EQ.2)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL ! int svc address SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$INTR_SVC' ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND. + DPT_STORE.B_STRUCOFFSET .EQ.'30'X.AND. + DPT_STORE.B_OPERATION .EQ.2)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL ! ctrlinit address SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$CTRLINIT' ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND. + DPT_STORE.B_STRUCOFFSET .EQ.'3C'X.AND. + DPT_STORE.B_OPERATION .EQ.2)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL ! unitinit address SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$UNITINIT' ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND. + DPT_STORE.B_STRUCOFFSET .EQ.'4C'X.AND. + DPT_STORE.B_OPERATION .EQ.2)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL ! int svc #2 address SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$INTR_SVC_2' ELSEIF(DPT_STORE.B_OPERATION .EQ.2)THEN CALL WRITE_SYM_TBL(%VAL(DPT_STORE.W_WORDVAL),%VAL(SYM_SUBR),,) ELSEIF((DPT_STORE.B_OPERATION .AND.'80'X).NE.0)THEN I3=(DPT_STORE.B_OPERATION .AND.'7F'X) IF(I3.EQ.3)I3=2 IF(I3.LE.3)THEN CALL WRITE_SYM_TBL(%VAL(DPT_STORE.L_LONGVAL), + %VAL(JISHFT(1,3+I3)),,) ! SYM_D_BYT+ ENDIF ENDIF CALL LIB$MOVC3(DPT_STORE$S_SIZE,REC_BUF(ADDR),DPT_STORE) ENDDO IF(DDT_ADR.NE.0)THEN IF(DDT.L_START .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_START+DDT_ADR ! start I/O routine SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$START' ENDIF IF(DDT.L_UNSOLINT .GT.0)THEN SYM_VAL(SYM_TBL_PTR)=DDT.L_UNSOLINT+DDT_ADR ! unsolicited int svc SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$UNSOLINT' SYM_TBL_PTR=SYM_TBL_PTR+1 ENDIF IF(DDT.L_FDT .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_FDT+DDT_ADR ! FDT table SYM_TYP(SYM_TBL_PTR)=SYM_D_FDT SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$FDT' ENDIF IF(DDT.L_CANCEL .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_CANCEL+DDT_ADR ! cancel I/O routine SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$CANCEL' ENDIF IF(DDT.L_REGDUMP .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_REGDUMP+DDT_ADR ! register dump routine SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$REGDUMP' ENDIF IF(DDT.L_UNITINIT .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_UNITINIT+DDT_ADR ! unit init routine SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$UNITINIT' ENDIF IF(DDT.L_ALTSTART .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_ALTSTART+DDT_ADR ! alt start I/O routine SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$ALTSTART' ENDIF IF(DDT.L_CLONEDUCB .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_CLONEDUCB+DDT_ADR ! cloned UCB routine SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$CLONEDUCB' ENDIF IF(DDT.L_FDT .GE.48)THEN IF(DDT.L_MNTV_SSSC .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_MNTV_SSSC+DDT_ADR ! mntver SSSC SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$MNTV_SSSC' ENDIF ENDIF IF(DDT.L_FDT .GE.52)THEN IF(DDT.L_MNTV_FOR .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_MNTV_FOR+DDT_ADR ! mntver foreign SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$MNTV_FOR' ENDIF ENDIF IF(DDT.L_FDT .GE.56)THEN IF(DDT.L_MNTV_SQD .GT.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=DDT.L_MNTV_SQD+DDT_ADR ! mntver sequential SYM_TYP(SYM_TBL_PTR)=SYM_SUBR SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$MNTV_SQD' ENDIF ENDIF I2=DDT.W_FDTSIZE-16 I9=0 ADDR=DDT.L_FDT+DDT_ADR+16 DO WHILE (I2.GT.0) CALL COPY_LONG(ADDR,I_FLT(1)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I_FLT(2)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I3) ADDR=ADDR+4 I9=I9+1 I2=I2-12 SYM_TBL_PTR=SYM_TBL_PTR+1 IF(I3.GT.0)THEN SYM_VAL(SYM_TBL_PTR)=I3+ADDR-12 ! relative to base of block ELSE SYM_VAL(SYM_TBL_PTR)=I3 ENDIF SYM_TYP(SYM_TBL_PTR)=SYM_SUBR CALL BUILD_IO_LIST(I_FLT,S_TMP,LN,LN2) I3=INDEX(S_TMP(1:LN),',') IF(I3.EQ.0)I3=LN IF(LN2.EQ.1)THEN CALL SYS$FAO('!AS$FDT_!AS',LN,SYM_NAM(SYM_TBL_PTR), + DPT.T_NAME(1:2),S_TMP(2:I3-1)) ELSE CALL SYS$FAO('!AS$FDT_!AS_!UW',LN,SYM_NAM(SYM_TBL_PTR), + DPT.T_NAME(1:2),S_TMP(2:I3-1),%VAL(LN2)) ENDIF SYM_NAM(SYM_TBL_PTR)(LN+1:)=' ' ENDDO ENDIF ENDIF ENDIF C ENDIF C C scan for and process any change-mode vector sections in image C DO I=1,ISD_NUM IF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)THEN ! ISD$M_VECTOR READ(1,REC=ISD(I).L_VBN) REC_BUF CALL LIB$MOVC3(32,REC_BUF(0),PLV) IF(PLV.L_TYPE .EQ.1)THEN ! PLV$C_TYP_CMOD IF(PLV.L_KERNEL .NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=PLV.L_KERNEL+8+ISD_BASEVA(I) SYM_TYP(SYM_TBL_PTR)=SYM_SUBR IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN ! VMS V3- linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN) + //'$CHMK_DISPATCHER' ELSE ! VMS V4+ linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)// + '$CHMK_DISPATCHER' ENDIF ENDIF IF(PLV.L_EXEC .NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=PLV.L_EXEC+12+ISD_BASEVA(I) SYM_TYP(SYM_TBL_PTR)=SYM_SUBR IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN ! VMS V3- linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN) + //'$CHME_DISPATCHER' ELSE ! VMS V4+ linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)// + '$CHME_DISPATCHER' ENDIF ENDIF IF(PLV.L_USRUNDWN .NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=PLV.L_USRUNDWN+16+ISD_BASEVA(I) SYM_TYP(SYM_TBL_PTR)=SYM_SUBR IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN ! VMS V3- linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN) + //'$USER_RUNDOWN' ELSE ! VMS V4+ linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)// + '$USER_RUNDOWN' ENDIF ENDIF IF(PLV.L_RMS .NE.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(SYM_TBL_PTR)=PLV.L_RMS+24+ISD_BASEVA(I) SYM_TYP(SYM_TBL_PTR)=SYM_SUBR IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN ! VMS V3- linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN) + //'$RMS_DISPATCHER' ELSE ! VMS V4+ linker SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)// + '$RMS_DISPATCHER' ENDIF ENDIF ENDIF ENDIF ENDDO C C if file filename.SYM exists, open it as a file and read it for C user symbol declarations C C Format of user declarations: C if it works, C columns 1-8 Z8 value of symbol C 10-17 Z8 type code C 19-22 I4 extended type C 24-31 Z8 extended value C 33-63 A31 name of symbol C else just use (old format) C columns 1-8 Z8 value of symbol C 10-17 Z8 type code C 19-49 A31 name of symbol C end-of-file marks end of list C INQUIRE(UNIT=1,NAME=OUT_FIL) CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) I=INDEX(OUT_FIL(1:LN),']') I=I+1 J=INDEX(OUT_FIL(I:LN),'.')+I-2 OPEN(UNIT=3,FILE=OUT_FIL(I:J),READONLY, + FORM='FORMATTED',RECORDTYPE='VARIABLE',STATUS='OLD', + IOSTAT=ICODE,DEFAULTFILE='.SYM',SHARED,ACCESS='SEQUENTIAL') IF(ICODE.EQ.0)THEN OK=.TRUE. DO WHILE (OK) READ(3,'(Q,A)',END=1940) LN2,S_TMP READ(S_TMP(1:LN2),9190,ERR=1930)I,I2,LN,I9,ROUTINE_NAME 9190 FORMAT(BZ,2(Z8,X),I4,X,Z8,X,A) GOTO 1931 1930 READ(S_TMP(1:LN2),9191)I,I2,ROUTINE_NAME 9191 FORMAT(BZ,2(Z8,X),A) LN=0 I9=0 1931 IF((I2.AND.SYM_NOTDEF).NE.0.AND. + (I2.AND.SYM_D_EXTENDED).EQ.0) ROUTINE_NAME=' ' DO J=1,SYM_TBL_PTR IF(SYM_VAL(J).EQ.I)THEN SYM_NAM(J)=ROUTINE_NAME SYM_TYP(J)=SYM_TYP(J).OR.I2 IF((I2.AND.SYM_D_EXTENDED).NE.0.AND. + LN.GT.SYM_EXT_ATTR(J))THEN SYM_EXT_ATTR(J)=LN SYM_EXT_VAL(J)=I9 ENDIF GOTO 1950 ENDIF ENDDO SYM_TBL_PTR=SYM_TBL_PTR+1 IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__SYMTBLOVF) ELSE SYM_VAL(SYM_TBL_PTR)=I SYM_TYP(SYM_TBL_PTR)=I2 SYM_NAM(SYM_TBL_PTR)=ROUTINE_NAME SYM_EXT_ATTR(SYM_TBL_PTR)=LN SYM_EXT_VAL(SYM_TBL_PTR)=I9 ENDIF GOTO 1950 1940 OK=.FALSE. 1950 CONTINUE ENDDO CLOSE(UNIT=3) ELSEIF(ICODE.NE.29)THEN ! it's OK if file not found error occurs CALL LIB$SIGNAL(DISM__BADUSRSFL,%VAL(2),%VAL(ICODE), + %DESCR(IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)//'.SYM')) ENDIF C C read in global symbol table records (if any), and assign names to C corresponding entries in symbol table C CALL LIB$ESTABLISH(FIX_BUF_1) IF(IHS.W_GSTRECS .GT.0)THEN CUR_VBN=IHS.L_GSTVBN CUR_VA=0 READ(1,REC=CUR_VBN) REC_BUF ! get 1st block of global symbol table INQUIRE(UNIT=1,NAME=OUT_FIL) CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) I=INDEX(OUT_FIL(1:LN),']') I=I+1 J=INDEX(OUT_FIL(I:LN),'.')+I-2 OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW', + FORM='UNFORMATTED',DEFAULTFILE='.GST',RECORDTYPE='VARIABLE') CALL NAME_SYM_TBL(-JZEXT(IHS.W_GSTRECS),0,0) ! fill in names into symbol, ISD tables CLOSE(UNIT=99) ENDIF C C read debug symbol table blocks (if any), and assign names to C corresponding entries in symbol table C IF(IHS.W_DSTBLKS .GT.0)THEN INQUIRE(UNIT=1,NAME=OUT_FIL) CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) I=INDEX(OUT_FIL(1:LN),']') I=I+1 J=INDEX(OUT_FIL(I:LN),'.')+I-2 OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW', + FORM='FORMATTED',CARRIAGECONTROL='LIST',BLOCKSIZE=16384, + DEFAULTFILE='.DST',INITIALSIZE=10*IHS.W_DSTBLKS) CUR_VBN=IHS.L_DSTVBN CUR_VA=0 ROUTINE_NAME=' ' LN2=0 DBG_RECS=0 READ(1,REC=CUR_VBN) REC_BUF ! get 1st block of debug symbol table WRITE(2,9800) 9800 FORMAT(';'/ + '; DEBUG Symbol Table analysis:') ADDR=0 K=1 DO WHILE (K.NE.0) CALL COPY_BYTE(ADDR,K) ADDR=ADDR+1 IF(K.NE.0)THEN J=ADDR I=0 CALL COPY_BYTE(J,I) J=J+1 IF(I.EQ.'BE'X)THEN ! DST$K_RTNBEG routine begin CALL COPY_BYTE(J,I3) ! MSB of byte set if JSB interface J=J+1 CALL COPY_LONG(J,I2) ! address of routine J=J+4 CALL COPY_STR(J,ROUTINE_NAME,LN2) ! name of routine IF(MOD_START(MOD_TBL_PTR).EQ.-1)THEN ! if first routine in module, MOD_START(MOD_TBL_PTR)=I2 ! save its start address ENDIF MOD_END(MOD_TBL_PTR)=I2 ! save initial end address WRITE(99,9801) I3, I2, ROUTINE_NAME(1:LN2) 9801 FORMAT('; DST$K_RTNBEG: msk=',Z2.2,' adr=',Z8.8, + ' name=',A) DO I=1,SYM_TBL_PTR IF(SYM_VAL(I).EQ.I2)THEN SYM_NAM(I)=ROUTINE_NAME(1:LN2) GOTO 1970 ENDIF ENDDO IF((I3.AND.'80'X).EQ.0)THEN CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_PROC),,) ELSE CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_SUBR),,) ENDIF SYM_NAM(SYM_TBL_PTR)=ROUTINE_NAME(1:LN2) ELSEIF(I.EQ.'BF'X)THEN ! DST$K_RTNEND J=J+1 CALL COPY_LONG(J,I2) WRITE(99,9802) I2 9802 FORMAT('; DST$K_RTNEND:',I5,' bytes in routine') ROUTINE_NAME=' ' LN2=0 MOD_END(MOD_TBL_PTR)=MOD_END(MOD_TBL_PTR)+I2-1 ELSEIF(I.EQ.'B0'X)THEN ! DST$K_BLKBEG block begin J=J+1 CALL COPY_LONG(J,I2) ! address of block J=J+4 CALL COPY_STR(J,BLOCK_NAME,LN3) ! name of block WRITE(99,9803) I2, BLOCK_NAME(1:LN3) 9803 FORMAT('; DST$K_BLKBEG: adr=',Z8.8,' name=',A) IF(LN3.NE.0)THEN ! only if block named DO I=1,SYM_TBL_PTR IF(SYM_VAL(I).EQ.I2)THEN SYM_NAM(I)=BLOCK_NAME(1:LN3) GOTO 1970 ENDIF ENDDO CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,) SYM_NAM(SYM_TBL_PTR)=BLOCK_NAME(1:LN3) ENDIF ELSEIF(I.EQ.'B1'X)THEN ! DST$K_BLKEND J=J+1 CALL COPY_LONG(J,I2) WRITE(99,9804) I2 9804 FORMAT('; DST$K_BLKEND:',I5,' bytes in block') BLOCK_NAME=' ' LN2=0 ELSEIF(I.EQ.'BA'X)THEN ! DST$K_LBLORLIT CALL COPY_BYTE(J,I3) ! bottom two bits are value kind J=J+1 CALL COPY_LONG(J,I2) ! value of label/literal J=J+4 CALL COPY_STR(J,S_TMP,LN4) ! name of label/literal I3=I3.AND.3 ! extract only VALKIND field WRITE(99,9805) I3, I2, S_TMP(1:LN4) 9805 FORMAT('; DST$K_LBLORLIT: kind=',I1,' val=',Z8.8, + ' name=',A) IF(I3.EQ.1)THEN ! only if label is it put in symbol table DO I=1,SYM_TBL_PTR IF(SYM_VAL(I).EQ.I2)THEN SYM_NAM(I)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP GOTO 1970 ENDIF ENDDO CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,) SYM_NAM(SYM_TBL_PTR)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP ENDIF ELSEIF(I.EQ.'B8'X)THEN ! DST$K_PSECT J=J+1 CALL COPY_LONG(J,I2) J=J+4 CALL COPY_STR(J,S_TMP,LN4) J=J+1+LN4 CALL COPY_LONG(J,I3) WRITE(99,9806) I2, I3, S_TMP(1:LN4) 9806 FORMAT('; DST$K_PSECT: start adr=',Z8.8, + I8,' bytes, name=',A) CALL WRITE_PSECT_TBL(I2,S_TMP(1:LN4),-1,-1,I3) ELSEIF(I.EQ.'BB'X)THEN ! DST$K_LABEL J=J+1 CALL COPY_LONG(J,I2) J=J+4 CALL COPY_STR(J,S_TMP,LN4) WRITE(99,9807) I2, S_TMP(1:LN4) 9807 FORMAT('; DST$K_LABEL: val=',Z8.8,' name=',A) DO I=1,SYM_TBL_PTR IF(SYM_VAL(I).EQ.I2)THEN SYM_NAM(I)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP GOTO 1970 ENDIF ENDDO CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,) SYM_NAM(SYM_TBL_PTR)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP ELSEIF(I.EQ.'BC'X)THEN ! DST$K_MODBEG MOD_TBL_PTR=MOD_TBL_PTR+1 J=J+1 CALL COPY_LONG(J,I3) ! language type MOD_LNG(MOD_TBL_PTR)=I3 J=J+4 CALL COPY_STR(J,MOD_NAM(MOD_TBL_PTR),LN) WRITE(99,9808) MOD_NAM(MOD_TBL_PTR)(1:LN), LANGUAGE_NAME(I3) 9808 FORMAT('; DST$K_MODBEG: name=',A,' language=',A) MOD_START(MOD_TBL_PTR)=-1 MOD_VERMAJ(MOD_TBL_PTR)=0 MOD_VERMIN(MOD_TBL_PTR)=0 CURRENT_LINE=0 CURRENT_STMT=1 CURRENT_INCR=1 CURRENT_STMT_MODE=.FALSE. CURRENT_PC=-1 CURRENT_MARK=.FALSE. ELSEIF(I.EQ.'BD'X)THEN ! DST$K_MODEND WRITE(99,9809) 9809 FORMAT('; DST$K_MODEND') OLD_MODTB_PTR=MOD_TBL_PTR ELSEIF(I.EQ.'B5'X)THEN ! DST$K_ENTRY J=J+1 CALL COPY_LONG(J,I2) J=J+4 CALL COPY_STR(J,S_TMP,LN4) WRITE(99,9810) I2, S_TMP(1:LN4) 9810 FORMAT('; DST$K_ENTRY: val=',Z8.8,' name=',A) DO I=1,SYM_TBL_PTR IF(SYM_VAL(I).EQ.I2)THEN SYM_TYP(I)=SYM_TYP(I).OR.SYM_PROC SYM_NAM(I)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP GOTO 1970 ENDIF ENDDO CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_PROC),,) SYM_NAM(SYM_TBL_PTR)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP ELSEIF(I.EQ.'A2'X)THEN ! DST$K_PROLOG CALL COPY_LONG(J,I2) WRITE(99,9811) I2 9811 FORMAT('; DST$K_PROLOG: adr=',Z8.8) DO I=1,SYM_TBL_PTR IF(SYM_VAL(I).EQ.I2)THEN SYM_TYP(I)=SYM_TYP(I).OR.SYM_JMPE SYM_NAM(I)='PROLOG_'//ROUTINE_NAME(1:LN2) GOTO 1970 ENDIF ENDDO CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,) SYM_NAM(SYM_TBL_PTR)='PROLOG_'//ROUTINE_NAME(1:LN2) ELSEIF(I.EQ.'B9'X)THEN ! DST$K_LINE_NUM IF(CURRENT_PC.EQ.-1)THEN CURRENT_PC=MOD_START(MOD_TBL_PTR) ENDIF WRITE(99,9812) K, CURRENT_PC 9812 FORMAT('; DST$K_LINE_NUM: ln=',I3,' current PC=',Z8.8) DO WHILE (J.LT.ADDR+K) CALL COPY_BYTE(J,OK) J=J+1 IF(OK.GE.-128.AND.OK.LE.0)THEN ! delta PC IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=CURRENT_STMT+1 ELSE CURRENT_LINE=CURRENT_LINE+CURRENT_INCR ENDIF CURRENT_MARK=.TRUE. CURRENT_PC=CURRENT_PC-OK WRITE(99,9850) CURRENT_LINE, CURRENT_STMT, CURRENT_PC 9850 FORMAT(';',9X,'delta PC byte, line',I5,'.',I2.2, + ' PC=',Z8.8) LIN_TBL_PTR=LIN_TBL_PTR+1 IF(LIN_TBL_PTR.GT.LIN_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__LINTBLOVF) ENDIF LIN_ADR(LIN_TBL_PTR)=CURRENT_PC LIN_NUM(LIN_TBL_PTR)=CURRENT_LINE LIN_STMT(LIN_TBL_PTR)=CURRENT_STMT ELSEIF(OK.EQ.1)THEN ! DST$K_DELTA_PC_W IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=CURRENT_STMT+1 ELSE CURRENT_LINE=CURRENT_LINE+CURRENT_INCR ENDIF CURRENT_MARK=.TRUE. I2=0 CALL COPY_WORD(J,I2) J=J+2 CURRENT_PC=CURRENT_PC+I2 WRITE(99,9851) CURRENT_LINE, CURRENT_STMT, CURRENT_PC 9851 FORMAT(';',9X,'delta PC word, line',I5,'.',I2.2, + ' PC=',Z8.8) LIN_TBL_PTR=LIN_TBL_PTR+1 IF(LIN_TBL_PTR.GT.LIN_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__LINTBLOVF) ENDIF LIN_ADR(LIN_TBL_PTR)=CURRENT_PC LIN_NUM(LIN_TBL_PTR)=CURRENT_LINE LIN_STMT(LIN_TBL_PTR)=CURRENT_STMT ELSEIF(OK.EQ.2)THEN ! DST$K_INCR_LINUM I2=0 CALL COPY_BYTE(J,I2) J=J+1 CURRENT_LINE=CURRENT_LINE+I2 IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=1 ENDIF WRITE(99,9852) CURRENT_LINE, CURRENT_STMT 9852 FORMAT(';',9X,'incr linum byte, line',I5,'.',I2.2) ELSEIF(OK.EQ.3)THEN ! DST$K_INCR_LINUM_W I2=0 CALL COPY_WORD(J,I2) J=J+2 CURRENT_LINE=CURRENT_LINE+I2 IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=1 ENDIF WRITE(99,9853) CURRENT_LINE, CURRENT_STMT 9853 FORMAT(';',9X,'incr linum word, line',I5,'.',I2.2) ELSEIF(OK.EQ.4)THEN ! DST$K_SET_LINUM_INCR CURRENT_INCR=0 CALL COPY_BYTE(J,CURRENT_INCR) J=J+1 IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=1 ENDIF WRITE(99,9854) CURRENT_INCR 9854 FORMAT(';',9X,'set linum incr byte, incr=',I4) ELSEIF(OK.EQ.5)THEN ! DST$K_SET_LINUM_INCR_W CURRENT_INCR=0 CALL COPY_WORD(J,CURRENT_INCR) J=J+2 IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=1 ENDIF WRITE(99,9855) CURRENT_INCR 9855 FORMAT(';',9X,'set linum incr word, incr=',I4) ELSEIF(OK.EQ.6)THEN ! DST$K_RESET_LINUM_INCR CURRENT_INCR=1 IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=1 ENDIF WRITE(99,9856) 9856 FORMAT(';',9X,'reset linum incr') ELSEIF(OK.EQ.7)THEN ! DST$K_BEG_STMT_MODE CURRENT_STMT=1 CURRENT_STMT_MODE=.TRUE. WRITE(99,9857) 9857 FORMAT(';',9X,'begin stmt mode') IF(.NOT.CURRENT_MARK) WRITE(99,9872) 9872 FORMAT(';',14X,'*** invalid DST record - line currently closed') ELSEIF(OK.EQ.8)THEN ! DST$K_END_STMT_MODE CURRENT_STMT=1 CURRENT_STMT_MODE=.FALSE. WRITE(99,9858) 9858 FORMAT(';',9X,'end stmt mode') ELSEIF(OK.EQ.9)THEN ! DST$K_SET_LINUM CURRENT_LINE=0 CALL COPY_WORD(J,CURRENT_LINE) J=J+2 WRITE(99,9859) CURRENT_LINE 9859 FORMAT(';',9X,'set linum word, line',I5) ELSEIF(OK.EQ.10)THEN ! DST$K_SET_PC CURRENT_PC=0 CALL COPY_BYTE(J,CURRENT_PC) J=J+1 CURRENT_PC=MOD_START(MOD_TBL_PTR)+CURRENT_PC WRITE(99,9860) CURRENT_PC 9860 FORMAT(';',9X,'set PC byte, PC=',Z8.8) IF(.NOT.CURRENT_MARK) WRITE(99,9872) ELSEIF(OK.EQ.11)THEN ! DST$K_SET_PC_W CURRENT_PC=0 CALL COPY_WORD(J,CURRENT_PC) J=J+2 CURRENT_PC=MOD_START(MOD_TBL_PTR)+CURRENT_PC WRITE(99,9861) CURRENT_PC 9861 FORMAT(';',9X,'set PC word, PC=',Z8.8) IF(.NOT.CURRENT_MARK) WRITE(99,9872) ELSEIF(OK.EQ.12)THEN ! DST$K_SET_PC_L CALL COPY_LONG(J,CURRENT_PC) J=J+4 CURRENT_PC=MOD_START(MOD_TBL_PTR)+CURRENT_PC WRITE(99,9862) CURRENT_PC 9862 FORMAT(';',9X,'set PC longword, PC=',Z8.8) IF(.NOT.CURRENT_MARK) WRITE(99,9872) ELSEIF(OK.EQ.13)THEN ! DST$K_SET_STMTNUM CURRENT_STMT=0 CALL COPY_WORD(J,CURRENT_STMT) J=J+2 WRITE(99,9863) CURRENT_PC 9863 FORMAT(';',9X,'set stmtnum, stmt',I3.2) ELSEIF(OK.EQ.14)THEN ! DST$K_TERM I2=0 CALL COPY_BYTE(J,I2) J=J+1 CURRENT_PC=CURRENT_PC+I2 CURRENT_MARK=.FALSE. WRITE(99,9864) CURRENT_PC 9864 FORMAT(';',9X,'term byte, PC=',Z8.8) ELSEIF(OK.EQ.15)THEN ! DST$K_TERM_W I2=0 CALL COPY_WORD(J,I2) J=J+2 CURRENT_PC=CURRENT_PC+I2 CURRENT_MARK=.FALSE. WRITE(99,9865) CURRENT_PC 9865 FORMAT(';',9X,'term word, PC=',Z8.8) ELSEIF(OK.EQ.16)THEN ! DST$K_SET_ABS_PC CALL COPY_LONG(J,CURRENT_PC) J=J+4 WRITE(99,9866) CURRENT_PC 9866 FORMAT(';',9X,'set abs PC, PC=',Z8.8) IF(.NOT.CURRENT_MARK) WRITE(99,9872) ELSEIF(OK.EQ.17)THEN ! DST$K_DELTA_PC_L IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=CURRENT_STMT+1 ELSE CURRENT_LINE=CURRENT_LINE+CURRENT_INCR ENDIF CURRENT_MARK=.TRUE. CALL COPY_LONG(J,I2) J=J+4 CURRENT_PC=CURRENT_PC+I2 WRITE(99,9867) CURRENT_LINE, CURRENT_STMT, CURRENT_PC 9867 FORMAT(';',9X,'delta PC long, line', + I5,'.',I2.2,' PC=',Z8.8) LIN_TBL_PTR=LIN_TBL_PTR+1 IF(LIN_TBL_PTR.GT.LIN_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__LINTBLOVF) ENDIF LIN_ADR(LIN_TBL_PTR)=CURRENT_PC LIN_NUM(LIN_TBL_PTR)=CURRENT_LINE LIN_STMT(LIN_TBL_PTR)=CURRENT_STMT ELSEIF(OK.EQ.18)THEN ! DST$K_INCR_LINUM_L CALL COPY_LONG(J,I2) J=J+4 CURRENT_LINE=CURRENT_LINE+I2 IF(CURRENT_STMT_MODE)THEN CURRENT_STMT=1 ENDIF WRITE(99,9868) CURRENT_LINE, CURRENT_STMT 9868 FORMAT(';',9X,'incr linum long, line',I5,'.',I2.2) ELSEIF(OK.EQ.19)THEN ! DST$K_SET_LINUM_B CURRENT_LINE=0 CALL COPY_BYTE(J,CURRENT_LINE) J=J+1 WRITE(99,9869) CURRENT_LINE 9869 FORMAT(';',9X,'set linum byte, line',I5) ELSEIF(OK.EQ.20)THEN ! DST$K_SET_LINUM_L CALL COPY_LONG(J,CURRENT_LINE) J=J+4 WRITE(99,9870) CURRENT_LINE 9870 FORMAT(';',9X,'set linum long, line',I5) ELSEIF(OK.EQ.21)THEN ! DST$K_TERM_L CALL COPY_LONG(J,I2) J=J+4 CURRENT_PC=CURRENT_PC+I2 CURRENT_MARK=.FALSE. WRITE(99,9871) CURRENT_PC 9871 FORMAT(';',9X,'term long, PC=',Z8.8) ELSE WRITE(99,9873) OK 9873 FORMAT(';',9X,'unknown linum command code=',Z2.2) ENDIF ENDDO ELSEIF(I.EQ.'99'X)THEN ! DST$K_VERSION I2=0 CALL COPY_BYTE(J,I2) MOD_VERMAJ(MOD_TBL_PTR)=I2 I3=0 J=J+1 CALL COPY_BYTE(J,I3) MOD_VERMIN(MOD_TBL_PTR)=I2 WRITE(99,9813) I2, I3 9813 FORMAT('; DST$K_VERSION: V',I2.2,'.',I2.2) ELSEIF(I.GE.0.AND.I.LE.37)THEN WRITE(99,9897) K, I 9897 FORMAT('; DST$K_???: ln=',I3,' valid data type code=',I3, + ' unrecog. by DISM-32') ELSEIF(I.GE.'99'X.AND.I.LE.'BF'X)THEN WRITE(99,9898) K, I 9898 FORMAT('; DST$K_???: ln=',I3,' valid type code=',I3, + ' unrecog. by DISM-32') ELSE WRITE(99,9899) K, I 9899 FORMAT('; DST$K_??????: ln=',I3, + ' invalid type code=',I3) ENDIF 1970 ADDR=ADDR+K DBG_RECS=DBG_RECS+1 ENDIF ENDDO WRITE(99,9890) DBG_RECS WRITE(2,9890) DBG_RECS 9890 FORMAT('; ',I5,' DEBUG symbol table records extracted') CLOSE(UNIT=99) CALL SYS$FAOL('DST analyzed, !SW records found',LN, + OUT_FIL,DBG_RECS) CALL LIB$PUT_OUTPUT(OUT_FIL(1:LN)) ENDIF CALL LIB$REVERT C C begin pass 1 disassembly C CALL LIB$PUT_OUTPUT('Beginning pass 1...') CALL LIB$ESTABLISH(FIX_BUFR_OVRFL) 100 OK=.TRUE. DO WHILE (OK) C C search for an undisassembled code entry point C OLD_SMTB_PTR=SYM_TBL_PTR DO I=1,OLD_SMTB_PTR IF((SYM_TYP(I).AND.(SYM_M_CODE.AND..NOT.SYM_TRANSFER)).NE.0.AND. + (SYM_TYP(I).AND.SYM_DISM).EQ.0)THEN SYM_TYP(I)=SYM_TYP(I).OR.SYM_DISM C C a good symbol to disassemble from has been found, find what image C section it is in C DO J=1,ISD_NUM IF(ISD_BASEVA(J).LE.SYM_VAL(I).AND. + ISD_PGEND(J).GE.SYM_VAL(I))THEN ISD(J).W_SIZE=-IABS(ISD(J).W_SIZE) C C if symbol is in this image section, only disassemble it if in this C image file (as opposed to a shareable image linked to it) C IF(ISD(J).L_VBN .NE.0.AND. + (ISD(J).L_FLAGS .AND.1).EQ.0)THEN ! ISD$M_GBL CUR_VBN=ISD(J).L_VBN+INT((SYM_VAL(I)- + ISD_BASEVA(J))/512) CUR_VA=(SYM_VAL(I).AND..NOT.'1FF'X) READ(1,REC=CUR_VBN) REC_BUF ADDR=SYM_VAL(I) IF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN ADDR=ADDR+2 K=0 CALL COPY_WORD(ADDR,K) IF(K.EQ.'EFDE'X)THEN ! MOVAL L^xxxx,- K=0 CALL COPY_BYTE(ADDR+6,K) IF(K.EQ.'4B'X)THEN ! R11 CALL COPY_LONG(ADDR+2,K) K=K+ADDR+6 CALL WRITE_SYM_TBL(%VAL(K),%VAL(SYM_BASEADR),,) ENDIF ENDIF ENDIF C C disassemble until unconditional transfer instruction C K=1 DO WHILE (K.EQ.1) K=DISM_INSTR(ADDR,0) IF(K.EQ.%LOC(DISM__INVOPCODE))THEN CALL LIB$SIGNAL(%VAL(K),%VAL(1),%VAL(ADDR-1)) ENDIF ENDDO GOTO 1900 ENDIF ENDIF ENDDO ENDIF 1900 CONTINUE ENDDO C C test if all symbols have been processed, and exit if no new symbols C have been added to the symbol table C IF(OLD_SMTB_PTR.EQ.SYM_TBL_PTR)OK=.FALSE. ENDDO C C enlarge working set to maximum allowed by quotas C ICODE=SYS$ADJWSL(%VAL(1000),) IF(.NOT.ICODE)CALL LIB$SIGNAL(%VAL(ICODE)) CALL SYS$FAOL('Beginning symbol table analysis, !SL symbols...', + LN,OUT_FIL,SYM_TBL_PTR) CALL LIB$PUT_OUTPUT(OUT_FIL(1:LN)) C C pre-scan symbol table to analyze complex data structures C SYM_FOUND_NEW_CODE=.FALSE. CALL EXTENDED_DATA_SYMTBL IF(SYM_FOUND_NEW_CODE)THEN CALL LIB$PUT_OUTPUT('Found more code symbols, rerunning pass 1...') GOTO 100 ENDIF C C shell-sort the symbol table into ascending address order C I9=(2**INT(LOG(FLOAT(MAX(SYM_TBL_PTR,1)))/LOG(2.0))) - 1 DO WHILE (I9.GT.0) DO I=1,SYM_TBL_PTR-I9 IF(SYM_VAL(I).GT.SYM_VAL(I+I9))THEN I2=SYM_VAL(I+I9) I3=SYM_TYP(I+I9) ROUTINE_NAME=SYM_NAM(I+I9) LN=SYM_EXT_ATTR(I+I9) K=SYM_EXT_VAL(I+I9) SYM_VAL(I+I9)=SYM_VAL(I) SYM_TYP(I+I9)=SYM_TYP(I) SYM_NAM(I+I9)=SYM_NAM(I) SYM_EXT_ATTR(I+I9)=SYM_EXT_ATTR(I) SYM_EXT_VAL(I+I9)=SYM_EXT_VAL(I) IF(I.GT.I9)THEN J=I-I9 DO WHILE (J.GE.1.AND.I2.LT.SYM_VAL(J)) SYM_VAL(J+I9)=SYM_VAL(J) SYM_TYP(J+I9)=SYM_TYP(J) SYM_NAM(J+I9)=SYM_NAM(J) SYM_EXT_ATTR(J+I9)=SYM_EXT_ATTR(J) SYM_EXT_VAL(J+I9)=SYM_EXT_VAL(J) J=J-I9 ENDDO SYM_VAL(J+I9)=I2 SYM_TYP(J+I9)=I3 SYM_NAM(J+I9)=ROUTINE_NAME SYM_EXT_ATTR(J+I9)=LN SYM_EXT_VAL(J+I9)=K ELSE SYM_VAL(I)=I2 SYM_TYP(I)=I3 SYM_NAM(I)=ROUTINE_NAME SYM_EXT_ATTR(I)=LN SYM_EXT_VAL(I)=K ENDIF ENDIF ENDDO I9=I9/2 ENDDO C C open SYS$LIBRARY:STARLET.OLB to read some symbol definition modules C ICODE=LBR$INI_CONTROL(LIBRARY_INDEX,LBR$C_READ) IF(.NOT.ICODE)THEN CALL LIB$SIGNAL(%VAL(ICODE)) ENDIF ICODE=LBR$OPEN(LIBRARY_INDEX,'SYS$LIBRARY:STARLET.OLB') IF(.NOT.ICODE)THEN CALL LIB$SIGNAL(%VAL(ICODE)) ENDIF C C read in and analyze the SYS$P1_VECTORS module to resolve more symbols C ICODE=LBR$LOOKUP_KEY(LIBRARY_INDEX,'SYS$P1_VECTOR',I_FLT) IF(.NOT.ICODE)THEN CALL LIB$SIGNAL(%VAL(ICODE)) ELSE DO WHILE (ICODE) ICODE=LBR$GET_RECORD(LIBRARY_INDEX,S_TMP,I_FLT) REC_TYP=ICHAR(S_TMP(1:1)) REC_SUBTYP=ICHAR(S_TMP(2:2)) IF(ICODE)THEN ICODE=ANALYZE_SYM_REC(REC_TYP,REC_SUBTYP, + S_TMP(3:MAX(I_FLT(1),3)),-1,0) ICODE=ICODE.EQ.0 ENDIF ENDDO ENDIF C C read in and analyze the RMS$GLOBALS module to resolve more symbols C ICODE=LBR$LOOKUP_KEY(LIBRARY_INDEX,'RMS$GLOBALS',I_FLT) IF(.NOT.ICODE)THEN CALL LIB$SIGNAL(%VAL(ICODE)) ELSE DO WHILE (ICODE) ICODE=LBR$GET_RECORD(LIBRARY_INDEX,S_TMP,I_FLT) REC_TYP=ICHAR(S_TMP(1:1)) REC_SUBTYP=ICHAR(S_TMP(2:2)) IF(ICODE)THEN ICODE=ANALYZE_SYM_REC(REC_TYP,REC_SUBTYP, + S_TMP(3:MAX(I_FLT(1),3)),-1,0) ICODE=ICODE.EQ.0 ENDIF ENDDO ENDIF C C close the system object library file C ICODE=LBR$CLOSE(LIBRARY_INDEX) IF(.NOT.ICODE)THEN CALL LIB$SIGNAL(%VAL(ICODE)) ENDIF C C read in and analyze SYS$SYSTEM:SYS.STB to resolve more symbols C OPEN(UNIT=3,FILE='SYS$SYSTEM:SYS.STB',ACCESS='SEQUENTIAL', + READONLY,FORM='FORMATTED',ORGANIZATION='SEQUENTIAL', + RECORDTYPE='VARIABLE',STATUS='OLD',IOSTAT=ICODE,SHARED) IF(ICODE.NE.0)THEN CALL LIB$SIGNAL(DISM__BADSYSSTB,%VAL(1),%VAL(ICODE)) ELSE DO WHILE (ICODE.EQ.0) READ(3,9100,IOSTAT=ICODE) REC_TYP,REC_SUBTYP,LN,S_TMP 9100 FORMAT(A1,A1,Q,A) IF(ICODE.EQ.0)THEN ICODE=ANALYZE_SYM_REC(REC_TYP,REC_SUBTYP,S_TMP(1:MAX(LN,1)),-1,0) ENDIF ENDDO CLOSE(UNIT=3) ENDIF C C assign names to ISD's that haven't had names assigned to them yet (so C they can be used as PSECT names) C MSG_NUMFAC=0 DO I=1,ISD_NUM IF(ISD_NAM(I).EQ.' ')THEN IF(JISHFT(ISD(I).L_FLAGS,-24).EQ.-3.OR. + JISHFT(ISD(I).L_FLAGS,-24).EQ.253)THEN ISD_NAM(I)='$USRSTACK' ELSEIF((ISD(I).L_FLAGS .AND.1).NE.0)THEN ! if shareable image section ISD_NAM(I)=ISD(I).T_GBLNAM(1:ISD(I).B_GBLNAMLEN)//'_SEC' ELSEIF((ISD(I).L_FLAGS .AND.'400'X).NE.0)THEN ! ISD$M_FIXUPVEC CALL SYS$FAO('$FIXUPSEC_!UL',,ISD_NAM(I),%VAL(I)) FIXUPSEC_ISD=I ELSEIF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)THEN ! ISD$M_VECTOR CUR_VBN=ISD(I).L_VBN READ(1,REC=CUR_VBN) REC_BUF CUR_VA=ISD_BASEVA(I) CALL LIB$MOVC3(32,REC_BUF(0),PLV) ! get privileged vector block IF(PLV.L_TYPE .EQ.1)THEN ! change mode vector, privileged CALL SYS$FAO('$PLVECT_!UL',,ISD_NAM(I),%VAL(I)) ELSEIF(PLV.L_TYPE .EQ.2)THEN ! message vector CALL SYS$FAO('$MSGVEC_!UL',,ISD_NAM(I),%VAL(I)) AUX_SYM_TBL(-1)=0 ADDR=ISD_BASEVA(I)+16 AUX_SYM_TBL(0)=-1 DO WHILE (AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0) AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)+1 CALL COPY_LONG(ADDR,AUX_SYM_TBL(AUX_SYM_TBL(-1))) ! get offset IF(AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0)THEN AUX_SYM_TBL(AUX_SYM_TBL(-1))=AUX_SYM_TBL(AUX_SYM_TBL(-1))+ADDR ENDIF ADDR=ADDR+4 ENDDO AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)-1 DO I2=1,AUX_SYM_TBL(-1) ADDR=AUX_SYM_TBL(I2) CALL COPY_WORD(ADDR,LN) ! get message section type ADDR=ADDR+4 CALL COPY_LONG(ADDR,I3) ! get section length ADDR=ADDR+4 IF(LN.EQ.0)THEN ! if actual definitions here MSG_NUMFAC=MSG_NUMFAC+1 MSG_FACDESCR(0,MSG_NUMFAC)=AUX_SYM_TBL(I2) CALL COPY_LONG(ADDR,MSG_FACDESCR(1,MSG_NUMFAC)) ! get offset to vector index MSG_FACDESCR(1,MSG_NUMFAC)=MSG_FACDESCR(1,MSG_NUMFAC) + +AUX_SYM_TBL(I2) ADDR=ADDR+4 CALL COPY_LONG(ADDR,MSG_FACDESCR(2,MSG_NUMFAC)) ! get offset to facility name MSG_FACDESCR(2,MSG_NUMFAC)=MSG_FACDESCR(2,MSG_NUMFAC) + +AUX_SYM_TBL(I2) ADDR=ADDR+4 CALL COPY_LONG(ADDR,MSG_FACDESCR(3,MSG_NUMFAC)) ! get offset to string area MSG_FACDESCR(3,MSG_NUMFAC)=MSG_FACDESCR(3,MSG_NUMFAC) + +AUX_SYM_TBL(I2) CALL COPY_WORD(MSG_FACDESCR(3,MSG_NUMFAC),LN2) DO K=1,LN2 CALL COPY_BYTE(MSG_FACDESCR(3,MSG_NUMFAC)+1+K, + %REF(FACILITY_BUF(K:K))) ENDDO MSG_FACDESCR(4,MSG_NUMFAC)=FACILITY_NUMBER ENDIF ENDDO ELSE CALL SYS$FAO('$UNKN_VEC_!UL',,ISD_NAM(I),%VAL(I)) ENDIF ELSEIF((ISD(I).L_FLAGS .AND.8).NE.0.AND. ! ISD$M_WRT + ISD(I).W_SIZE .LT.0)THEN CALL SYS$FAO('$IMPURE_!UL',,ISD_NAM(I),%VAL(I)) ELSEIF(ISD(I).W_SIZE .LT.0)THEN CALL SYS$FAO('$CODE_!UL',,ISD_NAM(I),%VAL(I)) ELSEIF((ISD(I).L_FLAGS.AND.8).NE.0)THEN ! ISD$M_WRT CALL SYS$FAO('$LOCAL_!UL',,ISD_NAM(I),%VAL(I)) ELSE CALL SYS$FAO('$PDATA_!UL',,ISD_NAM(I),%VAL(I)) ENDIF ENDIF ENDDO C C if a fixup section is defined then C IF(FIXUPSEC_ISD.NE.0)THEN C C do fixup section analysis C DO I=0,ISD(FIXUPSEC_ISD).W_PAGCNT-1 READ (1,REC=ISD(FIXUPSEC_ISD).L_VBN+I) + (HDR_BUF(J),J=I*512,(I+1)*512-1) ENDDO CALL LIB$MOVC3(IAF$S_SIZE,HDR_BUF(0),IAF) IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN J=SHL$S_SIZE ELSE J=SHL$S_SIZE_V3 ENDIF DO K=1,IAF.L_SHRIMGCNT CALL LIB$MOVC3(J, + HDR_BUF(IAF.L_SHLSTOFF+(K-1)*J), + FIX_SHL(K-1)) ENDDO FIX_SHL(0).T_IMGNAM='this image' FIX_SHL(0).B_IMGNAMLEN=10 DO K=1,SYM_TBL_PTR IF(SYM_VAL(K).GE.ISD_BASEVA(FIXUPSEC_ISD).AND. + SYM_VAL(K).LE.ISD_PGEND(FIXUPSEC_ISD).AND. + (SYM_TYP(K).AND.SYM_D_LNG).NE.0)THEN SYM_TYP(K)=SYM_TYP(K).OR.SYM_G_FIXUP ENDIF ENDDO J=IAF.L_G_FIXOFF I9=1 DO WHILE (HDR_BUF(J).NE.0.AND.J.NE.0) CALL LIB$MOVC3(8,HDR_BUF(J),OFFSET_VEC(0)) DO I8=1,OFFSET_VEC(0) DO WHILE (I9.LE.SYM_TBL_PTR.AND. + SYM_VAL(I9).LT.J+4+ISD_BASEVA(FIXUPSEC_ISD)+4*I8) I9=I9+1 ENDDO IF(SYM_VAL(I9).GT.J+4+ISD_BASEVA(FIXUPSEC_ISD)+4*I8)THEN IF(SYM_TBL_PTR+1.GT.SYM_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__SYMTBLOVF) ENDIF DO I2=SYM_TBL_PTR,I9,-1 SYM_VAL(I2+1)=SYM_VAL(I2) SYM_TYP(I2+1)=SYM_TYP(I2) SYM_NAM(I2+1)=SYM_NAM(I2) SYM_EXT_ATTR(I2+1)=SYM_EXT_ATTR(I2) SYM_EXT_VAL(I2+1)=SYM_EXT_VAL(I2) ENDDO SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(I9)=J+4+ISD_BASEVA(FIXUPSEC_ISD)+4*I8 SYM_TYP(I9)=SYM_G_FIXUP+SYM_D_LNG SYM_NAM(I9)=' ' SYM_EXT_ATTR(I9)=0 SYM_EXT_VAL(I9)=0 ENDIF ENDDO J=J+8+OFFSET_VEC(0)*4 ENDDO C C read in and analyze system shareable images to resolve more symbols C if any were linked into image C DO I=1,IAF.L_SHRIMGCNT-1 CALL LIB$ESTABLISH(FIX_BUF_3) J=FIX_SHL(I).B_IMGNAMLEN IF(FIX_SHL(I).T_IMGNAM(1:J).EQ.'VMSRTL')THEN I_FLT(1)=JISHFT(JPI$_IMAGNAME,16)+LEN(S_TMP) I_FLT(2)=%LOC(S_TMP) I_FLT(3)=%LOC(LN) I_FLT(4)=0 CALL SYS$GETJPI(,,,I_FLT,,,) ! get full filespec of DISM32.EXE I_FLT(1)=JISHFT(FSCN$_NAME,16) I_FLT(2)=0 I_FLT(3)=0 CALL SYS$FILESCAN(S_TMP(1:LN),I_FLT,) I2=I_FLT(2)-%LOC(S_TMP) OPEN(UNIT=3,FILE=S_TMP(1:I2)//'VMSRTL_V3.EXE',ACCESS='DIRECT', + READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL', + RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE, + SHARED) ELSE OPEN(UNIT=3,FILE=FIX_SHL(I).T_IMGNAM(1:J),ACCESS='DIRECT', + READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL', + RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE, + DEFAULTFILE='SYS$SHARE:.EXE',SHARED) ENDIF IF(ICODE.NE.0)THEN CALL LIB$SIGNAL(DISM__BADSHRIMG,%VAL(2),%VAL(ICODE), + %DESCR(FIX_SHL(I).T_IMGNAM(1:J))) ELSE OFFSET_VEC(0)=-1 OFFSET_VEC(1)=0 J=IAF.L_G_FIXOFF DO WHILE (OFFSET_VEC(1).NE.I.AND.OFFSET_VEC(0).NE.0) CALL LIB$MOVC3(8,HDR_BUF(J),OFFSET_VEC(0)) J=J+8+OFFSET_VEC(0)*4 ENDDO OFFSET_VEC(0)=J-OFFSET_VEC(0)*4-8 OFFSET_VEC(1)=1 DO WHILE (OFFSET_VEC(1).LE.SYM_TBL_PTR.AND. + OFFSET_VEC(0)+8+ISD_BASEVA(FIXUPSEC_ISD).GT. + SYM_VAL(OFFSET_VEC(1))) OFFSET_VEC(1)=OFFSET_VEC(1)+1 ENDDO CUR_VA=0 READ(3,REC=1) REC_BUF ! read in image header CALL LIB$MOVC3(IHD$S_SIZE,REC_BUF(0),SHR_IHD) CALL LIB$MOVC3(IHS$S_SIZE,REC_BUF(SHR_IHD.W_SYMDBGOFF),SHR_IHS) J=SHR_IHS.W_GSTRECS CUR_VBN=SHR_IHS.L_GSTVBN CUR_VA=0 READ(3,REC=CUR_VBN) REC_BUF ! read 1st block of global symbols CALL NAME_SYM_TBL(J,OFFSET_VEC(1),HDR_BUF(OFFSET_VEC(0))) CLOSE(UNIT=3) ENDIF CALL LIB$REVERT ENDDO C C else do V1 VMS shareable image analysis C ELSE IAF.L_SHRIMGCNT=0 DO I=1,ISD_NUM IF((ISD(I).L_FLAGS .AND.1).NE.0)THEN ! if global section IF(ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN-3:ISD(I).B_GBLNAMLEN-1) + .NE.'_00'.OR. + ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN:ISD(I).B_GBLNAMLEN) + .EQ.'1')THEN IAF.L_SHRIMGCNT=IAF.L_SHRIMGCNT+1 FIX_SHL(IAF.L_SHRIMGCNT).L_BASEVA=ISD_BASEVA(I) FIX_SHL(IAF.L_SHRIMGCNT).L_PERMCTX=ISD_PGEND(I) FIX_SHL(IAF.L_SHRIMGCNT).L_IDENT=ISD(I).L_IDENT FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN=ISD(I).B_GBLNAMLEN IF(ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN-3:ISD(I).B_GBLNAMLEN-2) + .EQ.'_0')THEN FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN= + FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN-4 ENDIF FIX_SHL(IAF.L_SHRIMGCNT).T_IMGNAM= + ISD(I).T_GBLNAM(1:FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN) ENDIF ENDIF ENDDO C C read in and analyze system shareable images to resolve more symbols C if any were linked into image C DO I=1,IAF.L_SHRIMGCNT CALL LIB$ESTABLISH(FIX_BUF_3) J=FIX_SHL(I).B_IMGNAMLEN IF(FIX_SHL(I).T_IMGNAM(1:J).EQ.'VMSRTL')THEN I_FLT(1)=JISHFT(JPI$_IMAGNAME,16)+LEN(S_TMP) I_FLT(2)=%LOC(S_TMP) I_FLT(3)=%LOC(LN) I_FLT(4)=0 CALL SYS$GETJPI(,,,I_FLT,,,) ! get full filespec of DISM32.EXE I_FLT(1)=JISHFT(FSCN$_NAME,16) I_FLT(2)=0 I_FLT(3)=0 CALL SYS$FILESCAN(S_TMP(1:LN),I_FLT,) I2=I_FLT(2)-%LOC(S_TMP) OPEN(UNIT=3,FILE=S_TMP(1:I2)//'VMSRTL_V3.EXE',ACCESS='DIRECT', + READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL', + RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE, + SHARED) ELSE OPEN(UNIT=3,FILE=FIX_SHL(I).T_IMGNAM(1:J),ACCESS='DIRECT', + READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL', + RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE, + DEFAULTFILE='SYS$SHARE:.EXE',SHARED) ENDIF IF(ICODE.NE.0)THEN CALL LIB$SIGNAL(DISM__BADSHRIMG,%VAL(2),%VAL(ICODE), + %DESCR(FIX_SHL(I).T_IMGNAM(1:J))) ELSE CUR_VA=0 READ(3,REC=1) REC_BUF ! read in image header CALL LIB$MOVC3(IHD$S_SIZE,REC_BUF(0),SHR_IHD) CALL LIB$MOVC3(IHS$S_SIZE,REC_BUF(SHR_IHD.W_SYMDBGOFF),SHR_IHS) J=SHR_IHS.W_GSTRECS CUR_VBN=SHR_IHS.L_GSTVBN CUR_VA=0 READ(3,REC=CUR_VBN) REC_BUF ! read 1st block of global symbols I2=IABS(FIND_P2_SYMBOL(%VAL(FIX_SHL(I).L_BASEVA))) AUX_SYM_TBL(-1)=0 I3=I2 DO WHILE (I2.LE.SYM_TBL_PTR.AND. + FIX_SHL(I).L_PERMCTX .GE.SYM_VAL(I2)) AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)+1 AUX_SYM_TBL(AUX_SYM_TBL(-1))=SYM_VAL(I2)-FIX_SHL(I).L_BASEVA I2=I2+1 ENDDO CALL NAME_SYM_TBL(J,I3,AUX_SYM_TBL(-1)) CLOSE(UNIT=3) ENDIF CALL LIB$REVERT ENDDO ENDIF C C scan for transfer vectors (shareable images) and fix up symbol names for C destinations of vectors C CALL LIB$ESTABLISH(FIX_BUFR_OVRFL) I=1 DO WHILE (I.LE.SYM_TBL_PTR) IF((SYM_TYP(I).AND.SYM_TRANSFER).NE.0)THEN IF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN ADDR=SYM_VAL(I)+2 ELSE ADDR=SYM_VAL(I) ENDIF I2=-1 ! assume error IF(ADDR.GE.ISD_BASEVA(1).AND. + ADDR.LE.ISD_PGEND(1))THEN CALL COPY_BYTE(ADDR,DISPL_BYT) ! get opcode IF(DISPL_BYT.EQ.'11'X)THEN ! BRB instruction CALL COPY_BYTE(ADDR+1,DISPL_BYT) I2=ADDR+DISPL_BYT+2 ELSEIF(DISPL_BYT.EQ.'31'X)THEN ! BRW instruction CALL COPY_WORD(ADDR+1,DISPL_WRD) I2=ADDR+DISPL_WRD+3 ELSEIF(DISPL_BYT.EQ.'17'X)THEN ! JMP instruction CALL COPY_BYTE(ADDR+1,DISPL_BYT) IF(DISPL_BYT.EQ.'AF'X)THEN ! byte relative CALL COPY_BYTE(ADDR+2,DISPL_BYT) I2=ADDR+DISPL_BYT+3 ELSEIF(DISPL_BYT.EQ.'CF'X)THEN ! word relative CALL COPY_WORD(ADDR+2,DISPL_WRD) I2=ADDR+DISPL_WRD+4 ELSEIF(DISPL_BYT.EQ.'EF'X)THEN ! longword relative CALL COPY_LONG(ADDR+2,I2) I2=ADDR+I2+6 ENDIF ELSE SYM_TYP(I)=SYM_TYP(I).AND..NOT.SYM_TRANSFER ENDIF IF(I2.NE.-1)THEN IF((SYM_TYP(I).AND.SYM_PROC).NE.0) I2=I2-2 K=FIND_P2_SYMBOL(%VAL(I2)) ! get symbol pointed at IF(K.GT.0)THEN SYM_NAM(K)=SYM_NAM(I) SYM_EXT_VAL(K)=SYM_VAL(I) SYM_EXT_VAL(I)=SYM_VAL(K) ELSEIF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN K=FIND_P2_SYMBOL(%VAL(I2+2)) IF(K.GT.0)THEN IF(SYM_TBL_PTR+1.GT.SYM_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__SYMTBLOVF) ENDIF DO I9=SYM_TBL_PTR,K,-1 SYM_VAL(I9+1)=SYM_VAL(I9) SYM_TYP(I9+1)=SYM_TYP(I9) SYM_EXT_ATTR(I9+1)=SYM_EXT_ATTR(I9) SYM_EXT_VAL(I9+1)=SYM_EXT_VAL(I9) SYM_NAM(I9+1)=SYM_NAM(I9) ENDDO SYM_TBL_PTR=SYM_TBL_PTR+1 SYM_VAL(K)=I2 SYM_TYP(K)=SYM_PROC SYM_EXT_ATTR(K)=0 SYM_EXT_VAL(K)=SYM_VAL(I) SYM_NAM(K)=SYM_NAM(I) SYM_EXT_VAL(I)=I2 ENDIF ENDIF ELSE ! didn't get recognized as a code transfer IF(IAND(SYM_TYP(I),SYM_M_CODE+SYM_M_DATA).EQ. + SYM_TRANSFER+SYM_SUBR)THEN SYM_TYP(I)=IOR(IAND(SYM_TYP(I),.NOT.SYM_SUBR),SYM_D_LNG) ENDIF ENDIF ENDIF ENDIF I=I+1 ENDDO CALL LIB$REVERT C C scan for RMS data blocks and procedure entry points and mark immediately C following symbols within the block as non-definable; also record any C special extended data types for special macro expansion C CALL LIB$ESTABLISH(FIX_BUFR_OVRFL) I=1 DO WHILE (I.LE.SYM_TBL_PTR) IF((SYM_TYP(I).AND.SYM_D_RMS).NE.0)THEN J=I+1 I2=0 CALL COPY_BYTE(SYM_VAL(I)+1,I2) DO WHILE (SYM_VAL(J).LT.SYM_VAL(I)+I2.AND. + J.LE.SYM_TBL_PTR) SYM_TYP(J)=SYM_TYP(J).OR.SYM_NOTDEF SYM_NAM(J)=' ' J=J+1 ENDDO I=J ELSEIF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN J=I+1 DO WHILE (SYM_VAL(J).LE.SYM_VAL(I)+2.AND. + J.LE.SYM_TBL_PTR) SYM_TYP(J)=SYM_TYP(J).OR.SYM_NOTDEF SYM_NAM(J)=' ' J=J+1 ENDDO I=J ELSEIF((SYM_TYP(I).AND.SYM_D_EXTENDED).NE.0)THEN IF(SYM_EXT_ATTR(I).NE.SYM_T_KEYWRDTBL.AND. + SYM_EXT_ATTR(I).NE.SYM_T_STATE)THEN SYM_NEED_MACRO(SYM_EXT_ATTR(I))=.TRUE. ENDIF I=I+1 ELSE I=I+1 ENDIF ENDDO C C find if any symbol definitions unspecified that might be address-referenced C condition code values and make up symbol names for them C IF(FIXUPSEC_ISD.NE.0.AND. + MSG_NUMFAC.NE.0)THEN K=IABS(FIND_P2_SYMBOL(%VAL(ISD_PGEND(FIXUPSEC_ISD)+1))) DO WHILE (K.NE.0) IF((SYM_VAL(K).AND.'E0000000'X).EQ.0.AND. + (SYM_VAL(K).AND.'7'X).LE.4)THEN I=1 I2=JISHFT(IAND(SYM_VAL(K),'0FFF0000'X),-16) DO WHILE (I.LE.MSG_NUMFAC.AND. + I2.NE.MSG_FACDESCR(4,I)) I=I+1 ENDDO IF(I.LE.MSG_NUMFAC)THEN CALL COPY_WORD(MSG_FACDESCR(2,I),LN) DO I3=1,LN CALL COPY_BYTE(MSG_FACDESCR(2,I)+1+I3,%REF(S_TMP(I3:I3))) ENDDO IF((I2.AND.'800'X).NE.0)THEN S_TMP(LN+1:LN+2)='__' ELSE S_TMP(LN+1:LN+2)='$_' ENDIF LN=LN+2 ADDR=MSG_FACDESCR(1,I) OFFSET_VEC(0)=-1 DO WHILE (ADDR.LT.MSG_FACDESCR(3,I).AND. + OFFSET_VEC(0).NE.SYM_VAL(K)) CALL COPY_LONG(ADDR,OFFSET_VEC(0)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,OFFSET_VEC(1)) ADDR=ADDR+4 IF(OFFSET_VEC(0).EQ.IAND(SYM_VAL(K),.NOT.7))THEN OFFSET_VEC(1)=OFFSET_VEC(1)+MSG_FACDESCR(0,I) CALL COPY_STR(OFFSET_VEC(1),MESSAGE_BUF) I2=ICHAR(MESSAGE_BUF(9:9)) SYM_NAM(K)=S_TMP(1:LN)//MESSAGE_BUF(10:9+I2) I3=SYM_VAL(K).AND.7 IF(I3.NE.0)THEN CALL SYS$FAO('+!UL',,SYM_NAM(K)(LN+I2+1:),%VAL(I3)) ENDIF ENDIF ENDDO ENDIF K=K+1 ELSE K=0 ! end the loop ENDIF ENDDO ENDIF C C scan through the symbol table and find all procedure entry points that C look like BASIC procedures, and analyze their procedure description C lists C DO I=1,SYM_TBL_PTR IF((SYM_TYP(I).AND.SYM_PROC).NE.0.AND. + (SYM_VAL(I).AND.'C0000000'X).EQ.0)THEN J=1 DO WHILE (J.LE.ISD_NUM.AND. + (SYM_VAL(I).LT.ISD_BASEVA(J).OR. + SYM_VAL(I).GT.ISD_PGEND(J))) J=J+1 ENDDO IF(J.LE.ISD_NUM)THEN DO J=2,21 CALL COPY_BYTE(SYM_VAL(I)+J,BASIC_ENTRY(J)) ENDDO OK=.FALSE. IF(BASIC_ENTRY_C(1:6).EQ.BASIC_ENTRY_CMP_C(1:6).AND. + BASIC_ENTRY_C(11:16).EQ.BASIC_ENTRY_CMP_C(11:16))THEN J=FIND_P2_SYMBOL(%VAL(SYM_VAL(I)+22+BASIC_ENTRY_INIT)) IF(J.GT.0.AND. + SYM_VAL(IABS(J)).GE.ISD_BASEVA(FIXUPSEC_ISD).AND. + SYM_VAL(IABS(J)).LE.ISD_PGEND(FIXUPSEC_ISD))THEN IF(SYM_NAM(J).EQ.'BAS$INIT_R8')THEN OK=.TRUE. K=SYM_VAL(I)+12+BASIC_ENTRY_ARGLIST ENDIF ENDIF ELSEIF(BASIC_ENTRY_C(1:3).EQ.BASIC_ENTRY_DEF_C(1:3).AND. + BASIC_ENTRY_C(8:13).EQ.BASIC_ENTRY_DEF_C(8:13))THEN J=FIND_P2_SYMBOL(%VAL(SYM_VAL(I)+18+BASIC_DEF_INIT)) IF(J.GT.0.AND. + SYM_VAL(IABS(J)).GE.ISD_BASEVA(FIXUPSEC_ISD).AND. + SYM_VAL(IABS(J)).LE.ISD_PGEND(FIXUPSEC_ISD))THEN IF(SYM_NAM(J).EQ.'BAS$INIT_DEF_R8')THEN OK=.TRUE. K=SYM_VAL(I)+8+BASIC_DEF_ARGLIST ENDIF ENDIF ENDIF IF(OK)THEN DO I2=0,71 CALL COPY_BYTE(K+I2,BASIC.ARGLIST(I2)) ENDDO IF(BASIC.OFS_NAME .NE. 0)THEN CALL COPY_STR(K+BASIC.OFS_NAME,S_TMP,LN) IF(SYM_NAM(I).EQ.' ')THEN SYM_NAM(I)=S_TMP(1:LN) ENDIF I2=1 DO WHILE (I2.LE.MOD_TBL_PTR.AND. + MOD_START(I2).NE.SYM_VAL(I)) I2=I2+1 ENDDO IF(I2.GT.MOD_TBL_PTR)THEN MOD_TBL_PTR=MOD_TBL_PTR+1 IF(MOD_TBL_PTR.GT.MOD_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__MODTBLOVF) ENDIF MOD_START(MOD_TBL_PTR)=SYM_VAL(I) MOD_END(MOD_TBL_PTR)=SYM_VAL(I)+29 MOD_VERMAJ(MOD_TBL_PTR)=BASIC.VERSION MOD_VERMIN(MOD_TBL_PTR)=0 MOD_LNG(MOD_TBL_PTR)=4 ! code # for BASIC MOD_NAM(MOD_TBL_PTR)=S_TMP(1:LN) ELSEIF(MOD_VERMAJ(I2).EQ.0)THEN MOD_VERMAJ(MOD_TBL_PTR)=BASIC.VERSION ENDIF I2=FIND_P2_SYMBOL(%VAL(K)) IF(I2.GT.0.AND. + SYM_EXT_ATTR(I2).EQ.0)THEN SYM_TYP(I2)=SYM_TYP(I2).OR.SYM_D_EXTENDED SYM_EXT_ATTR(I2)=SYM_T_BASARGLST SYM_EXT_VAL(I2)=SYM_VAL(I) IF(SYM_NAM(I2).EQ.' ')THEN SYM_NAM(I2)='barg_'//S_TMP(1:LN) ENDIF ENDIF I2=BASIC.OFS_NAME+1+LN CALL COPY_LONG(K+I2,I9) I2=I2+4 DO I3=1,I9 CALL COPY_WORD(K+I2,LN) CALL COPY_WORD(K+I2+2,LN2) I2=I2+4 I8=SYM_VAL(I)+LN2 J=1 DO WHILE (J.LE.LIN_TBL_PTR.AND. + I8.NE.LIN_ADR(J)) J=J+1 ENDDO IF(J.GT.LIN_TBL_PTR)THEN LIN_TBL_PTR=LIN_TBL_PTR+1 IF(LIN_TBL_PTR.GT.LIN_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__LINTBLOVF) ENDIF LIN_ADR(LIN_TBL_PTR)=I8 LIN_NUM(LIN_TBL_PTR)=LN LIN_STMT(LIN_TBL_PTR)=1 ENDIF ENDDO ENDIF ENDIF ENDIF ENDIF ENDDO C C shell-sort the module table into ascending address order C IF(MOD_TBL_PTR.NE.0)THEN I9=(2**INT(LOG(FLOAT(MOD_TBL_PTR))/LOG(2.0))) - 1 DO WHILE (I9.GT.0) DO I=1,MOD_TBL_PTR-I9 IF(MOD_START(I).GT.MOD_START(I+I9))THEN I2=MOD_START(I+I9) I3=MOD_END(I+I9) OK=MOD_VERMAJ(I+I9) OK2=MOD_VERMIN(I+I9) REC_TYP=MOD_LNG(I+I9) S_TMP(1:31)=MOD_NAM(I+I9) MOD_START(I+I9)=MOD_START(I) MOD_END(I+I9)=MOD_END(I) MOD_VERMAJ(I+I9)=MOD_VERMAJ(I) MOD_VERMIN(I+I9)=MOD_VERMIN(I) MOD_LNG(I+I9)=MOD_LNG(I) MOD_NAM(I+I9)=MOD_NAM(I) IF(I.GT.I9)THEN J=I-I9 DO WHILE (J.GE.1.AND.I2.LT.MOD_START(J)) MOD_START(J+I9)=MOD_START(J) MOD_END(J+I9)=MOD_END(J) MOD_VERMAJ(J+I9)=MOD_VERMAJ(J) MOD_VERMIN(J+I9)=MOD_VERMIN(J) MOD_LNG(J+I9)=MOD_LNG(J) MOD_NAM(J+I9)=MOD_NAM(J) J=J-I9 ENDDO MOD_START(J+I9)=I2 MOD_END(J+I9)=I3 MOD_VERMAJ(J+I9)=OK MOD_VERMIN(J+I9)=OK2 MOD_LNG(J+I9)=REC_TYP MOD_NAM(J+I9)=S_TMP(1:31) ELSE MOD_START(I)=I2 MOD_END(I)=I3 MOD_VERMAJ(I)=OK MOD_VERMIN(I)=OK2 MOD_LNG(I)=REC_TYP MOD_NAM(I)=S_TMP(1:31) ENDIF ENDIF ENDDO I9=I9/2 ENDDO ENDIF C C shell-sort the line number table into ascending address order C IF(LIN_TBL_PTR.NE.0)THEN I9=(2**INT(LOG(FLOAT(LIN_TBL_PTR))/LOG(2.0))) - 1 DO WHILE (I9.GT.0) DO I=1,LIN_TBL_PTR-I9 IF(LIN_ADR(I).GT.LIN_ADR(I+I9))THEN I2=LIN_ADR(I+I9) LN=LIN_NUM(I+I9) LN2=LIN_STMT(I+I9) LIN_ADR(I+I9)=LIN_ADR(I) LIN_NUM(I+I9)=LIN_NUM(I) LIN_STMT(I+I9)=LIN_STMT(I) IF(I.GT.I9)THEN J=I-I9 DO WHILE (J.GE.1.AND.I2.LT.LIN_ADR(J)) LIN_ADR(J+I9)=LIN_ADR(J) LIN_NUM(J+I9)=LIN_NUM(J) LIN_STMT(J+I9)=LIN_STMT(J) J=J-I9 ENDDO LIN_ADR(J+I9)=I2 LIN_NUM(J+I9)=LN LIN_STMT(J+I9)=LN2 ELSE LIN_ADR(I)=I2 LIN_NUM(I)=LN LIN_STMT(I)=LN2 ENDIF ENDIF ENDDO I9=I9/2 ENDDO ENDIF C C scan through the symbol table and make up symbol names for all C unnamed entries C DO I=1,SYM_TBL_PTR IF((SYM_TYP(I).AND.SYM_NOTDEF).EQ.0) J=I IF(SYM_NAM(I).EQ.' ')THEN CALL OTS$CVT_L_TZ(SYM_VAL(I),S_TMP(1:8),%VAL(8)) IF((SYM_TYP(I).AND.SYM_NOTDEF).NE.0.AND. + (SYM_TYP(I).AND.SYM_D_EXTENDED).EQ.0)THEN CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN) CALL SYS$FAO('!AD+!UL',,SYM_NAM(I),%VAL(LN),%REF(SYM_NAM(J)), + %VAL(SYM_VAL(I)-SYM_VAL(J))) ELSEIF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN SYM_NAM(I)='P_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_SUBR).NE.0)THEN SYM_NAM(I)='S_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_JMPE).NE.0)THEN SYM_NAM(I)='LB_'//S_TMP(1:8) ELSE ! data type only IF((SYM_TYP(I).AND.SYM_BASEADR).NE.0)THEN SYM_NAM(I)='BASE_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_EXTENDED).NE.0)THEN CALL EXTENDED_DATA_SYMNAM(I,S_TMP(1:8)) ELSEIF((SYM_TYP(I).AND.SYM_D_RMS).NE.0)THEN CALL COPY_BYTE(SYM_VAL(I),OK) ! get type of block SYM_NAM(I)=RMS_TYPNAM(OK)(1:RMS_TYPNAMLEN(OK))//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_FORMAT).NE.0)THEN SYM_NAM(I)='FORMAT_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_HFL).NE.0)THEN SYM_NAM(I)='H_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_GFL).NE.0)THEN SYM_NAM(I)='G_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_DFL).NE.0)THEN SYM_NAM(I)='D_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_FLT).NE.0)THEN SYM_NAM(I)='F_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_OCT).NE.0)THEN SYM_NAM(I)='O_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_QUD).NE.0)THEN SYM_NAM(I)='Q_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_CHR).NE.0)THEN SYM_NAM(I)='STR_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_PDS).NE.0)THEN SYM_NAM(I)='PDEC_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_LSN).NE.0)THEN SYM_NAM(I)='LSTR_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_TNS).NE.0)THEN SYM_NAM(I)='TNSTR_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_TBL).NE.0)THEN SYM_NAM(I)='TBL_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_PTN).NE.0)THEN SYM_NAM(I)='PTTN_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_LNG).NE.0)THEN SYM_NAM(I)='L_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_WRD).NE.0)THEN SYM_NAM(I)='W_'//S_TMP(1:8) ELSEIF((SYM_TYP(I).AND.SYM_D_BYT).NE.0)THEN SYM_NAM(I)='B_'//S_TMP(1:8) ENDIF ENDIF ENDIF ENDDO C C report on transfer addresses (if any exist) C IF(IHA.L_TFRADR(1).NE.0)THEN WRITE(2,9150) 9150 FORMAT(';'/ + '; transfer addresses:') DO I=1,3 IF(IHA.L_TFRADR(I).NE.0)THEN K=FIND_P2_SYMBOL(%VAL(IHA.L_TFRADR(I))) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,9151) IHA.L_TFRADR(I), SYM_NAM(K)(1:LN) 9151 FORMAT('; ',Z8.8,X,A) ELSE WRITE(2,9152) IHA.L_TFRADR(I) 9152 FORMAT('; ',Z8.8) ENDIF ENDIF ENDDO ENDIF C C add special macro definitions if needed C DO I=1,20 IF(SYM_NEED_MACRO(I))THEN WRITE(2,9153) TAB, SPECIAL_MACRO(I) 9153 FORMAT(A1,A) ENDIF ENDDO C C begin pass 2 disassembly C CALL LIB$PUT_OUTPUT('Beginning pass 2...') CALL LIB$ESTABLISH(FIX_BUFR_OVRFL) MOD_PTR=1 ! set up module table indexing DO I=1,ISD_NUM CALL STR$TRIM(ISD_NAM(I),ISD_NAM(I),LN2) CALL SYS$FAO('Beginning ISD !AS (^X!XL to ^X!XL)...',LN,OUT_FIL, + ISD_NAM(I)(1:LN2), + %VAL(ISD_BASEVA(I)),%VAL(ISD_PGEND(I))) CALL LIB$PUT_OUTPUT(OUT_FIL(1:LN)) I3=JISHFT(ISD(I).L_FLAGS, -24) IF(I3.EQ.253.OR. + I3.EQ.-3)GOTO 5000 ! skip stack section WRITE(2,9002) WRITE(2,9200)form_feed,TAB,TAB,ISD_NAM(I)(1:LN2) 9200 FORMAT(A1/ + A1,'.SBTTL',A1,'Image section ',A) WRITE(2,9002) LN3=JISHFT(ISD(I).L_VPNPFC,-24) I2=IAND(ISD(I).L_FLAGS,'00FFFFFF'X) WRITE(2,9210) I, ISD_BASEVA(I), ISD_PGEND(I), ISD(I).W_PAGCNT, + LN3, I2, ISD(I).L_VBN, C_ISDTYP(I3) 9210 FORMAT('; Image section',I3,': start ^X',Z8.8,', end ^X',Z8.8, + ', contains',I4,' pages'/ + '; PFC=',I3,', linker flags ^X',Z6.6, + ', base VBN=',I4,', typ=',A) WRITE(2,9002) C C select method of disassembly, depending on I-sect type C IF((ISD(I).L_FLAGS .AND.1).NE.0)GOTO 4000 ! process shareable section IF((ISD(I).L_FLAGS .AND.'400'X).NE.0)GOTO 4500 ! process fixup vector IF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)GOTO 4800! process message section C C do each program section from an image section C S_TMP=CHAR(9)//'.PSECT'//CHAR(9)//ISD_NAM(I)(1:LN2)// + ',CON,REL,NOVEC,RD,' LN=LN2+27 IF((ISD(I).L_FLAGS .AND.'8'X).NE.0)THEN ! ISD$M_WRT S_TMP(LN:)='WRT,' LN=LN+4 ELSE S_TMP(LN:)='NOWRT,' LN=LN+6 ENDIF IF(ISD(I).W_SIZE .LT.0)THEN S_TMP(LN:)='EXE,' LN=LN+4 ELSE S_TMP(LN:)='NOEXE,' LN=LN+6 ENDIF IF((ISD(I).L_FLAGS .AND.'200'X).EQ.0)THEN ! ISD$M_BASED S_TMP(LN:)='PIC,' ! private or shareable PIC I-sect LN=LN+4 ELSE S_TMP(LN:)='NOPIC,' LN=LN+6 ENDIF IF((ISD(I).L_FLAGS .AND.1).NE.0)THEN ! ISD$M_GBL S_TMP(LN:)='GBL,' ELSE S_TMP(LN:)='LCL,' ENDIF LN=LN+4 IF((ISD(I).L_FLAGS .AND.'106'X).NE.0)THEN ! ISD$M_CRF, ISD$M_DZRO, S_TMP(LN:)='NOSHR,' ! ISD$M_COPYALWAYS LN=LN+6 ELSE S_TMP(LN:)='SHR,' LN=LN+4 ENDIF S_TMP(LN:)='LONG' LN=LN+3 WRITE(2,'(A)') S_TMP(1:LN) WRITE(2,9002) C C set up to start 'P-section' by getting base address, base VBN (if any), C reading VB, and initializing to data (as opposed to code) mode C CUR_VA=ISD_BASEVA(I) ADDR=ISD_BASEVA(I) CUR_VBN=ISD(I).L_VBN 2000 IF(CUR_VBN.NE.0)THEN ! this is normal processing entry for vector READ(1,REC=CUR_VBN) REC_BUF ! I-sects as well ELSE CALL LIB$MOVC5(0,0,0,512,REC_BUF) ENDIF OK=.FALSE. ! set to data mode J=0 IF((ISD(I).L_FLAGS .AND.4).NE.0)GOTO 3000 ! process demand zero section DO WHILE (ADDR.LE.ISD_PGEND(I)) C C find the module in module table equal to current address C IF(MOD_PTR.LE.MOD_TBL_PTR)THEN IF(MOD_START(MOD_PTR).GT.ADDR)THEN CONTINUE ELSEIF(MOD_START(MOD_PTR).LT.ADDR)THEN MOD_PTR=MOD_PTR+1 ELSE CALL STR$TRIM(MOD_NAM(MOD_PTR),MOD_NAM(MOD_PTR),LN) WRITE(2,9201) MOD_NAM(MOD_PTR)(1:LN), + LANGUAGE_NAME(MOD_LNG(MOD_PTR)), + MOD_VERMAJ(MOD_PTR), MOD_VERMIN(MOD_PTR) 9201 FORMAT(';'/ + '; Module ',A,', compiled by ',A,' V',I2.2,'.',I2.2) ENDIF ENDIF C C find the first symbol in symbol table equal to or greater than current C address C CURR_ADR=ADDR K=IABS(FIND_P2_SYMBOL(%VAL(ADDR))) J=K DO WHILE (((SYM_TYP(J).AND.SYM_NOTDEF).NE.0.AND. + (SYM_TYP(J).AND.SYM_D_EXTENDED).EQ.0).AND. + J.LE.SYM_TBL_PTR) J=J+1 ENDDO I2=MIN(SYM_VAL(J)-ADDR,MAX(ISD_PGEND(I)-ADDR,0)) IF(SYM_VAL(J).EQ.ADDR)THEN CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN) IF((SYM_TYP(J).AND.SYM_PROC).NE.0)THEN LLV_CODEMODE=.TRUE. ! switch to code mode WRITE(2,9002) ICODE=0 CALL COPY_WORD(ADDR,ICODE) ! get entry mask word IF((SYM_TYP(J).AND.SYM_TRANSFER).NE.0)THEN I9=0 CALL COPY_WORD(SYM_EXT_VAL(J),I9) ELSE I9=-1 ENDIF ADDR=ADDR+2 CURR_ADR=ADDR IF((SYM_TYP(J).AND.SYM_TRANSFER).NE.0.AND. + I9.EQ.ICODE)THEN WRITE(2,'(A1,''.TRANSFER'',A1,A)')TAB,TAB,SYM_NAM(J)(1:LN) WRITE(2,'(A1,''.MASK'',2A1,A)')TAB,TAB,TAB,SYM_NAM(J)(1:LN) ELSE S_TMP=CHAR(9)//'.ENTRY'//CHAR(9)//SYM_NAM(J)(1:LN)// + ',^M<' LN=LN+13 CALL MAKE_MASK(S_TMP(LN:),ICODE,LN2) LN=LN+LN2-1 WRITE(2,'(A)') S_TMP(1:LN) ENDIF ELSEIF((SYM_TYP(J).AND.SYM_M_CODE).NE.0)THEN LLV_CODEMODE=.TRUE. ! switch to code mode IF((SYM_TYP(J).AND.SYM_TRANSFER).NE.0)THEN WRITE(2,'(A1,''.TRANSFER'',A1,A)')TAB,TAB,SYM_NAM(J)(1:LN) ELSE WRITE(2,'(A,'':'')') SYM_NAM(J)(1:LN) ENDIF ELSE !!??? LLV_CODEMODE=.FALSE. ! switch to data mode IF((SYM_TYP(J).AND.SYM_NOTDEF).EQ.0)THEN WRITE(2,'(A,'':'')') SYM_NAM(J)(1:LN) ENDIF ENDIF I2=MIN(SYM_VAL(J+1),ISD_PGEND(I))-SYM_VAL(J) ELSE IF(SYM_VAL(K).EQ.ADDR)THEN J=K ELSE J=K-1 ENDIF ENDIF C C disassemble object into either appropriate type data or executable C code, depending on mode C IF(LLV_CODEMODE)THEN K=DISM_INSTR(ADDR,1) ! disassemble instruction IF(K.EQ.0)THEN LLV_CODEMODE=.FALSE. ! end of code section, switch to data ELSEIF(K.EQ.%LOC(DISM__INVOPCODE))THEN WRITE(2,9205)TAB,TAB,TAB,TAB 9205 FORMAT(A1,'.WARN',A1,'0',2A1,'; Undefined opcode') ENDIF ELSE C C unscramble data into data areas, according to last symbol type C K=25 I8='08000000'X 2009 DO WHILE (((SYM_TYP(J).AND.I8).EQ.0.OR. + (SYM_VAL(J).NE.ADDR.AND..NOT.DTYP_CONTINUE(K))).AND. + I8.GE.'8'X) K=K-1 I8=I8/2 ENDDO IF(DTYP_SIZE(K).GT.I2)K=1 ! in case of alignment problems GOTO (2010,2020,2030,2040,2050,2060,2070,2080,2090,2100, + 2110,2120,2130,2140,2150, + 2030, ! hole-filling + 2190,2200, + 2210,2220,2230,2240,2250,2260,2270),K ! vector to appropriate routine C C handler for type longword (also default handler) C 2030 CALL COPY_LONG(ADDR,I2) ADDR=ADDR+4 IF(I2.NE.0)THEN K=FIND_P2_SYMBOL(%VAL(I2)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN3) WRITE(2,9230)TAB,TAB,SYM_NAM(K)(1:LN3) 9230 FORMAT(A1,'.ADDRESS',A1,A) GOTO 2900 ENDIF ENDIF S_TMP=CHAR(9)//'.LONG'//CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I2,S_TMP(10:17),%VAL(8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:17)) GOTO 2900 C C handler for type byte C 2010 CALL COPY_BYTE(ADDR,I2) ADDR=ADDR+1 S_TMP=CHAR(9)//'.BYTE'//CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I2,S_TMP(10:11),%VAL(2),%VAL(1)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:11)) GOTO 2900 C C handler for type word C 2020 I2=0 CALL COPY_WORD(ADDR,I2) ADDR=ADDR+2 S_TMP=CHAR(9)//'.WORD'//CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I2,S_TMP(10:13),%VAL(4),%VAL(2)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:13)) GOTO 2900 C C handler for type quadword C 2040 CALL COPY_LONG(ADDR,I2) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I3) ADDR=ADDR+4 K=FIND_P2_SYMBOL(%VAL(I3)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN3) S_TMP=CHAR(9)//'.LONG'//CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I2,S_TMP(10:17),%VAL(8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:17)) WRITE(2,9230)TAB,TAB,SYM_NAM(K)(1:LN3) GOTO 2900 ENDIF IF(ADDR.EQ.I3.AND. + (I2.AND.'FFFF0000'X).EQ.0)THEN S_TMP=CHAR(9)//'.LONG'//CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I2,S_TMP(10:17),%VAL(8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:17)) WRITE(2,9240)TAB,TAB 9240 FORMAT(A1,'.ADDRESS',A1,'.+4') GOTO 2900 ENDIF K=1 DO WHILE (K.LE.SYM_TBL_PTR.AND. + SYM_VAL(K).LT.ADDR) K=K+1 ENDDO I8=I2.AND.'FFFF'X IF(SYM_VAL(K)-ADDR.GE.I8.AND. + I3.EQ.ADDR.AND. + (JISHFT(I2.AND.'00FF0000'X,-16).EQ.14.OR. + JISHFT(I2.AND.'00FF0000'X,-16).EQ.16.OR. + JISHFT(I2.AND.'00FF0000'X,-16).EQ.18).AND. + JISHFT(I2.AND.'FF000000'X,-24).EQ.1)THEN DO K=1,I8 CALL COPY_BYTE(ADDR,%REF(CMD_LIN(K:K))) ADDR=ADDR+1 ENDDO K=STR$FIND_FIRST_NOT_IN_SET(STR_DELIM, + CMD_LIN(1:I8)) S_TMP=CHAR(9)//'.ASCID'//CHAR(9)//STR_DELIM(K:K)// + CMD_LIN(1:I8)//STR_DELIM(K:K) LN=I8+10 GOTO 2899 ENDIF S_TMP=CHAR(9)//'.QUAD'//CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I3,S_TMP(10:17),%VAL(8)) CALL OTS$CVT_L_TZ(I2,S_TMP(18:25),%VAL(8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:25)) GOTO 2900 C C handler for type F_floating C 2050 CALL COPY_LONG(ADDR,X_FLT) ADDR=ADDR+4 ICODE=CONVERT_F_FLOAT(X_FLT,S_TMP(1:14),LN) IF(.NOT.ICODE) LN=0 WRITE(2,9250)TAB,TAB,I_FLT(1),TAB,S_TMP(1:LN) 9250 FORMAT(A1,'.LONG',A1,'^X',Z8.8,A1,'; F_float ',A) GOTO 2900 C C handler for D_floating type C 2060 CALL COPY_LONG(ADDR,I_FLT(1)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I_FLT(2)) ADDR=ADDR+4 ICODE=CONVERT_D_FLOAT(X_DFL,S_TMP(1:24),LN) IF(.NOT.ICODE) LN=0 WRITE(2,9260)TAB,TAB,I_FLT(1),I_FLT(2),TAB,S_TMP(1:LN) 9260 FORMAT(A1,'.LONG',A1,'^X',Z8.8,',^X',Z8.8,A1,'; D_float ',A) GOTO 2900 C C handler for G_floating type C 2070 CALL COPY_LONG(ADDR,I_FLT(1)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I_FLT(2)) ADDR=ADDR+4 ICODE=CONVERT_G_FLOAT(X_DFL,S_TMP(1:24),LN) IF(.NOT.ICODE) LN=0 WRITE(2,9270)TAB,TAB,I_FLT(1),I_FLT(2),TAB,S_TMP(1:LN) 9270 FORMAT(A1,'.LONG',A1,'^X',Z8.8,',^X',Z8.8,A1,'; G_float ',A) GOTO 2900 C C handler for H_floating type C 2080 DO I3=1,4 CALL COPY_LONG(ADDR,I_FLT(I3)) ADDR=ADDR+4 ENDDO ICODE=CONVERT_H_FLOAT(X_HFL,S_TMP(1:42),LN) IF(.NOT.ICODE) LN=0 WRITE(2,9280)TAB,TAB,I_FLT,TAB,S_TMP(1:LN) 9280 FORMAT(A1,'.LONG',A1,'^X',Z8.8,3(',^X',Z8.8),A1, + '; H_float ',A) GOTO 2900 C C handler for character string type C 2090 S_TMP=CHAR(9)//'.ASCII'//CHAR(9)//'"' LN=10 LN2=0 2092 IF(LN2.NE.0)THEN I3=MIN0(LN2,62) ELSE I3=MIN0(I2,62) ENDIF I2=0 DO K=1,I3 CALL COPY_BYTE(ADDR,I2) ADDR=ADDR+1 IF(I2.EQ.ICHAR('"'))THEN S_TMP(LN:LN+4)='"/"/"' LN=LN+5 ELSEIF(I2.LT.127.AND.I2.GE.32)THEN S_TMP(LN:LN)=CHAR(I2) LN=LN+1 ELSE ADDR=ADDR-1 IF(K.EQ.1)GOTO 2010 GOTO 2095 ENDIF ENDDO 2095 S_TMP(LN:LN)='"' GOTO 2899 C C handler for packed decimal string type C 2100 S_TMP=CHAR(9)//'.PACKED'//CHAR(9)//' ' LN=10 DO K=1,16 CALL COPY_BYTE(ADDR,I2) ADDR=ADDR+1 S_TMP(LN+1:LN+2)=CHAR((I2/16)+48)//CHAR((I2.AND.'F'X)+48) LN=LN+2 IF(S_TMP(LN:LN).GT.'9')THEN I2=I2.AND.'F'X LN=LN-1 IF(I2.EQ.11.OR.I2.EQ.13)THEN S_TMP(10:10)='-' ELSE S_TMP(10:10)='+' ENDIF GOTO 2105 ENDIF ENDDO 2105 GOTO 2899 C C handler for leading separate numeric string type C 2110 S_TMP=CHAR(9)//'.ASCII'//CHAR(9)//'/' LN=9 CALL COPY_BYTE(ADDR,%REF(S_TMP(LN+1:LN+1))) IF(S_TMP(LN+1:LN+1).NE.'+'.AND. + S_TMP(LN+1:LN+1).NE.' '.AND. + S_TMP(LN+1:LN+1).NE.'-'.AND. + (S_TMP(LN+1:LN+1).LT.'0'.OR.S_TMP(LN+1:LN+1).GT.'9'))THEN GOTO 2010 ! treat as byte ELSE LN=LN+1 ADDR=ADDR+1 K=IABS(FIND_P2_SYMBOL(%VAL(ADDR))) I3=MIN(SYM_VAL(K),ISD_PGEND(I)) CALL COPY_BYTE(ADDR,%REF(S_TMP(LN+1:LN+1))) DO WHILE (ADDR.LT.I3.AND. + LN.LE.70.AND. + S_TMP(LN+1:LN+1).GE.'0'.AND. + S_TMP(LN+1:LN+1).LE.'9') LN=LN+1 ADDR=ADDR+1 CALL COPY_BYTE(ADDR,%REF(S_TMP(LN+1:LN+1))) ENDDO LN=LN+1 S_TMP(LN:LN)='/' GOTO 2899 ENDIF GOTO 2900 C C handler for trailing numeric string type C 2120 CALL WRITE_OUTPUT_TEXT(CHAR(9)// + '; trailing numeric string type') GOTO 2010 C C handler for table types C 2130 CALL WRITE_OUTPUT_TEXT(CHAR(9)//'; table type') K=12 I8=SYM_D_TBL/2 GOTO 2009 C C handler for edit pattern string type C 2140 I2=-1 DO WHILE (I2.NE.0) LN=1 S_TMP=CHAR(9) CALL COPY_BYTE(ADDR,I2) ADDR=ADDR+1 I3=1 DO WHILE (EDIT_MASK(I3).NE.0.AND.I2.NE.0) K=I2.AND.EDIT_MASK(I3) IF(K.EQ.EDIT_OPC(I3))THEN CALL STR$TRIM(EDIT_NAM(I3),EDIT_NAM(I3),LN2) S_TMP(LN+1:LN+LN2)=EDIT_NAM(I3)(1:LN2) LN=LN+LN2 IF(K.EQ.0)THEN I2=0 ELSE GOTO (2145,2141,2142,2143), EDIT_ARG(I3)+1 2141 CALL SYS$FAO('!_!UB',LN2,S_TMP(LN+1:), + %VAL(I2.AND.'F'X)) LN=LN+LN2 GOTO 2145 2142 CALL COPY_BYTE(ADDR,I3) ADDR=ADDR+1 CALL SYS$FAO('!_!UB',LN2,S_TMP(LN+1:),%VAL(I3)) LN=LN+LN2 GOTO 2145 2143 CALL COPY_BYTE(ADDR,I3) ADDR=ADDR+1 IF(I3.GE.'20'X.AND.I3.LE.'7E'X.AND. + I3.NE.'22'X)THEN CALL SYS$FAO('!_"!AD"',LN2,S_TMP(LN+1:),%VAL(1),I3) LN=LN+LN2 ELSE S_TMP(LN+1:)=CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I2,S_TMP(LN+4:LN+5),%VAL(8)) LN=LN+5 ENDIF GOTO 2145 ENDIF GOTO 2145 ELSE I3=I3+1 ENDIF ENDDO 2145 CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDDO GOTO 2900 C C handler for octaword type C 2150 DO I3=1,4 CALL COPY_LONG(ADDR,I_FLT(I3)) ADDR=ADDR+4 ENDDO S_TMP=CHAR(9)//'.OCTA'//CHAR(9)//'^X' CALL OTS$CVT_L_TZ(I_FLT(4),S_TMP(10:17),%VAL(8)) CALL OTS$CVT_L_TZ(I_FLT(3),S_TMP(18:25),%VAL(8)) CALL OTS$CVT_L_TZ(I_FLT(2),S_TMP(26:33),%VAL(8)) CALL OTS$CVT_L_TZ(I_FLT(1),S_TMP(34:41),%VAL(8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:41)) GOTO 2900 C C handler for extended data structures C 2190 CALL EXTENDED_DATA_PASS2(ADDR,J) GOTO 2900 C C handler for transfer vectors C 2200 CALL LIB$SIGNAL(DISM__CORDTSTRUC) GOTO 2900 C C handler for RMS data structures C 2210 I2=0 I3=0 CALL COPY_BYTE(ADDR,I2) ! xxx$B_BID CALL COPY_BYTE(ADDR+1,I3) ! xxx$B_BLN IF(I2.EQ.'1'X)THEN ! RAB$C_BID CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$RAB'//CHAR(9)//'-') CALL COPY_LONG(ADDR+60,I8) ! RAB$L_FAB IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FAB='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FAB=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF CALL COPY_LONG(ADDR+48,I8) ! RAB$L_KBF IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KBF='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KBF=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF I8=0 CALL COPY_BYTE(ADDR+53,I8) ! RAB$B_KRF IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KRF=^X'// + S_TMP(1:2)//',-') ENDIF I8=0 CALL COPY_BYTE(ADDR+52,I8) ! RAB$B_KSZ IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KSZ=^X'// + S_TMP(1:2)//',-') ENDIF I8=0 CALL COPY_BYTE(ADDR+54,I8) ! RAB$B_MBF IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'MBF=^X'// + S_TMP(1:2)//',-') ENDIF I8=0 CALL COPY_BYTE(ADDR+55,I8) ! RAB$B_MBC IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'MBC=^X'// + S_TMP(1:2)//',-') ENDIF I8=0 CALL COPY_BYTE(ADDR+30,I8) ! RAB$B_RAC IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RAC=^X'// + S_TMP(1:2)//',-') ENDIF CALL COPY_LONG(ADDR+40,I8) ! RAB$L_RBF IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RBF='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RBF=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF CALL COPY_LONG(ADDR+44,I8) ! RAB$L_RHB IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RHB='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RHB=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF CALL COPY_LONG(ADDR+8,I8) ! RAB$L_ROP IF(I8.NE.0) THEN S_TMP=CHAR(9)//CHAR(9)//'ROP=<' LN=7 DO I9=0,31 IF((I8.AND.JISHFT(1,I9)).NE.0)THEN S_TMP(LN+1:)=C_ROP_CODES(I9)//',' LN=LN+4 ENDIF ENDDO S_TMP(LN:LN)='>,-' CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2)) ENDIF I8=0 CALL COPY_WORD(ADDR+34,I8) ! RAB$W_RSZ IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:4),%VAL(4)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSZ=^X'// + S_TMP(1:4)//',-') ENDIF I8=0 CALL COPY_BYTE(ADDR+31,I8) ! RAB$B_TMO IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'TMO=^X'// + S_TMP(1:2)//',-') ENDIF CALL COPY_LONG(ADDR+36,I8) ! RAB$L_UBF IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'UBF='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'UBF=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF I8=0 CALL COPY_WORD(ADDR+32,I8) ! RAB$W_USZ IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:4),%VAL(4)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'USZ=^X'// + S_TMP(1:4)//',-') ENDIF CALL COPY_LONG(ADDR+64,I8) ! RAB$L_XAB IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF CALL COPY_LONG(ADDR+24,I8) ! RAB$L_CTX K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX='// + SYM_NAM(K)(1:LN)) ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX=^X'// + S_TMP(1:8)) ENDIF ELSEIF(I2.EQ.'2'X)THEN ! NAM$C_BID CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$NAM'//CHAR(9)//'-') I8=0 CALL COPY_BYTE(ADDR+2,I8) ! NAM$B_RSS IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSS=^X'// + S_TMP(1:2)//',-') ENDIF CALL COPY_LONG(ADDR+4,I8) ! NAM$L_RSA IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSA='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSA=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF CALL COPY_LONG(ADDR+16,I8) ! NAM$L_RLF IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RLF='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RLF=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF I8=0 CALL COPY_BYTE(ADDR+10,I8) ! NAM$B_ESS IF(I8.NE.0) THEN CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ESS=^X'// + S_TMP(1:2)//',-') ENDIF CALL COPY_LONG(ADDR+12,I8) ! NAM$L_ESA IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ESA='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ESA=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF I8=0 CALL COPY_BYTE(ADDR+8,I8) ! NAM$B_NOP CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NOP=^X'// + S_TMP(1:2)) ELSEIF(I2.EQ.'3'X)THEN ! FAB$C_BID CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$FAB'//CHAR(9)//'-') CALL COPY_LONG(ADDR+16,I8) ! FAB$L_ALQ IF(I8.NE.0) THEN CALL SYS$FAO('!_!_ALQ=!UL,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF I8=0 CALL COPY_BYTE(ADDR+62,I8) ! FAB$B_BKS IF(I8.NE.0) THEN CALL SYS$FAO('!_!_BKS=!UB,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF I8=0 CALL COPY_WORD(ADDR+20,I8) ! FAB$W_DEQ IF(I8.NE.0) THEN CALL SYS$FAO('!_!_DEQ=!UW,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF CALL COPY_LONG(ADDR+48,I8) ! FAB$L_DNA IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'DNA='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'DNA=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF I8=0 CALL COPY_BYTE(ADDR+53,I8) ! FAB$B_DNS IF(I8.NE.0) THEN CALL SYS$FAO('!_!_DNS=!UB,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF I8=0 CALL COPY_BYTE(ADDR+22,I8) ! FAB$B_FAC IF(I8.NE.0) THEN S_TMP=CHAR(9)//CHAR(9)//'FAC=<' LN=7 DO I9=0,7 IF((I8.AND.JISHFT(1,I9)).NE.0)THEN S_TMP(LN+1:)=C_FAB_FAC_CODES(I9)//',' LN=LN+4 ENDIF ENDDO S_TMP(LN:LN)='>,-' CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2)) ENDIF CALL COPY_LONG(ADDR+44,I8) ! FAB$L_FNA IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FNA='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FNA=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF I8=0 CALL COPY_BYTE(ADDR+52,I8) ! FAB$B_FNS IF(I8.NE.0) THEN CALL SYS$FAO('!_!_FNS=!UB,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF CALL COPY_LONG(ADDR+4,I8) ! FAB$L_FOP IF(I8.NE.0) THEN S_TMP=CHAR(9)//CHAR(9)//'FOP=<' LN=7 DO I9=0,30 IF((I8.AND.JISHFT(1,I9)).NE.0)THEN S_TMP(LN+1:)=C_FAB_FOP_CODES(I9)//',' LN=LN+4 ENDIF ENDDO S_TMP(LN:LN)='>,-' CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2)) ENDIF I8=0 CALL COPY_BYTE(ADDR+63,I8) ! FAB$B_FSZ IF(I8.NE.0) THEN CALL SYS$FAO('!_!_FSZ=!UB,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF I8=0 CALL COPY_WORD(ADDR+72,I8) ! FAB$W_GBC IF(I8.NE.0) THEN CALL SYS$FAO('!_!_GBC=!UW,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF CALL COPY_LONG(ADDR+56,I8) ! FAB$L_MRN IF(I8.NE.0) THEN CALL SYS$FAO('!_!_MRN=!UL,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF I8=0 CALL COPY_WORD(ADDR+54,I8) ! FAB$W_MRS IF(I8.NE.0) THEN CALL SYS$FAO('!_!_MRS=!UW,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF CALL COPY_LONG(ADDR+40,I8) ! FAB$L_NAM IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NAM='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NAM=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF I8=0 CALL COPY_BYTE(ADDR+29,I8) ! FAB$B_ORG IF(I8.EQ.0) THEN CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=SEQ,-') ELSEIF(I8.EQ.16) THEN CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=REL,-') ELSEIF(I8.EQ.32) THEN CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=IDX,-') ELSEIF(I8.EQ.48) THEN CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=HSH,-') ENDIF I8=0 CALL COPY_BYTE(ADDR+30,I8) ! FAB$B_RAT IF(I8.NE.0) THEN S_TMP=CHAR(9)//CHAR(9)//'RAT=<' LN=7 DO I9=0,3 IF((I8.AND.JISHFT(1,I9)).NE.0)THEN S_TMP(LN+1:)=C_FAB_RAT_CODES(I9)//',' LN=LN+4 ENDIF ENDDO S_TMP(LN:LN+2)='>,-' CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2)) ENDIF I8=0 CALL COPY_BYTE(ADDR+31,I8) ! FAB$B_RFM IF(I8.GT.0.AND.I8.LE.6)THEN CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RFM='// + C_FAB_RFM_CODES(I8)//',-') ENDIF I8=0 CALL COPY_BYTE(ADDR+28,I8) ! FAB$B_RTV IF(I8.NE.0) THEN CALL SYS$FAO('!_!_RTV=!UB,-',LN,S_TMP,%VAL(I8)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ENDIF I8=0 CALL COPY_BYTE(ADDR+23,I8) ! FAB$B_SHR IF(I8.NE.0) THEN S_TMP=CHAR(9)//CHAR(9)//'SHR=<' LN=7 DO I9=0,7 IF((I8.AND.JISHFT(1,I9)).NE.0)THEN S_TMP(LN+1:)=C_FAB_SHR_CODES(I9)//',' LN=LN+4 ENDIF ENDDO S_TMP(LN:LN)='>,-' CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2)) ENDIF CALL COPY_LONG(ADDR+36,I8) ! FAB$L_XAB IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF CALL COPY_LONG(ADDR+24,I8) ! FAB$L_CTX K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX='// + SYM_NAM(K)(1:LN)) ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX=^X'// + S_TMP(1:8)) ENDIF ELSEIF(I2.EQ.'12'X)THEN ! XAB$C_DAT CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABDAT'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)) ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)) ENDIF ELSEIF(I2.EQ.'13'X)THEN ! XAB$C_PRO CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABPRO'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'14'X)THEN ! XAB$C_ALL CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABALL'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'15'X)THEN ! XAB$C_KEY CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABKEY'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'16'X)THEN ! XAB$C_SUM CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABSUM'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'1D'X)THEN ! XAB$C_FHC CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABFHC'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'1E'X)THEN ! XAB$C_RDT CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABRDT'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'1F'X)THEN ! XAB$C_TRM CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABTRM'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'20'X)THEN ! XAB$C_CXF CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABCXF'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'21'X)THEN ! XAB$C_CXR CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABCXR'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'22'X)THEN ! XAB$C_JNL CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABJNL'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ELSEIF(I2.EQ.'23'X)THEN ! XAB$C_RU CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABRU'//CHAR(9)//'-') CALL COPY_LONG(ADDR+4,I8) ! XAB$L_NXT IF(I8.NE.0) THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='// + SYM_NAM(K)(1:LN)//',-') ELSE CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8)) CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'// + S_TMP(1:8)//',-') ENDIF ENDIF ENDIF ADDR=ADDR+I3 GOTO 2900 C C handler for FORTRAN precompiled FORMAT statement C 2220 I2=0 DO WHILE (I2.NE.4) ! loop until end of format statement I2=0 CALL COPY_BYTE(ADDR,I2) ADDR=ADDR+1 I3=0 IF((I2.AND.'80'X).NE.0)THEN ! if X bit set CALL COPY_BYTE(ADDR,I3) ! get representation size byte ADDR=ADDR+1 ENDIF GOTO (22200,22201,22202,22203,22204,22205,22206,22207, + 22298,22209,22210,22211,22212,22213,22214,22215, + 22216,22217,22218,22219,22220,22221,22222,22223, + 22224,22225,22226,22227,22228,22298,22230,22231, + 22232,22233,22234,22235,22298,22298,22298,22298, + 22298,22241,22242,22243,22244,22245,22298,22298, + 22298,22298,22250,22251,22252,22253), (I2.AND.'7F'X)+1 22200 WRITE(2, +'(A1,5H.BYTE,A1,2H^X,Z2.2,2A1,''; format syntax error'')') + TAB, TAB, I2, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB 92220 FORMAT(A1,'.BYTE',A1,'^X',Z2.2,2A1,'; RS/S/VFEM byte') ENDIF GOTO 22299 22201 WRITE(2, +'(A1,5H.BYTE,A1,''1'',2A1,''; ( format reversion point'')') + TAB, TAB, TAB, TAB GOTO 22299 22202 WRITE(2, +'(A1,5H.BYTE,A1,1H2,2A1,''; n( left paren, repeat group'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22203 WRITE(2, +'(A1,5H.BYTE,A1,1H3,2A1,''; ) right paren, repeat group'')') + TAB, TAB, TAB, TAB GOTO 22299 22204 WRITE(2, +'(A1,5H.BYTE,A1,1H4,2A1,''; ) end of format'')') + TAB, TAB, TAB, TAB GOTO 22299 22205 WRITE(2, +'(A1,5H.BYTE,A1,1H5,2A1,''; / record separator'')') + TAB, TAB, TAB, TAB GOTO 22299 22206 WRITE(2, +'(A1,5H.BYTE,A1,1H6,2A1,''; $ terminal I/O'')') + TAB, TAB, TAB, TAB GOTO 22299 22207 WRITE(2, +'(A1,5H.BYTE,A1,1H7,2A1,''; : terminate if end of list'')') + TAB, TAB, TAB, TAB GOTO 22299 22209 WRITE(2, +'(A1,5H.BYTE,A1,1H9,2A1,''; S default optional plus sign'')') + TAB, TAB, TAB, TAB GOTO 22299 22210 WRITE(2, +'(A1,5H.BYTE,A1,2H10,2A1,''; SP force optional plus sign'')') + TAB, TAB, TAB, TAB GOTO 22299 22211 WRITE(2, +'(A1,5H.BYTE,A1,2H11,2A1,''; SS omit optional plus sign'')') + TAB, TAB, TAB, TAB GOTO 22299 22212 WRITE(2, +'(A1,5H.BYTE,A1,2H12,2A1,''; sP signed scale factor'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF IF((I3.AND.'40'X).NE.0)THEN ! if VFEM W bit set CALL COPY_LONG(ADDR,I9) ! get VFE address ADDR=ADDR+4 I9=I9+ADDR WRITE(2, +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE scale factor'')') + TAB, TAB, I9, TAB, TAB ELSE IF((I3.AND.'4'X).EQ.0)THEN CALL COPY_BYTE(ADDR,REC_TYP) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; scale factor'')') + TAB, TAB, REC_TYP, TAB, TAB ELSE CALL COPY_WORD(ADDR,LN) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; scale factor'')') + TAB, TAB, LN, TAB, TAB ENDIF ENDIF GOTO 22299 22213 WRITE(2, +'(A1,5H.BYTE,A1,2H13,2A1,''; Tn tab set'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF IF((I3.AND.'40'X).NE.0)THEN ! if VFEM W bit set CALL COPY_LONG(ADDR,I9) ! get VFE address ADDR=ADDR+4 I9=I9+ADDR WRITE(2, +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE tab position'')') + TAB, TAB, I9, TAB, TAB ELSE I9=0 IF((I3.AND.'4'X).EQ.0)THEN CALL COPY_BYTE(ADDR,I9) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; tab position'')') + TAB, TAB, I9, TAB, TAB ELSE CALL COPY_WORD(ADDR,I9) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; tab position'')') + TAB, TAB, I9, TAB, TAB ENDIF ENDIF GOTO 22299 22214 WRITE(2, +'(A1,5H.BYTE,A1,2H14,2A1,''; nX (obsolete)'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF IF((I3.AND.'40'X).NE.0)THEN ! if VFEM W bit set CALL COPY_LONG(ADDR,I9) ! get VFE address ADDR=ADDR+4 I9=I9+ADDR WRITE(2, +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE offset'')') + TAB, TAB, I9, TAB, TAB ELSE I9=0 IF((I3.AND.'4'X).EQ.0)THEN CALL COPY_BYTE(ADDR,I9) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; offset'')') + TAB, TAB, I9, TAB, TAB ELSE CALL COPY_WORD(ADDR,I9) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; offset'')') + TAB, TAB, I9, TAB, TAB ENDIF ENDIF GOTO 22299 22215 WRITE(2, +'(A1,5H.BYTE,A1,2H15,2A1,''; nHc1c2...cn Hollerith text'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) I9=0 IF((I3.AND.'4'X).EQ.0)THEN CALL COPY_BYTE(ADDR,I9) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I5,2A1,''; length of string'')') + TAB, TAB, I9, TAB, TAB ELSE CALL COPY_WORD(ADDR,I9) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; length of string'')') + TAB, TAB, I9, TAB, TAB ENDIF DO I8=1,I9 CALL COPY_BYTE(ADDR,%REF(S_TMP(I8:I8))) ADDR=ADDR+1 ENDDO K=STR$FIND_FIRST_NOT_IN_SET(STR_DELIM,S_TMP(1:I9)) CALL SYS$FAO('!_.ASCII!_!AS!AD!AS',LN,CMD_LIN,STR_DELIM(K:K), + %VAL(I9),%REF(S_TMP), + STR_DELIM(K:K)) WRITE(2,'(A)') CMD_LIN(1:LN) GOTO 22299 22216 WRITE(2, +'(A1,5H.BYTE,A1,2H16,2A1,''; BN blanks are nulls'')') + TAB, TAB, TAB, TAB GOTO 22299 22217 WRITE(2, +'(A1,5H.BYTE,A1,2H17,2A1,''; BZ blanks are zeros'')') + TAB, TAB, TAB, TAB GOTO 22299 22218 WRITE(2,'(A1,5H.BYTE,A1,2H18,2A1,''; TLc'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF IF((I3.AND.'40'X).NE.0)THEN ! if VFEM W bit set CALL COPY_LONG(ADDR,I9) ! get VFE address ADDR=ADDR+4 I9=I9+ADDR WRITE(2, +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE offset'')') + TAB, TAB, I9, TAB, TAB ELSE I9=0 IF((I3.AND.'4'X).EQ.0)THEN CALL COPY_BYTE(ADDR,I9) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; offset'')') + TAB, TAB, I9, TAB, TAB ELSE CALL COPY_WORD(ADDR,I9) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; offset'')') + TAB, TAB, I9, TAB, TAB ENDIF ENDIF GOTO 22299 22219 WRITE(2,'(A1,5H.BYTE,A1,2H19,2A1,''; TRc'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF IF((I3.AND.'40'X).NE.0)THEN ! if VFEM W bit set CALL COPY_LONG(ADDR,I9) ! get VFE address ADDR=ADDR+4 I9=I9+ADDR WRITE(2, +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE offset'')') + TAB, TAB, I9, TAB, TAB ELSE I9=0 IF((I3.AND.'4'X).EQ.0)THEN CALL COPY_BYTE(ADDR,I9) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; offset'')') + TAB, TAB, I9, TAB, TAB ELSE CALL COPY_WORD(ADDR,I9) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; offset'')') + TAB, TAB, I9, TAB, TAB ENDIF ENDIF GOTO 22299 22220 WRITE(2, +'(A1,5H.BYTE,A1,2H20,2A1,''; Q return remaining record len'')') + TAB, TAB, TAB, TAB GOTO 22299 22221 WRITE(2,'(A1,5H.BYTE,A1,2H21,2A1,''; nAw'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) GOTO 22299 22222 WRITE(2,'(A1,5H.BYTE,A1,2H22,2A1,''; nLw'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) GOTO 22299 22223 WRITE(2,'(A1,5H.BYTE,A1,2H23,2A1,''; nOw'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) GOTO 22299 22224 WRITE(2,'(A1,5H.BYTE,A1,2H24,2A1,''; nIw'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) GOTO 22299 22225 WRITE(2,'(A1,5H.BYTE,A1,2H25,2A1,''; nZw'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) GOTO 22299 22226 WRITE(2,'(A1,5H.BYTE,A1,2H26,2A1,''; nOw.d'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) GOTO 22299 22227 WRITE(2,'(A1,5H.BYTE,A1,2H27,2A1,''; nIw.d'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) GOTO 22299 22228 WRITE(2,'(A1,5H.BYTE,A1,2H28,2A1,''; nZw.d'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) GOTO 22299 22230 WRITE(2,'(A1,5H.BYTE,A1,2H30,2A1,''; nFw.d'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) GOTO 22299 22231 WRITE(2,'(A1,5H.BYTE,A1,2H31,2A1,''; nEw.d'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) GOTO 22299 22232 WRITE(2,'(A1,5H.BYTE,A1,2H32,2A1,''; nGw.d'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) GOTO 22299 22233 WRITE(2,'(A1,5H.BYTE,A1,2H33,2A1,''; nDw.d'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) GOTO 22299 22234 WRITE(2,'(A1,5H.BYTE,A1,2H34,2A1,''; nEw.d.e'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) CALL WRITE_FORMAT_EXPONENT(ADDR,I3) GOTO 22299 22235 WRITE(2,'(A1,5H.BYTE,A1,2H35,2A1,''; nGw.d.e'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) CALL WRITE_FORMAT_WIDTH(ADDR,I3) CALL WRITE_FORMAT_MANTISSA(ADDR,I3) CALL WRITE_FORMAT_EXPONENT(ADDR,I3) GOTO 22299 22241 WRITE(2, +'(A1,5H.BYTE,A1,2H41,2A1,''; nA default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22242 WRITE(2, +'(A1,5H.BYTE,A1,2H42,2A1,''; nL default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22243 WRITE(2, +'(A1,5H.BYTE,A1,2H43,2A1,''; nO default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22244 WRITE(2, +'(A1,5H.BYTE,A1,2H44,2A1,''; nI default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22245 WRITE(2, +'(A1,5H.BYTE,A1,2H45,2A1,''; nZ default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22250 WRITE(2, +'(A1,5H.BYTE,A1,2H50,2A1,''; nF default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22251 WRITE(2, +'(A1,5H.BYTE,A1,2H51,2A1,''; nE default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22252 WRITE(2, +'(A1,5H.BYTE,A1,2H52,2A1,''; nG default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22253 WRITE(2, +'(A1,5H.BYTE,A1,2H53,2A1,''; nD default format'')') + TAB, TAB, TAB, TAB IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF CALL WRITE_FORMAT_REPEAT(ADDR,I3) GOTO 22299 22298 WRITE(2,92221) TAB, TAB, I2, TAB, TAB 92221 FORMAT(A1,5H.BYTE,A1,'^X',Z2.2,2A1,'; unused format code') IF((I2.AND.'80'X).NE.0)THEN WRITE(2,92220) TAB, TAB, I3, TAB, TAB ENDIF 22299 CONTINUE ENDDO GOTO 2900 C C handler for driver prolog table (DPT) type C 2230 WRITE(2,92300) form_feed, TAB, TAB, + DPT.T_NAME(1:DPT.B_NAMELEN), TAB, TAB, TAB, TAB, + DPT.W_VERSION 92300 FORMAT(A1/ + A1,'.SBTTL',A1,A,' Driver Prologue Table'/ + ';'/ + '; Driver prologue table'/ + ';'/ + A1,'DPTAB',A1,'-',2A1,'; version',I2,' VMS') K=FIND_P2_SYMBOL(%VAL(DPT.W_SIZE)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92301) TAB, TAB, SYM_NAM(K)(1:LN) 92301 FORMAT(2A1,'END=',A,',-') WRITE(2,92302) TAB, TAB, ADAPTER_NAME(DPT.B_ADPTYPE) 92302 FORMAT(2A1,'ADAPTER=',A,',-') IF(DPT.B_FLAGS .NE.0)THEN S_TMP=' ' LN=0 IF((DPT.B_FLAGS .AND.1).NE.0)THEN S_TMP='DPT$M_SUBCNTRL' LN=14 ENDIF IF((DPT.B_FLAGS .AND.2).NE.0)THEN S_TMP='+DPT$M_SVP' LN=LN+10 ENDIF IF((DPT.B_FLAGS .AND.4).NE.0)THEN S_TMP='+DPT$M_NOUNLOAD' LN=LN+15 ENDIF IF((DPT.B_FLAGS .AND.8).NE.0)THEN S_TMP='+DPT$M_SCS' LN=LN+10 ENDIF WRITE(2,92303) TAB, TAB, S_TMP(1:LN) 92303 FORMAT(2A1,'FLAGS=',A,',-') ENDIF WRITE(2,92304) TAB, TAB, DPT.W_UCBSIZE 92304 FORMAT(2A1,'UCBSIZE=',I4,',-') IF(DPT.W_UNLOAD .NE.0)THEN K=FIND_P2_SYMBOL(%VAL(DPT.W_UNLOAD)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92305) TAB, TAB, SYM_NAM(K)(1:LN) 92305 FORMAT(2A1,'UNLOAD=',A,',-') ENDIF IF(DPT.W_MAXUNITS .NE.8)THEN WRITE(2,92306) TAB, TAB, DPT.W_MAXUNITS 92306 FORMAT(2A1,'MAXUNITS=',I5,',-') ENDIF IF(DPT.W_DEFUNITS .NE.1)THEN WRITE(2,92307) TAB, TAB, DPT.W_DEFUNITS 92307 FORMAT(2A1,'DEFUNITS=',I2,',-') ENDIF IF(DPT.W_DELIVER .NE.0)THEN K=FIND_P2_SYMBOL(%VAL(DPT.W_DELIVER)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92308) TAB, TAB, SYM_NAM(K)(1:LN) 92308 FORMAT(2A1,'DELIVER=',A,',-') ENDIF IF(DPT.W_VECTOR .NE.0)THEN K=FIND_P2_SYMBOL(%VAL(DPT.W_VECTOR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92309) TAB, TAB, SYM_NAM(K)(1:LN) 92309 FORMAT(2A1,'VECTOR=',A,',-') ENDIF WRITE(2,92310) TAB, TAB, DPT.T_NAME(1:DPT.B_NAMELEN) 92310 FORMAT(2A1,'NAME=',A) ADDR=ADDR+DPT.W_INITTAB GOTO 2900 C C handler for driver dispatch table (DDT) type C 2240 WRITE(2,92400) TAB, TAB 92400 FORMAT(';'/ + '; Driver dispatch table'/ + ';'/ + A1,'DDTAB',A1,'-') IF(DDT.L_START .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_START+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92401) TAB, TAB, SYM_NAM(K)(1:LN) 92401 FORMAT(2A1,'START=',A,',-') ENDIF IF(DDT.L_UNSOLINT .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_UNSOLINT+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92402) TAB, TAB, SYM_NAM(K)(1:LN) 92402 FORMAT(2A1,'UNSOLIC=',A,',-') ENDIF IF(DDT.L_CANCEL .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_CANCEL+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92403) TAB, TAB, SYM_NAM(K)(1:LN) 92403 FORMAT(2A1,'CANCEL=',A,',-') ENDIF IF(DDT.L_REGDUMP .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_REGDUMP+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92404) TAB, TAB, SYM_NAM(K)(1:LN) 92404 FORMAT(2A1,'REGDMP=',A,',-') ENDIF IF(DDT.W_DIAGBUF .NE.0)THEN WRITE(2,92405) TAB, TAB, DDT.W_DIAGBUF 92405 FORMAT(2A1,'DIAGBF=',I3,',-') ENDIF IF(DDT.W_ERRORBUF .NE.0)THEN WRITE(2,92406) TAB, TAB, DDT.W_ERRORBUF 92406 FORMAT(2A1,'ERLGBF=',I3,',-') ENDIF IF(DDT.L_UNITINIT .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_UNITINIT+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92407) TAB, TAB, SYM_NAM(K)(1:LN) 92407 FORMAT(2A1,'UNITINIT=',A,',-') ENDIF IF(DDT.L_ALTSTART .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_ALTSTART+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92408) TAB, TAB, SYM_NAM(K)(1:LN) 92408 FORMAT(2A1,'ALTSTART=',A,',-') ENDIF IF(DDT.L_MNTVER .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTVER+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92409) TAB, TAB, SYM_NAM(K)(1:LN) 92409 FORMAT(2A1,'MNTVER=',A,',-') ENDIF IF(DDT.L_CLONEDUCB .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_CLONEDUCB+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92410) TAB, TAB, SYM_NAM(K)(1:LN) 92410 FORMAT(2A1,'CLONEDUCB=',A,',-') ENDIF IF(DDT.L_MNTV_SSSC .GT.0.AND. + DDT.L_FDT .GE.48)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTV_SSSC+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92411) TAB, TAB, SYM_NAM(K)(1:LN) 92411 FORMAT(2A1,'MNTV_SSSC=',A,',-') ENDIF IF(DDT.L_MNTV_FOR .GT.0.AND. + DDT.L_FDT .GE.52)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTV_FOR+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92412) TAB, TAB, SYM_NAM(K)(1:LN) 92412 FORMAT(2A1,'MNTV_FOR=',A,',-') ENDIF IF(DDT.L_MNTV_SQD .GT.0.AND. + DDT.L_FDT .GE.56)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTV_SQD+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92413) TAB, TAB, SYM_NAM(K)(1:LN) 92413 FORMAT(2A1,'MNTV_SQD=',A,',-') ENDIF IF(DDT.L_FDT .GT.0)THEN K=FIND_P2_SYMBOL(%VAL(DDT.L_FDT+DDT_ADR)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92414) TAB, TAB, SYM_NAM(K)(1:LN) 92414 FORMAT(2A1,'FUNCTB=',A,',-') ENDIF ADDR=ADDR+MAX(DDT.L_FDT,44) WRITE(2,92415) TAB, TAB, DPT.T_NAME(1:2) 92415 FORMAT(2A1,'DEVNAM=',A) GOTO 2900 C C handler for driver initialization table C 2250 K=FIND_P2_SYMBOL(%VAL(ADDR)) IF(K.GT.0)THEN WRITE(2,92500) TAB, TAB 92500 FORMAT(/A1,'DPT_STORE',A1,'INIT'/) ENDIF GOTO 2261 C C handler for driver reinitialization table C 2260 K=FIND_P2_SYMBOL(%VAL(ADDR)) IF(K.GT.0)THEN WRITE(2,92600) TAB, TAB 92600 FORMAT(/A1,'DPT_STORE',A1,'REINIT'/) ENDIF 2261 I2=0 CALL COPY_BYTE(ADDR,I2) ! structure type ADDR=ADDR+1 IF(I2.EQ.0)THEN WRITE(2,92601) TAB, TAB 92601 FORMAT(/A1,'DPT_STORE',A1,'END'/) ADDR=((ADDR+3)/4)*4 ! move to next longword boundary ELSE I3=0 CALL COPY_BYTE(ADDR,I3) ! offset ADDR=ADDR+1 I9=0 CALL COPY_BYTE(ADDR,I9) ! operation ADDR=ADDR+1 I8=0 IF(I9.EQ.0)THEN CALL COPY_BYTE(ADDR,I8) ADDR=ADDR+1 WRITE(2,92602) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92602 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',B,<^X',Z2.2,'>') ELSEIF(I9.EQ.1)THEN CALL COPY_WORD(ADDR,I8) ADDR=ADDR+2 WRITE(2,92603) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92603 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',W,<^X',Z4.4,'>') ELSEIF(I9.EQ.2)THEN CALL COPY_WORD(ADDR,I8) ADDR=ADDR+2 K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92604) TAB, TAB, BLOCK_TYPE(I2), I3, SYM_NAM(K)(1:LN) 92604 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',D,',A) ELSE WRITE(2,92606) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92606 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',D,<^X',Z4.4,'>') ENDIF ELSE CALL COPY_LONG(ADDR,I8) ADDR=ADDR+4 IF(I9.EQ.3)THEN WRITE(2,92605) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92605 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',L,<^X',Z8.8,'>') ELSEIF(I9.EQ.'80'X)THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92607) TAB, TAB, BLOCK_TYPE(I2), I3, + SYM_NAM(K)(1:LN) 92607 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@B,',A) ELSE WRITE(2,92608) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92608 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@B,<^X',Z8.8,'>') ENDIF ELSEIF(I9.EQ.'81'X)THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92609) TAB, TAB, BLOCK_TYPE(I2), I3, + SYM_NAM(K)(1:LN) 92609 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@W,',A) ELSE WRITE(2,92610) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92610 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@W,<^X',Z8.8,'>') ENDIF ELSEIF(I9.EQ.'82'X)THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92611) TAB, TAB, BLOCK_TYPE(I2), I3, + SYM_NAM(K)(1:LN) 92611 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@D,',A) ELSE WRITE(2,92612) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92612 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@D,<^X',Z8.8,'>') ENDIF ELSEIF(I9.EQ.'83'X)THEN K=FIND_P2_SYMBOL(%VAL(I8)) IF(K.GT.0)THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92613) TAB, TAB, BLOCK_TYPE(I2), I3, + SYM_NAM(K)(1:LN) 92613 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@L,',A) ELSE WRITE(2,92614) TAB, TAB, BLOCK_TYPE(I2), I3, I8 92614 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@L,<^X',Z8.8,'>') ENDIF ELSEIF((I9.AND.'7F'X).EQ.4)THEN LN=0 CALL COPY_BYTE(ADDR,LN) ADDR=ADDR+1 K=0 CALL COPY_BYTE(ADDR,K) ADDR=ADDR+1 IF((I9.AND.'80'X).NE.0)THEN WRITE(2,92615) TAB, TAB, BLOCK_TYPE(I2), I3, I8, LN, K 92615 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@V,<^X',Z8.8, + '>,',I2,',',I2) ELSE WRITE(2,92616) TAB, TAB, BLOCK_TYPE(I2), I3, I8, LN, K 92616 FORMAT(A1,'DPT_STORE',A1,A,',',I3,',V,<^X',Z8.8, + '>,',I2,',',I2) ENDIF ELSE WRITE(2,92617) TAB, TAB, BLOCK_TYPE(I2), I3, I9 92617 FORMAT(A1,'DPT_STORE',A1,A,',',I3, + ',;**** unknown op: ',Z2.2) ENDIF ENDIF ENDIF GOTO 2900 C C handler for function decision table (FDT) type C 2270 DO I2=1,2 CALL COPY_LONG(ADDR,I_FLT(1)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I_FLT(2)) ADDR=ADDR+4 WRITE(2,92700) TAB, TAB 92700 FORMAT(A1,'FUNCTAB',A1,',-') CALL BUILD_IO_LIST(I_FLT,S_TMP,LN,LN2) I3=INDEX(S_TMP(1:LN),',') DO WHILE (I3.GT.0) WRITE(2,92701) TAB, TAB, S_TMP(1:I3) 92701 FORMAT(2A1,A,'-') S_TMP=S_TMP(I3+1:LN) LN=LN-I3 I3=INDEX(S_TMP(1:LN),',') ENDDO WRITE(2,92702) TAB, TAB, S_TMP(1:LN) 92702 FORMAT(2A1,A/) ENDDO I9=DDT.W_FDTSIZE-16 DO WHILE (I9.GT.0) CALL COPY_LONG(ADDR,I_FLT(1)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I_FLT(2)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I_FLT(3)) ADDR=ADDR+4 I9=I9-12 IF(I_FLT(3).GT.0)THEN K=FIND_P2_SYMBOL(%VAL(I_FLT(3)+ADDR-12)) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92703) TAB, TAB, SYM_NAM(K)(1:LN) 92703 FORMAT(A1,'FUNCTAB',A1,A,',-') ELSE K=FIND_P2_SYMBOL(%VAL(I_FLT(3))) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,92704) TAB, TAB, SYM_NAM(K)(1:LN) 92704 FORMAT(A1,'FUNCTAB',A1,'+',A,',-') ENDIF CALL BUILD_IO_LIST(I_FLT,S_TMP,LN,LN2) I3=INDEX(S_TMP(1:LN),',') DO WHILE (I3.GT.0) WRITE(2,92701) TAB, TAB, S_TMP(1:I3) S_TMP=S_TMP(I3+1:LN) LN=LN-I3 I3=INDEX(S_TMP(1:LN),',') ENDDO WRITE(2,92702) TAB, TAB, S_TMP(1:LN) ENDDO GOTO 2900 C 2899 CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) 2900 CONTINUE C ENDIF ENDDO GOTO 5000 ! end of private section handler C C begin demand zero section handler C 3000 DO WHILE (ADDR.LE.ISD_PGEND(I)) C C find the first symbol in symbol table equal to or greater than current C address C DO I2=1,SYM_TBL_PTR IF(SYM_VAL(I2).GE.ADDR)THEN K=I2 GOTO 3008 ENDIF ENDDO 3008 J=K I2=MIN(SYM_VAL(J),ISD_PGEND(I)+1)-ADDR IF(SYM_VAL(J).EQ.ADDR)THEN CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN) LLV_CODEMODE=.FALSE. ! switch to data mode CALL WRITE_OUTPUT_TEXT(SYM_NAM(J)(1:LN)//':') I2=MIN(SYM_VAL(J+1),ISD_PGEND(I)+1)-SYM_VAL(J) ELSE J=J-1 ENDIF C C extract data type code from last symbol type C DO I9=27,3,-1 IF((SYM_TYP(J).AND.JISHFT(1,I9)).NE.0)THEN K=I9-2 GOTO 3029 ENDIF ENDDO 3029 I3=I2/DTYP_SIZE(K) IF(I3.EQ.0)THEN I3=I2 K=1 ELSE I2=I3*DTYP_SIZE(K) ENDIF C C generate the output text C CALL SYS$FAO('!_.BLK!AS!_!UL',LN,S_TMP,%DESCR(DTYP_C(K)),%VAL(I3)) CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN)) ADDR=ADDR+I2 ENDDO GOTO 5000 ! end of demand zero section handler C C begin shareable section handler C 4000 IF(FIXUPSEC_ISD.EQ.0)THEN DO K=1,SYM_TBL_PTR IF(SYM_VAL(K).GE.ISD_BASEVA(I).AND. + SYM_VAL(K).LE.ISD_PGEND(I))THEN CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,9400) TAB, TAB, SYM_NAM(K)(1:LN) 9400 FORMAT(A1,'.EXTRN',A1,A) ENDIF ENDDO ELSEIF(ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN-3:ISD(I).B_GBLNAMLEN) + .EQ.'_001')THEN DO K=0,ISD(FIXUPSEC_ISD).W_PAGCNT-1 READ (1,REC=ISD(FIXUPSEC_ISD).L_VBN+K) + (HDR_BUF(J),J=I*512,(K+1)*512-1) ENDDO K=1 DO WHILE (K.LE.IAF.L_SHRIMGCNT .AND. + ISD(I).T_GBLNAM(1:ISD(I).B_GBLNAMLEN-4).NE. + FIX_SHL(K).T_IMGNAM(1:FIX_SHL(K).B_IMGNAMLEN)) K=K+1 ENDDO IF(IAF.L_G_FIXOFF .NE.0)THEN J=IAF.L_G_FIXOFF OFFSET_VEC(0)=-1 OFFSET_VEC(1)=-1 DO WHILE (OFFSET_VEC(0).NE.0.AND. + OFFSET_VEC(1).NE.K) CALL LIB$MOVC3(8,HDR_BUF(J),OFFSET_VEC) J=J+8+4*OFFSET_VEC(0) ENDDO IF(OFFSET_VEC(0).NE.0)THEN J=J-(4*OFFSET_VEC(0))+ISD_BASEVA(FIXUPSEC_ISD) K=FIND_P2_SYMBOL(%VAL(J)) DO I2=1,OFFSET_VEC(0) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN) WRITE(2,9400) TAB, TAB, SYM_NAM(K)(1:LN) K=K+1 ENDDO ENDIF ENDIF ENDIF GOTO 5000 ! end of shareable section handler C C begin fixup vector section handler C 4500 CUR_VBN=ISD(FIXUPSEC_ISD).L_VBN READ(1,REC=CUR_VBN) REC_BUF CUR_VA=ISD_BASEVA(FIXUPSEC_ISD) WRITE (2,9451) TAB, IAF.W_FLAGS, TAB, IAF.L_SHRIMGCNT, + TAB, IAF.L_SHREXTRA 9451 FORMAT('; fix-up section:'/ + '; fixed information:'/ + ';',A1,' flags: %X''',Z4.4,''''/ + ';',A1,' shareable image count:',I2/ + ';',A1,' extra image count:',I2) IF(IAF.L_SHRIMGCNT.GT.1)THEN WRITE(2,9452) TAB 9452 FORMAT(';'/ + '; shareable image list:'/ + ';',A1,' 0) this image') DO K=1,IAF.L_SHRIMGCNT-1 IF(FIX_SHL(K).L_BASEVA .NE.0)THEN WRITE(2,9453) TAB, K, FIX_SHL(K).T_IMGNAM(1: + FIX_SHL(K).B_IMGNAMLEN), + FIX_SHL(K).L_BASEVA 9453 FORMAT(';',A1,' ',I3,') ',A,' based at %X''',Z8.8,'''') ELSE WRITE(2,9454) TAB, K, FIX_SHL(K).T_IMGNAM(1: + FIX_SHL(K).B_IMGNAMLEN) 9454 FORMAT(';',A1,' ',I3,') ',A) ENDIF ENDDO ENDIF IF(IAF.L_G_FIXOFF .NE.0)THEN WRITE(2,9460) 9460 FORMAT(';'/ + '; G^ reference fixups') K=IAF.L_G_FIXOFF+ISD_BASEVA(FIXUPSEC_ISD) CALL COPY_LONG(K,I2) DO WHILE (I2.NE.0) K=K+4 CALL COPY_LONG(K,I3) K=K+4 WRITE(2,9455) TAB, I2, I3, + FIX_SHL(I3).T_IMGNAM(1:FIX_SHL(I3).B_IMGNAMLEN) 9455 FORMAT(';'/ + ';',A1,I4,' references to image',I2,' (',A,'):') DO I9=1,I2,4 DO I3=0,MIN(3,I2-I9) CALL COPY_LONG(K,I_FLT(I3+1)) K=K+4 ENDDO WRITE(2,9456) TAB, (I_FLT(I3+1),I3=0,MIN(3,I2-I9)) 9456 FORMAT(';',A1,' ',4(3X,Z8.8:)) ENDDO CALL COPY_LONG(K,I2) ENDDO ENDIF IF(IAF.L_DOTADROFF .NE.0)THEN WRITE(2,9457) ISD_BASEVA(1) 9457 FORMAT(';'/ + '; .ADDRESS reference fixups (relative to %X''',Z8.8,''')') K=IAF.L_DOTADROFF+ISD_BASEVA(FIXUPSEC_ISD) CALL COPY_LONG(K,I2) DO WHILE (I2.NE.0) K=K+4 CALL COPY_LONG(K,I3) K=K+4 WRITE(2,9455) TAB, I2, I3, + FIX_SHL(I3).T_IMGNAM(1:FIX_SHL(I3).B_IMGNAMLEN) DO I9=1,I2 CALL COPY_LONG(K,I3) K=K+4 WRITE(2,9456) TAB, I3 ENDDO CALL COPY_LONG(K,I2) ENDDO ENDIF IF(IAF.L_CHGPRTOFF .NE.0)THEN K=IAF.L_CHGPRTOFF+ISD_BASEVA(FIXUPSEC_ISD) CALL COPY_LONG(K,I2) K=K+4 WRITE(2,9458) ISD_BASEVA(1) 9458 FORMAT(';'/ +'; protection change fixups (relative to %X''',Z8.8,''')'/ +';') DO ICODE=1,I2 CALL COPY_LONG(K,I3) I9=0 CALL COPY_WORD(K+4,I9) I8=0 CALL COPY_WORD(K+6,I8) K=K+8 WRITE(2,9459) TAB, I3, I9, TAB, PROT_NAME(I8) 9459 FORMAT(';',A1,' address: %X''',Z8.8,''', page count:',I4/ + ';',A1,' protection: PRT$C_',A4) ENDDO ENDIF GOTO 5000 C C begin (message) vector section handler C 4800 CUR_VBN=ISD(I).L_VBN READ(1,REC=CUR_VBN) REC_BUF CUR_VA=ISD_BASEVA(I) CALL LIB$MOVC3(32,REC_BUF(0),PLV) ! get privileged vector block IF(PLV.L_TYPE .EQ.1)THEN ! change mode vector, privileged WRITE(2,9481) PLV.L_VERSION, PLV.L_VERSION 9481 FORMAT('; Change-Mode Vector for privileged shareable image'/ + ';'/ + '; for version ',A4,' (^X',Z8.8,')'/ + ';') CALL STR$TRIM(ISD_NAM(I),ISD_NAM(I),LN) S_TMP=CHAR(9)//'.PSECT'//CHAR(9)//ISD_NAM(I)(1:LN)// + ',CON,REL,RD,LCL,VEC,' LN=LN+29 IF((ISD(I).L_FLAGS .AND.'8'X).NE.0)THEN ! ISD$M_WRT S_TMP(LN:)='WRT,' LN=LN+4 ELSE S_TMP(LN:)='NOWRT,' LN=LN+6 ENDIF IF(ISD(I).W_SIZE .LT.0)THEN S_TMP(LN:)='EXE,' LN=LN+4 ELSE S_TMP(LN:)='NOEXE,' LN=LN+6 ENDIF IF((ISD(I).L_FLAGS .AND.'200'X).EQ.0)THEN ! ISD$M_BASED S_TMP(LN:)='PIC,' ! private or shareable PIC I-sect LN=LN+4 ELSE S_TMP(LN:)='NOPIC,' LN=LN+6 ENDIF IF((ISD(I).L_FLAGS .AND.'106'X).NE.0)THEN ! ISD$M_CRF, ISD$M_DZRO, S_TMP(LN:)='NOSHR,' ! ISD$M_COPYALWAYS LN=LN+6 ELSE S_TMP(LN:)='SHR,' LN=LN+4 ENDIF S_TMP(LN:)='LONG' LN=LN+3 WRITE(2,'(A)') S_TMP(1:LN) WRITE(2,9002) WRITE(2,94811) TAB, TAB, TAB, TAB, TAB, PLV.L_VERSION, TAB 94811 FORMAT(A1,'$PLVDEF'/ + ';'/ + A1,'.LONG',A1,'PLV$C_TYP_CMOD'/ +A1,'.LONG',A1,'^X',Z8.8,A1,'; field for system version number') IF(PLV.L_KERNEL .EQ.0)THEN WRITE(2,94812) TAB, TAB, TAB, TAB, 'kernel-mode' 94812 FORMAT(A1,'.LONG',A1,'0',2A1,'; no ',A,' dispatcher vector') ELSE K=FIND_P2_SYMBOL(%VAL(PLV.L_KERNEL+8+ISD_BASEVA(I))) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2) WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'kernel-mode' 94813 FORMAT(A1,'.LONG',A1,A,'-.',A1,'; ',A,' dispatcher vector') ENDIF IF(PLV.L_EXEC .EQ.0)THEN WRITE(2,94812) TAB, TAB, TAB, TAB, 'executive-mode' ELSE K=FIND_P2_SYMBOL(%VAL(PLV.L_EXEC+12+ISD_BASEVA(I))) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2) WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'executive-mode' ENDIF IF(PLV.L_USRUNDWN .EQ.0)THEN WRITE(2,94812) TAB, TAB, TAB, TAB, 'user rundown' ELSE K=FIND_P2_SYMBOL(%VAL(PLV.L_USRUNDWN+16+ISD_BASEVA(I))) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2) WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'user rundown' ENDIF WRITE(2,94814) TAB, TAB, TAB, TAB 94814 FORMAT(A1,'.LONG',A1,'0',2A1,'; (reserved)') IF(PLV.L_RMS .EQ.0)THEN WRITE(2,94812) TAB, TAB, TAB, TAB, 'RMS' ELSE K=FIND_P2_SYMBOL(%VAL(PLV.L_RMS+24+ISD_BASEVA(I))) CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2) WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'RMS' ENDIF WRITE(2,94815) TAB, TAB, PLV.L_CHECK, TAB 94815 FORMAT(A1,'.LONG',A1,'^X',Z8.8,A1,'; address check longword') ADDR=ISD_BASEVA(I)+32 GOTO 2000 ! treat like normal I-sect now ELSEIF(PLV.L_TYPE .EQ.2)THEN ! message vector AUX_SYM_TBL(-1)=0 ADDR=ISD_BASEVA(I)+16 AUX_SYM_TBL(0)=-1 DO WHILE (AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0) AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)+1 CALL COPY_LONG(ADDR,AUX_SYM_TBL(AUX_SYM_TBL(-1))) ! get offset IF(AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0)THEN AUX_SYM_TBL(AUX_SYM_TBL(-1))=AUX_SYM_TBL(AUX_SYM_TBL(-1))+ADDR ENDIF ADDR=ADDR+4 ENDDO AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)-1 WRITE(2,9482) AUX_SYM_TBL(-1) 9482 FORMAT('; Message vector for image:'/ + '; contains',I3,' message sections') DO I2=1,AUX_SYM_TBL(-1) ADDR=AUX_SYM_TBL(I2) CALL COPY_WORD(ADDR,LN) ! get message section type ADDR=ADDR+4 CALL COPY_LONG(ADDR,I3) ! get section length ADDR=ADDR+4 IF(LN.EQ.0)THEN ! if actual definitions here CALL COPY_LONG(ADDR,I8) ! get offset to vector index I8=I8+AUX_SYM_TBL(I2) ADDR=ADDR+4 CALL COPY_LONG(ADDR,I9) ! get offset to facility name I9=I9+AUX_SYM_TBL(I2) ADDR=ADDR+4 CALL COPY_LONG(ADDR,J) ! get offset to string area J=J+AUX_SYM_TBL(I2) ADDR=ADDR+24 CALL COPY_WORD(ADDR,LN3) ! get last msg # in facility LN=LN3/8-1 WRITE(2,94821) I2, I3, LN 94821 FORMAT(';'/ + '; message section',I3,', len=',I6,' bytes,',I4,' msgs'/ + ';') CALL COPY_WORD(I9,LN2) DO K=1,LN2 CALL COPY_BYTE(I9+1+K,%REF(FACILITY_BUF(K:K))) ENDDO LN=1 S_TMP=' ' IF((FACILITY_NUMBER.AND.'800'X).EQ.0)THEN S_TMP='/SYSTEM' LN=7 ELSE S_TMP='/PREFIX='//FACILITY_NAM(1:FACILITY_NAMLEN)//'__' LN=FACILITY_NAMLEN+10 ENDIF LN2=FACILITY_NUMBER.AND..NOT.'800'X WRITE(2,94822) S_TMP(1:LN), TAB, + FACILITY_NAM(1:FACILITY_NAMLEN), LN2, TAB 94822 FORMAT('; .FACILITY',A,A1,A,',',I4/ + '; !'/ + '; .SEVERITY',A1,'WARNING') ADDR=I8+8 ! start at beginning of vector index DO WHILE (ADDR.LT.J) ! scan until end of vector index CALL COPY_LONG(ADDR,OFFSET_VEC(0)) ADDR=ADDR+4 CALL COPY_LONG(ADDR,OFFSET_VEC(1)) ADDR=ADDR+4 OFFSET_VEC(1)=OFFSET_VEC(1)+AUX_SYM_TBL(I2) CALL COPY_STR(OFFSET_VEC(1),MESSAGE_BUF) I8=ICHAR(MESSAGE_BUF(9:9)) K=INDEX(MESSAGE_BUF(11+I8:10+I8+ICHAR( + MESSAGE_BUF(10+I8:10+I8))), + '"') IF(K.EQ.0)THEN S_TMP(1:2)='""' ELSE S_TMP(1:2)='<>' ENDIF K=INDEX(MESSAGE_BUF(11+I8:10+I8+ICHAR( + MESSAGE_BUF(10+I8:10+I8))), + '!/') IF(K.EQ.0)THEN CALL SYS$FAO( +'; !AD/FAO=!UL!#!_!AS!AD!AS!_!! !XL', + LN,CMD_LIN, + %VAL(I8),%REF(MESSAGE_BUF(10:)), + %VAL(MSG_FAOCOUNT), + %VAL(-10*(MSG_USERVALUE.NE.0)),%VAL(MSG_USERVALUE), + S_TMP(1:1), + %VAL(ICHAR(MESSAGE_BUF(10+I8:10+I8))), + %REF(MESSAGE_BUF(11+I8:)), + S_TMP(2:2), + %VAL(OFFSET_VEC(0))) WRITE(2,'(A)') CMD_LIN(1:LN) ELSE CALL SYS$FAO( +'; !AD/FAO=!UL!#!_!AS!AD!AS-', + LN,CMD_LIN, + %VAL(I8),%REF(MESSAGE_BUF(10:)), + %VAL(MSG_FAOCOUNT), + %VAL(-10*(MSG_USERVALUE.NE.0)),%VAL(MSG_USERVALUE), + S_TMP(1:1), + %VAL(K+1),%REF(MESSAGE_BUF(11+I8:)), + S_TMP(2:2)) WRITE(2,'(A)') CMD_LIN(1:LN) I9=INDEX(MESSAGE_BUF(11+I8+K:10+I8+ICHAR( + MESSAGE_BUF(10+I8:10+I8))), + '!/')+K DO WHILE (I9.GT.K) CALL SYS$FAO( +';!_!_!_!AS!AD!AS-', + LN,CMD_LIN, + S_TMP(1:1), + %VAL(I9-K),%REF(MESSAGE_BUF(12+I8+K:)), + S_TMP(2:2)) WRITE(2,'(A)') CMD_LIN(1:LN) K=I9 I9=INDEX(MESSAGE_BUF(11+I8+K:10+I8+ICHAR( + MESSAGE_BUF(10+I8:10+I8))), + '!/')+K ENDDO IF(K.NE.ICHAR(MESSAGE_BUF(10+I8:10+I8)))THEN CALL SYS$FAO( +';!_!_!_!AS!AD!AS!_!! !XL', + LN,CMD_LIN, + S_TMP(1:1), + %VAL(ICHAR(MESSAGE_BUF(10+I8:10+I8))-(K+1)), + %REF(MESSAGE_BUF(12+I8+K:)), + S_TMP(2:2), + %VAL(OFFSET_VEC(0))) WRITE(2,'(A)') CMD_LIN(1:LN) ELSE CALL SYS$FAO( +';!_!_!_!_!! !XL', + LN,CMD_LIN, + %VAL(OFFSET_VEC(0))) WRITE(2,'(A)') CMD_LIN(1:LN) ENDIF ENDIF ENDDO WRITE(2,94824) 94824 FORMAT('; !'/ + '; .END') ELSEIF(LN.EQ.1)THEN ! indirect file reference LN=0 CALL COPY_BYTE(ADDR,LN) ADDR=ADDR+1 DO I9=1,LN CALL COPY_BYTE(ADDR,%REF(S_TMP(I9:I9))) ADDR=ADDR+1 ENDDO WRITE(2,94825) I2, I3, S_TMP(1:LN) 94825 FORMAT(';'/ + '; message section',I3,', len=',I4,' bytes, file=''',A,'''') ENDIF ENDDO ELSE CALL LIB$SIGNAL(DISM__UNRECVEC,%VAL(4),%VAL(I), + %VAL(ISD(I).L_VBN),%VAL(ISD_BASEVA(I)), + %VAL(PLV.L_TYPE)) ENDIF GOTO 5000 C 5000 CONTINUE ENDDO CALL LIB$REVERT C C generate a .SYM file for future usage C INQUIRE(UNIT=1,NAME=OUT_FIL) CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) I=INDEX(OUT_FIL(1:LN),']') I=I+1 J=INDEX(OUT_FIL(I:LN),'.')+I-2 OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW', + FORM='FORMATTED',CARRIAGECONTROL='LIST',BLOCKSIZE=16384, + DEFAULTFILE='.SYM',INITIALSIZE=SYM_TBL_PTR/11) DO I=1,SYM_TBL_PTR SYM_TYP(I)=SYM_TYP(I).AND..NOT.SYM_DISM CALL STR$TRIM(SYM_NAM(I),SYM_NAM(I),LN) WRITE(99,'(2(Z8.8,X),I4,X,Z8.8,X,A)') + SYM_VAL(I), SYM_TYP(I), SYM_EXT_ATTR(I), + SYM_EXT_VAL(I), SYM_NAM(I)(1:LN) ENDDO CLOSE(UNIT=99) C C generate a report file on the module and line number records C IF(MOD_TBL_PTR+LIN_TBL_PTR.GT.0)THEN INQUIRE(UNIT=1,NAME=OUT_FIL) CALL STR$TRIM(OUT_FIL,OUT_FIL,LN) I=INDEX(OUT_FIL(1:LN),']') I=I+1 J=INDEX(OUT_FIL(I:LN),'.')+I-2 OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW', + FORM='FORMATTED',CARRIAGECONTROL='LIST',BLOCKSIZE=16384, + DEFAULTFILE='.MOD_LIN', + INITIALSIZE=MOD_TBL_PTR/6+LIN_TBL_PTR/25) OLD_LINTB_PTR=1 DO I=1,MOD_TBL_PTR CALL STR$TRIM(MOD_NAM(I),MOD_NAM(I),LN) WRITE(99,9700) MOD_NAM(I)(1:LN), LANGUAGE_NAME(MOD_LNG(I)), + MOD_VERMAJ(I), MOD_VERMIN(I), MOD_START(I), + MOD_END(I) 9700 FORMAT('MODULE=',A,X,A,' V',I2.2,'.',I2.2,2Z9.8) J=OLD_LINTB_PTR DO WHILE (J.LE.LIN_TBL_PTR.AND. + LIN_ADR(J).LT.MOD_START(I)) J=J+1 ENDDO IF(J.LE.LIN_TBL_PTR)THEN DO WHILE (LIN_ADR(J).LE.MOD_END(I).AND. + J.LE.LIN_TBL_PTR) IF(LIN_STMT(J).EQ.1)THEN WRITE(99,9702) LIN_ADR(J), LIN_NUM(J) 9702 FORMAT('LINE =',Z8.8,I5) ELSE WRITE(99,9703) LIN_ADR(J), LIN_NUM(J), LIN_STMT(J) 9703 FORMAT('LINE =',Z8.8,I5,'.',I2.2) ENDIF J=J+1 ENDDO ENDIF OLD_LINTB_PTR=J ENDDO CLOSE(UNIT=99) ENDIF C C wind down the disassembler, close all files, and exit. C WRITE(2,9002) IF((IHD.L_LNKFLAGS .AND.2).NE.0)THEN WRITE(2,9990)TAB 9990 FORMAT(A1,'.END') ELSE DO I=1,3 J=1 DO WHILE (J.LE.ISD_NUM.AND. + (IHA.L_TFRADR(I) .LT.ISD_BASEVA(J).OR. + IHA.L_TFRADR(I) .GT.ISD_PGEND(J))) J=J+1 ENDDO IF(J.LE.ISD_NUM)THEN I2=1 DO WHILE (I2.LE.SYM_TBL_PTR.AND. + IHA.L_TFRADR(I) .NE.SYM_VAL(I2)) I2=I2+1 ENDDO CALL STR$TRIM(SYM_NAM(I2),SYM_NAM(I2),LN) WRITE(2,9991) TAB,TAB,SYM_NAM(I2)(1:LN) 9991 FORMAT(A1,'.END',A1,A) GOTO 999 ENDIF ENDDO ENDIF 999 CLOSE(UNIT=1) CLOSE(UNIT=2) CALL LIB$PUT_OUTPUT('Statistics:') CALL SYS$FAO( +'!_generated !UL symbols, !UL modules, !UL line numbers', +LN,S_TMP,%VAL(SYM_TBL_PTR),%VAL(MOD_TBL_PTR),%VAL(LIN_TBL_PTR)) CALL LIB$PUT_OUTPUT(S_TMP(1:LN)) CALL LIB$SHOW_TIMER() C END INTEGER*4 FUNCTION FIX_BUFR_OVRFL(SIG_ARGS,MECH_ARGS) C C this condition handler traps only for the DISM__INVBOFSET signal, and C resignals all others. If the signal occurs, the appropriate record from the C input file is read in, and the block virtual address is C adjusted to the new VBN. C IMPLICIT NONE INTEGER*4 SIG_ARGS(*),MECH_ARGS(*) EXTERNAL DISM__INVBOFSET INTEGER*4 I C INCLUDE 'DISMISDTBL.INC' INCLUDE 'DISMMISC.INC' C IF(SIG_ARGS(2).EQ.%LOC(DISM__INVBOFSET))THEN I=1 DO WHILE (I.LE.ISD_NUM) IF(ISD_BASEVA(I).LE.SIG_ARGS(4).AND. + ISD_PGEND(I).GE.SIG_ARGS(4))THEN GOTO 10 ENDIF I=I+1 ENDDO GOTO 90 10 CUR_VBN=(SIG_ARGS(4)/512)-(ISD_BASEVA(I)/512)+ISD(I).L_VBN IF(ISD(I).L_VBN .NE.0)THEN READ(1,REC=CUR_VBN) REC_BUF ELSE CALL LIB$MOVC5(0,0,0,512,REC_BUF) CUR_VBN=0 ENDIF CUR_VA=SIG_ARGS(4).AND..NOT.'1FF'X FIX_BUFR_OVRFL=1 ! return SS$_CONTINUE ELSE 90 FIX_BUFR_OVRFL=0 ! return SS$_RESIGNAL ENDIF RETURN C END INTEGER*4 FUNCTION FIX_BUF_1(SIG_ARGS,MECH_ARGS) C C this condition handler traps only for the DISM__INVBOFSET signal, and C resignals all others. If the signal occurs, the next record from the C input file is read in, the offset parameter used by the signaling C process has 512 subtracted from it, and the block virtual address is C incremented by 512. C IMPLICIT NONE BYTE REC_BUF(0:511) INTEGER*4 SIG_ARGS(*),MECH_ARGS(*),CUR_VBN,CUR_VA EXTERNAL DISM__INVBOFSET COMMON /DSK_BUF/ CUR_VBN,REC_BUF,CUR_VA C IF(SIG_ARGS(2).EQ.%LOC(DISM__INVBOFSET))THEN CUR_VBN=CUR_VBN+1 CUR_VA=CUR_VA+512 READ(1,REC=CUR_VBN) REC_BUF FIX_BUF_1=1 ! return SS$_CONTINUE ELSE FIX_BUF_1=0 ! return SS$_RESIGNAL ENDIF RETURN C END INTEGER*4 FUNCTION FIX_BUF_3(SIG_ARGS,MECH_ARGS) C C this condition handler traps only for the DISM__INVBOFSET signal, and C resignals all others. If the signal occurs, the next record from the C input file is read in, the offset parameter used by the signaling C process has 512 subtracted from it, and the block virtual address is C incremented by 512. C IMPLICIT NONE BYTE REC_BUF(0:511) INTEGER*4 SIG_ARGS(*),MECH_ARGS(*),CUR_VBN,CUR_VA EXTERNAL DISM__INVBOFSET COMMON /DSK_BUF/ CUR_VBN,REC_BUF,CUR_VA C IF(SIG_ARGS(2).EQ.%LOC(DISM__INVBOFSET))THEN CUR_VBN=CUR_VBN+1 CUR_VA=CUR_VA+512 READ(3,REC=CUR_VBN) REC_BUF FIX_BUF_3=1 ! return SS$_CONTINUE ELSE FIX_BUF_3=0 ! return SS$_RESIGNAL ENDIF RETURN C END INTEGER*4 FUNCTION WRITE_OUTPUT_TEXT(LINE) C C this procedure writes the passed string to the output file. C IMPLICIT NONE CHARACTER*(*) LINE C BYTE B_TABS(6) INTEGER*4 I CHARACTER*6 TABS EQUIVALENCE (TABS, B_TABS) DATA B_TABS/6*9/ C INCLUDE 'DISMLINTBL.INC' INCLUDE 'DISMMISC.INC' C I=OLD_LINTB_PTR DO WHILE (LIN_ADR(I).LT.CURR_ADR.AND. + I.LE.LIN_TBL_PTR) I=I+1 ENDDO OLD_LINTB_PTR=I IF(LIN_ADR(I).NE.CURR_ADR)THEN WRITE(2,'(A)')LINE ELSE IF(INDEX(LINE(2:),CHAR(9)).EQ.0)THEN I=6 ELSE I=MAX(5-(LEN(LINE)-INDEX(LINE(2:),CHAR(9))-1)/8,1) ENDIF IF(LIN_STMT(I).EQ.1)THEN WRITE(2,9000) LINE, TABS(1:I), LIN_NUM(OLD_LINTB_PTR) 9000 FORMAT(/A,A,'; ',I4.4) ELSE WRITE(2,9001) LINE, TABS(1:I), LIN_NUM(OLD_LINTB_PTR), + LIN_STMT(OLD_LINTB_PTR) 9001 FORMAT(/A,A,'; ',I4.4,'.',I2.2) ENDIF ENDIF WRITE_OUTPUT_TEXT=1 RETURN C END INTEGER*4 FUNCTION WRITE_SYM_TBL(VAL,TYP,EXT_TYP,EXT_VAL) C C This procedure checks for previous occurrences of the specified symbol C value and type pair, and then, if no previous occurrences show up, adds C the symbol entry to the end of the symbol table, raising the signal C DISM__SYMTBLOVF if the table is full. C IMPLICIT NONE INTEGER*4 VAL, TYP, EXT_TYP, EXT_VAL C INTEGER*4 I C INCLUDE 'DISMSYMTBL.INC' C EXTERNAL DISM__SYMTBLOVF C C scan through the symbol table for a previous occurrence, C I=1 DO WHILE (I.LE.SYM_TBL_PTR.AND. + SYM_VAL(I).NE.%LOC(VAL)) I=I+1 ENDDO IF(I.LE.SYM_TBL_PTR)THEN IF((SYM_TYP(I).AND.SYM_M_CODE).EQ.0.AND. + (%LOC(TYP).AND.SYM_M_CODE).NE.0)THEN SYM_FOUND_NEW_CODE=.TRUE. ENDIF SYM_TYP(I)=SYM_TYP(I).OR.%LOC(TYP) IF((%LOC(TYP).AND.SYM_D_EXTENDED).NE.0.AND. + %LOC(EXT_TYP).GE.SYM_EXT_ATTR(I).AND. + SYM_EXT_ATTR(I).NE.SYM_T_STATETBL)THEN SYM_EXT_ATTR(I)=%LOC(EXT_TYP) SYM_EXT_VAL(I)=%LOC(EXT_VAL) ENDIF ELSE C C not in table, add it (if not a table overflow) C SYM_TBL_PTR=SYM_TBL_PTR+1 IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__SYMTBLOVF) ELSE SYM_VAL(SYM_TBL_PTR)=%LOC(VAL) SYM_TYP(SYM_TBL_PTR)=%LOC(TYP) SYM_NAM(SYM_TBL_PTR)=' ' SYM_EXT_ATTR(SYM_TBL_PTR)=%LOC(EXT_TYP) SYM_EXT_VAL(SYM_TBL_PTR)=%LOC(EXT_VAL) SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X IF((%LOC(TYP).AND.SYM_M_CODE).NE.0)THEN SYM_FOUND_NEW_CODE=.TRUE. ENDIF ENDIF ENDIF C C exit with success C WRITE_SYM_TBL=1 RETURN C END SUBROUTINE EXTRACT_SYM_TBL(STR,VAL) C C This procedure extracts a symbol name from the symbol table corresponding C to the specified value, and appends the name to the passed C dynamic string. C IMPLICIT NONE INTEGER*4 STR(2), VAL ! disguise to protect integrity of dynamic descriptor C INTEGER*2 LN INTEGER*4 J C INCLUDE 'DISMSYMTBL.INC' C EXTERNAL DISM__NOSUCHSYM INTEGER*4 FIND_P2_SYMBOL EXTERNAL FIND_P2_SYMBOL C J=FIND_P2_SYMBOL(VAL) IF(J.GT.0)THEN CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN) CALL STR$APPEND(STR,SYM_NAM(J)(1:LN)) ELSE C C report error due to no match occurring C CALL LIB$SIGNAL(DISM__NOSUCHSYM,%VAL(1),%VAL(%LOC(VAL))) ENDIF C C exit C RETURN C END INTEGER*4 FUNCTION FIND_P2_SYMBOL(VAL) C C This procedure attempts to locate an entry in the symbol table that C matches the specified symbol value C IMPLICIT NONE INTEGER*4 VAL C INTEGER*4 I, J, LAST_SYM_TBL/0/, DELTA_BASE/0/ SAVE LAST_SYM_TBL, DELTA_BASE INCLUDE 'DISMSYMTBL.INC' C C scan by binary search through the symbol table looking for symbol in question C IF(SYM_TBL_PTR.NE.LAST_SYM_TBL)THEN DELTA_BASE=2**INT(LOG(FLOAT(MAX(SYM_TBL_PTR,1)))/LOG(2.0)) LAST_SYM_TBL=SYM_TBL_PTR ENDIF I=DELTA_BASE J=(SYM_TBL_PTR+1)/2 DO WHILE (I.GE.1.AND.SYM_VAL(J).NE.%LOC(VAL)) I=JISHFT(I,-1) IF(%LOC(VAL).LT.SYM_VAL(J))THEN J=MAX(J-I,1) ELSEIF(%LOC(VAL).GT.SYM_VAL(J))THEN J=MIN(J+I,SYM_TBL_PTR) ENDIF ENDDO IF(SYM_VAL(J).EQ.%LOC(VAL))THEN FIND_P2_SYMBOL=J ELSEIF(SYM_VAL(J).LT.%LOC(VAL))THEN FIND_P2_SYMBOL=-(J+1) ELSE FIND_P2_SYMBOL=-J ENDIF C RETURN C END INTEGER*4 FUNCTION GET_SYMBOL_TYPE(VAL) C C This procedure extracts the type flags for a symbol table entry. C IMPLICIT NONE INTEGER*4 VAL ! disguise to protect integrity of dynamic descriptor C INTEGER*4 I C INCLUDE 'DISMSYMTBL.INC' C INTEGER*4 FIND_P2_SYMBOL EXTERNAL FIND_P2_SYMBOL EXTERNAL DISM__NOSUCHSYM C C scan through the symbol table looking for the symbol in question C I=FIND_P2_SYMBOL(%VAL(%LOC(VAL))) IF(I.GT.0)THEN GET_SYMBOL_TYPE=SYM_TYP(I) ELSE C C report error due to no match occurring C CALL LIB$SIGNAL(DISM__NOSUCHSYM,%VAL(1),VAL) ENDIF C C exit C 99 RETURN C END SUBROUTINE NAME_SYM_TBL(REC_COUNT,OFFSET_VEC,SYM_TBL) C C This procedure will read and analyze the Object Language records from the C global symbol table areas of the input image or VMSRTL.EXE C and use the symbol names in them, where appropriate, to fill in the C symbol name fields in the symbol table. C IMPLICIT NONE BYTE REC,SUBREC INTEGER*4 OFFSET_VEC, SYM_TBL(-1:*) C CHARACTER*2048 LINE INTEGER*4 REC_COUNT, I, POS, K, I2, J C INTEGER*4 ANALYZE_SYM_REC EXTERNAL ANALYZE_SYM_REC C C read record length from input file C POS=0 DO I=1,IABS(REC_COUNT) K=0 CALL COPY_WORD(POS,K) POS=POS+2 C C if non-zero length, read rest of record C IF(K.NE.0)THEN CALL COPY_BYTE(POS,REC) POS=POS+1 CALL COPY_BYTE(POS,SUBREC) POS=POS+1 DO I2=1,K-2 CALL COPY_BYTE(POS,%REF(LINE(I2:I2))) POS=POS+1 ENDDO IF(REC_COUNT.LT.0)THEN WRITE(99) REC, SUBREC, LINE(1:K-2) ENDIF J=ANALYZE_SYM_REC(REC,SUBREC,LINE(1:MAX(K-2,1)), + OFFSET_VEC,SYM_TBL) IF(J.NE.0)GOTO 99 IF(MOD(POS,2).NE.0)POS=POS+1 ENDIF ENDDO C C exit now that entire set of records has been processed C 99 RETURN C END SUBROUTINE MAKE_MASK(LINE,VALUE,ENDPOS) C C This procedure will construct the text of a mask word, given the value of C the mask word, and a character variable to build the text in. The length C of the resulting text will be returned in ENDPOS. C C declare variables C IMPLICIT NONE CHARACTER*(*) LINE INTEGER*4 VALUE,ENDPOS C INTEGER*4 I, N, N2, J, ICODE CHARACTER*3 MASK_NAM(0:15,2) DATA MASK_NAM/'R0','R1','R2','R3','R4','R5','R6','R7','R8','R9', + 'R10','R11','AP','FP','SP','PC','R0','R1','R2','R3','R4','R5', + 'R6','R7','R8','R9','R10','R11','XX','XX','IV','DV'/ C INTEGER*4 LIB$FFS EXTERNAL LIB$FFS C C analyze the bit mask for a procedure entry point, and add text for C each set bit C ENDPOS=1 N=2 N2=0 DO I=0,15 ICODE=LIB$FFS(I,1,VALUE,J) IF(ICODE)THEN IF(N2.NE.0)THEN LINE(ENDPOS:ENDPOS)=',' ENDPOS=ENDPOS+1 ENDIF N2=1 LINE(ENDPOS:)=MASK_NAM(I,N) IF(I.EQ.10.OR.I.EQ.11)THEN ENDPOS=ENDPOS+3 ELSE ENDPOS=ENDPOS+2 ENDIF ENDIF ENDDO C C close mask C LINE(ENDPOS:ENDPOS)='>' C C exit C RETURN C END INTEGER*4 FUNCTION ANALYZE_SYM_REC(TYP,SUBTYP,RECORD, + OFFSET_VEC,SYM_TBL) C C This procedure analyzes an Object Language record and updates the symbol C table and image section descriptor table with the new names found (if C any). If an End of Module (EOM) record is read, a zero value is C returned to inform the caller that the module end has been reached. C IMPLICIT NONE C BYTE TYP,SUBTYP CHARACTER*(*) RECORD INTEGER*4 OFFSET_VEC, SYM_TBL(-1:*) C BYTE TAB/9/ CHARACTER*31 S_TMP INTEGER*4 I, J, I2, J2, K, K2, TYP_CONV(0:34) EXTERNAL DISM__UNKOBJREC,DISM__OBJSYMERR, DISM__SYMTBLOVF C INCLUDE 'DISMISDTBL.INC' INCLUDE 'DISMSYMTBL.INC' C DATA TYP_CONV ! convert from VMS DSC$K_DTYPE_xxx to DISM32 bitmasks + /SYM_SUBR,SYM_D_BYT,SYM_D_BYT,SYM_D_WRD,SYM_D_LNG,SYM_D_QUD, ! 0-5 + SYM_D_BYT,SYM_D_WRD,SYM_D_LNG,SYM_D_QUD,SYM_D_FLT,SYM_D_DFL, ! 6-11 + SYM_D_FLT,SYM_D_DFL,SYM_D_CHR,SYM_D_LSN,SYM_D_LSN,SYM_D_LSN, ! 12-17 + SYM_D_TNS,SYM_D_TNS,SYM_D_LSN,SYM_D_PDS,SYM_SUBR,SYM_PROC, ! 18-23 + SYM_D_QUD,SYM_D_OCT,SYM_D_OCT,SYM_D_GFL,SYM_D_HFL,SYM_D_GFL, ! 24-29 + SYM_D_HFL,SYM_D_WRD,SYM_D_LNG,SYM_D_LNG,SYM_D_BYT/ ! 30-34 C C select handler for record based upon record type C GOTO (100,1000,2000,3000,4000,5000,6000,7000),TYP+1 C C this is a catch-all for undefined record types. it signals a warning. C CALL LIB$SIGNAL(DISM__UNKOBJREC,%VAL(2),%VAL(TYP),%VAL(-1)) GOTO 9000 C C header record: ignore C 100 GOTO 9000 C C global symbol dictionary record: analyze and update ISD, psect, and symbol C tables accordingly C 1000 I=1 ! initialize for looping through multiple subrecords DO WHILE (I.LT.LEN(RECORD)) GOTO (1001,1100,1200,1300),SUBTYP+1 C C this is a catch-all for undefined GSD subrecord types. it signals a warning. C CALL LIB$SIGNAL(DISM__UNKOBJREC,%VAL(2),%VAL(TYP),%VAL(SUBTYP)) GOTO 9000 C C GSD p-sect definition: add this p-sect to the p-sect table C 1001 K=ICHAR(RECORD(I:I)) ! get alignment J=0 CALL LIB$MOVC3(2,%REF(RECORD(I+1:I+2)),J) ! get flags CALL LIB$MOVC3(4,%REF(RECORD(I+3:I+6)),J2) ! get allocation K2=ICHAR(RECORD(I+7:I+7)) ! get name length IF((J.AND.'8'X).NE.0)THEN ! if GPS$V_REL set, CALL WRITE_PSECT_TBL(-1,RECORD(I+8:I+7+K2),J,K,J2) ENDIF I=I+9+K2 GOTO 1900 C C GSD global symbol specification: read it and store symbol in table; if C symbol not defined in table, ignore it C 1100 K2=ICHAR(RECORD(I+1:I+1)) IF(((K2.AND.'A'X).EQ.2.OR. + ((K2.AND.'A'X).EQ.10.AND. + ICHAR(RECORD(I+3:I+3)).EQ.0)).AND. + RECORD(I+8:I+20).NE.CHAR(12)//'P1SYSVECTORS')THEN CALL LIB$MOVC3(4,%REF(RECORD(I+4:I+7)),J) J2=ICHAR(RECORD(I:I)) IF(OFFSET_VEC.LE.0)THEN K=1 DO WHILE (K.LE.SYM_TBL_PTR.AND. + SYM_VAL(K).NE.J) K=K+1 ENDDO I2=ICHAR(RECORD(I+8:I+8)) IF(K.LE.SYM_TBL_PTR.AND. + (OFFSET_VEC.EQ.0.OR.J.LT.0.OR.J.GE.'40000000'X))THEN SYM_NAM(K)=RECORD(I+9:I+8+I2) IF((K2.AND.'C'X).EQ.'C'X)THEN ! GSY$V_UNI and GSY$V_REL set SYM_TYP(K)=SYM_TYP(K).OR.SYM_TRANSFER ENDIF ELSEIF(K.GT.SYM_TBL_PTR.AND. + (OFFSET_VEC.EQ.0.OR. + (K2.AND.4).NE.0))THEN SYM_TBL_PTR=SYM_TBL_PTR+1 IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__SYMTBLOVF) ELSE SYM_VAL(SYM_TBL_PTR)=J SYM_TYP(SYM_TBL_PTR)=TYP_CONV(J2) SYM_NAM(SYM_TBL_PTR)=RECORD(I+9:I+8+I2) SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X IF((K2.AND.'C'X).EQ.'C'X)THEN SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER ENDIF ENDIF ENDIF ELSE K=1 DO WHILE (K.LE.SYM_TBL(-1).AND. + SYM_TBL(K).NE.J) K=K+1 ENDDO IF(K.LE.SYM_TBL(-1))THEN I2=ICHAR(RECORD(I+8:I+8)) SYM_NAM(OFFSET_VEC+K-1)=RECORD(I+9:I+8+I2) IF((K2.AND.'C'X).EQ.'C'X)THEN SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER ENDIF ENDIF ENDIF ENDIF J=ICHAR(RECORD(I+8:I+8)) I=I+10+J GOTO 1900 C C GSD entry point symbol/mask declaration: same as global symbol spec. C 1200 K2=ICHAR(RECORD(I+1:I+1)) IF(((K2.AND.'A'X).EQ.2.OR. + ((K2.AND.'A'X).EQ.10.AND. + ICHAR(RECORD(I+3:I+3)).EQ.0)).AND. + RECORD(I+10:I+22).NE.CHAR(12)//'P1SYSVECTORS')THEN CALL LIB$MOVC3(4,%REF(RECORD(I+4:I+7)),J) IF(OFFSET_VEC.LE.0)THEN K=1 DO WHILE (K.LE.SYM_TBL_PTR.AND. + SYM_VAL(K).NE.J) K=K+1 ENDDO I2=ICHAR(RECORD(I+10:I+10)) IF(K.LE.SYM_TBL_PTR.AND. + (OFFSET_VEC.EQ.0.OR.J.LT.0.OR.J.GE.'40000000'X))THEN SYM_NAM(K)=RECORD(I+11:I+10+I2) ELSEIF(K.GT.SYM_TBL_PTR.AND. + OFFSET_VEC.EQ.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__SYMTBLOVF) ELSE SYM_VAL(SYM_TBL_PTR)=J SYM_TYP(SYM_TBL_PTR)=SYM_PROC SYM_NAM(SYM_TBL_PTR)=RECORD(I+11:I+10+I2) SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X IF((K2.AND.'C'X).EQ.'C'X)THEN SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER ENDIF ENDIF ENDIF ELSE K=1 DO WHILE (K.LE.SYM_TBL(-1).AND. + SYM_TBL(K).NE.J) K=K+1 ENDDO IF(K.LE.SYM_TBL(-1))THEN I2=ICHAR(RECORD(I+10:I+10)) SYM_NAM(OFFSET_VEC+K-1)=RECORD(I+11:I+10+I2) IF((K2.AND.'C'X).EQ.'C'X)THEN SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER ENDIF ENDIF ENDIF ENDIF J=ICHAR(RECORD(I+10:I+10)) I=I+12+J GOTO 1900 C C GSD procedure definition: same as global symbol spec, except argument C types can be used (maybe) to make up symbols for offsets from AP. C 1300 K2=ICHAR(RECORD(I+1:I+1)) IF(((K2.AND.'A'X).EQ.2.OR. + ((K2.AND.'A'X).EQ.10.AND. + ICHAR(RECORD(I+3:I+3)).EQ.0)).AND. + RECORD(I+10:I+22).NE.CHAR(12)//'P1SYSVECTORS')THEN CALL LIB$MOVC3(4,%REF(RECORD(I+4:I+7)),J) J2=ICHAR(RECORD(I:I)) IF(OFFSET_VEC.LE.0)THEN K=1 DO WHILE (K.LE.SYM_TBL_PTR.AND. + SYM_VAL(K).NE.J) K=K+1 ENDDO I2=ICHAR(RECORD(I+10:I+10)) IF(K.LE.SYM_TBL_PTR.AND. + (OFFSET_VEC.EQ.0.OR.J.LT.0.OR.J.GE.'40000000'X))THEN SYM_NAM(K)=RECORD(I+11:I+10+I2) ELSEIF(K.GT.SYM_TBL_PTR.AND. + OFFSET_VEC.EQ.0)THEN SYM_TBL_PTR=SYM_TBL_PTR+1 IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN CALL LIB$SIGNAL(DISM__SYMTBLOVF) ELSE SYM_VAL(SYM_TBL_PTR)=J SYM_TYP(SYM_TBL_PTR)=SYM_PROC SYM_NAM(SYM_TBL_PTR)=RECORD(I+11:I+10+I2) SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X IF((K2.AND.'C'X).EQ.'C'X)THEN SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER ENDIF ENDIF ENDIF ELSE K=1 DO WHILE (K.LE.SYM_TBL(-1).AND. + SYM_TBL(K).NE.J) K=K+1 ENDDO IF(K.LE.SYM_TBL(-1))THEN I2=ICHAR(RECORD(I+10:I+10)) SYM_NAM(OFFSET_VEC+K-1)=RECORD(I+11:I+10+I2) IF((K2.AND.'C'X).EQ.'C'X)THEN SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER ENDIF ENDIF ENDIF ENDIF C****************** J=ICHAR(RECORD(I+10:I+10)) I=I+12+J C****************** GOTO 1900 C 1900 IF(I.LT.LEN(RECORD))THEN SUBTYP=ICHAR(RECORD(I-1:I-1)) ENDIF ENDDO GOTO 9000 C C text information and relocation record: ignore C 2000 GOTO 9000 C C end of module record: check error field, then exit C 3000 IF(SUBTYP.NE.0)THEN CALL LIB$SIGNAL(DISM__OBJSYMERR,%VAL(1),%VAL(SUBTYP)) ENDIF ANALYZE_SYM_REC=1 GOTO 9999 C C debug information record: ignore C 4000 GOTO 9000 C C traceback information record: ignore C 5000 GOTO 9000 C C link option specification record: add .LINK pseudo-op to .MAR file C 6000 J2=0 CALL LIB$MOVC3(2,%REF(RECORD(1:2)),J2) K=0 CALL LIB$MOVC3(2,%REF(RECORD(3:4)),K) GOTO (6100,6100,6200,6300,6400),SUBTYP+1 C C this is a catch-all for undefined LNK subrecord types. it signals a warning. C CALL LIB$SIGNAL(DISM__UNKOBJREC,%VAL(2),%VAL(TYP),%VAL(SUBTYP)) GOTO 9000 C C LNK object or shareable image library specification: write out file spec C 6100 WRITE(6,9601) TAB, TAB, RECORD(5:4+K) 9601 FORMAT(A1,'.LINK',A1,'"',A,'"/LIBRARY') GOTO 9000 C C LNK object library with include list specification: write out file spec C 6200 WRITE(6,9620) TAB, TAB, RECORD(5:4+K) 9620 FORMAT(A1,'.LINK',A1,'"',A,'"/INCLUDE') GOTO 9000 C C LNK object file specification: write out file spec C 6300 S_TMP=' ' J=0 IF(J2)THEN S_TMP='/SELECTIVE_SEARCH' J=17 ENDIF WRITE(6,9630) TAB, TAB, RECORD(5:4+K), S_TMP(1:J) 9630 FORMAT(A1,'.LINK',A1,'"',A,'"',A) GOTO 9000 C C LNK shareable image specification: write out file spec C 6400 WRITE(6,9640) TAB, TAB, RECORD(5:4+K) 9640 FORMAT(A1,'.LINK',A1,'"',A,'"/SHAREABLE') GOTO 9000 C C end of module (word psect) record: check error field, then exit C 7000 IF(SUBTYP.NE.0)THEN CALL LIB$SIGNAL(DISM__OBJSYMERR,%VAL(1),%VAL(SUBTYP)) ENDIF ANALYZE_SYM_REC=1 GOTO 9999 C C return successfully C 9000 ANALYZE_SYM_REC=0 9999 RETURN C END INTEGER*4 FUNCTION CONVERT_F_FLOAT(X,STR,LN) C IMPLICIT NONE CHARACTER*(*) STR INTEGER*2 LN REAL*4 X C INTEGER*4 FOR$CVT_D_TG EXTERNAL LIB$SIG_TO_RET, FOR$CVT_D_TG C CALL LIB$ESTABLISH(LIB$SIG_TO_RET) LN=0 STR=' ' CONVERT_F_FLOAT=FOR$CVT_D_TG( + DBLE(X),STR,%VAL(7),%VAL(0),%VAL(2),%VAL(2)) CALL STR$TRIM(STR,STR,LN) RETURN C END INTEGER*4 FUNCTION CONVERT_D_FLOAT(X,STR,LN) C IMPLICIT NONE CHARACTER*(*) STR INTEGER*2 LN REAL*8 X C INTEGER*4 FOR$CVT_D_TG EXTERNAL LIB$SIG_TO_RET, FOR$CVT_D_TG C CALL LIB$ESTABLISH(LIB$SIG_TO_RET) LN=0 STR=' ' CONVERT_D_FLOAT=FOR$CVT_D_TG( + X,STR,%VAL(17),%VAL(0),%VAL(2),%VAL(2)) CALL STR$TRIM(STR,STR,LN) RETURN C END OPTIONS /G_FLOATING INTEGER*4 FUNCTION CONVERT_G_FLOAT(X,STR,LN) C IMPLICIT NONE CHARACTER*(*) STR INTEGER*2 LN REAL*8 X C INTEGER*4 FOR$CVT_G_TG EXTERNAL LIB$SIG_TO_RET, FOR$CVT_G_TG C CALL LIB$ESTABLISH(LIB$SIG_TO_RET) LN=0 STR=' ' CONVERT_G_FLOAT=FOR$CVT_G_TG( + X,STR,%VAL(16),%VAL(0),%VAL(2),%VAL(2)) CALL STR$TRIM(STR,STR,LN) RETURN C END INTEGER*4 FUNCTION CONVERT_H_FLOAT(X,STR,LN) C IMPLICIT NONE CHARACTER*(*) STR INTEGER*2 LN REAL*16 X C INTEGER*4 FOR$CVT_H_TG EXTERNAL LIB$SIG_TO_RET, FOR$CVT_H_TG C CALL LIB$ESTABLISH(LIB$SIG_TO_RET) LN=0 STR=' ' CONVERT_H_FLOAT=FOR$CVT_H_TG( + X,STR,%VAL(33),%VAL(0),%VAL(4),%VAL(2)) CALL STR$TRIM(STR,STR,LN) RETURN C END SUBROUTINE BUILD_IO_LIST(IO_MASK,STR,LN,NUM) C C this procedure converts an FDT I/O function bit-mask into a string of C combined I/O function names C IMPLICIT NONE CHARACTER*(*) STR INTEGER*2 LN, NUM INTEGER*4 IO_MASK(2) C CHARACTER*11 IOSYM(0:63) INTEGER*2 IOLEN(0:63) INTEGER*4 I DATA IOSYM/'NOP','LOADMCODE','STARTMPROC','STOP','INITIALIZE', + 'RELEASE','ERASETAPE','QSTOP','PACKACK','SPACERECORD', + 'WRITECHECK','WRITEPBLK','READPBLK','WRITEHEAD', + 'READHEAD','WRITETRACKD','READTRACKD','AVAILABLE', + '**^X12**','**^X13**','**^X14**','DSE','REREADN', + 'REREADP','WRITECHECKH','READPRESET','SETCHAR', + 'SENSECHAR','WRITEMARK','DIAGNOSE','FORMAT','PHYSICAL', + 'WRITELBLK','READLBLK','REWINDOFF','SETMODE','REWIND', + 'SKIPFILE','SKIPRECORD','SENSEMODE','WRITEOF', + '**^X29**','**^X2A**','**^X2B**','**^X2C**','**^X2D**', + '**^X2E**','LOGICAL','WRITEVBLK','READVBLK','ACCESS', + 'CREATE','DEACCESS','DELETE','MODIFY','READPROMPT', + 'ACPCONTROL','MOUNT','TTYREADALL','TTYREADPALL', + 'CONINTREAD','CONINTWRITE','**^X3E**','VIRTUAL'/ DATA IOLEN/3,9,10,4,10,7,9,5,7,11,10,9,8,9,8,11,10,9,8,8,8,3,7, + 7,11,10,7,9,9,8,6,8, + 9,8,9,7,6,8,10,9,7,8,8,8,8,8,8,7, + 9,8,6,6,8,6,6,10,10,5,10,11,10,11,8,7/ C STR='<' LN=0 NUM=0 DO I=0,31 IF((IO_MASK(1).AND.JISHFT(1,I)).NE.0)THEN STR(LN+2:)=IOSYM(I) LN=LN+IOLEN(I)+2 STR(LN:LN)=',' NUM=NUM+1 ENDIF ENDDO DO I=0,31 IF((IO_MASK(2).AND.JISHFT(1,I)).NE.0)THEN STR(LN+2:)=IOSYM(I+32) LN=LN+IOLEN(I+32)+2 STR(LN:LN)=',' NUM=NUM+1 ENDIF ENDDO LN=MAX(LN,2) STR(LN:LN)='>' C RETURN C END SUBROUTINE WRITE_FORMAT_REPEAT(ADDR,VFEM) C IMPLICIT NONE BYTE VFEM INTEGER*4 ADDR C INTEGER*4 VAL CHARACTER*1 TAB /9/ C IF((VFEM.AND.'80'X).NE.0)THEN ! if VFEM RC bit set CALL COPY_LONG(ADDR,VAL) ! get VFE address ADDR=ADDR+4 VAL=VAL+ADDR WRITE(2, +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE repeat count'')') + TAB, TAB, VAL, TAB, TAB ELSE VAL=0 IF((VFEM.AND.'3'X).EQ.0)THEN WRITE(2,'(4A1,''; default repeat count=1'')') + TAB, TAB, TAB, TAB ELSEIF((VFEM.AND.'3'X).EQ.1)THEN CALL COPY_BYTE(ADDR,VAL) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; repeat count'')') + TAB, TAB, VAL, TAB, TAB ELSEIF((VFEM.AND.'3'X).EQ.2)THEN CALL COPY_WORD(ADDR,VAL) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; repeat count'')') + TAB, TAB, VAL, TAB, TAB ENDIF ENDIF C RETURN C END SUBROUTINE WRITE_FORMAT_WIDTH(ADDR,VFEM) C IMPLICIT NONE BYTE VFEM INTEGER*4 ADDR C INTEGER*4 VAL CHARACTER*1 TAB /9/ C IF((VFEM.AND.'40'X).NE.0)THEN ! if VFEM W bit set CALL COPY_LONG(ADDR,VAL) ! get VFE address ADDR=ADDR+4 VAL=VAL+ADDR WRITE(2,'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE width'')') + TAB, TAB, VAL, TAB, TAB ELSE VAL=0 IF((VFEM.AND.'4'X).EQ.0)THEN CALL COPY_BYTE(ADDR,VAL) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; field width'')') + TAB, TAB, VAL, TAB, TAB ELSE CALL COPY_WORD(ADDR,VAL) ADDR=ADDR+2 WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; field width'')') + TAB, TAB, VAL, TAB, TAB ENDIF ENDIF C RETURN C END SUBROUTINE WRITE_FORMAT_MANTISSA(ADDR,VFEM) C IMPLICIT NONE BYTE VFEM INTEGER*4 ADDR C INTEGER*4 VAL CHARACTER*1 TAB /9/ C IF((VFEM.AND.'20'X).NE.0)THEN ! if VFEM D bit set CALL COPY_LONG(ADDR,VAL) ! get VFE address ADDR=ADDR+4 VAL=VAL+ADDR WRITE(2, +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE decimal width'')') + TAB, TAB, VAL, TAB, TAB ELSE VAL=0 CALL COPY_BYTE(ADDR,VAL) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; decimal width'')') + TAB, TAB, VAL, TAB, TAB ENDIF C RETURN C END SUBROUTINE WRITE_FORMAT_EXPONENT(ADDR,VFEM) C IMPLICIT NONE BYTE VFEM INTEGER*4 ADDR C INTEGER*4 VAL CHARACTER*1 TAB /9/ C IF((VFEM.AND.'10'X).NE.0)THEN ! if VFEM E bit set CALL COPY_LONG(ADDR,VAL) ! get VFE address ADDR=ADDR+4 VAL=VAL+ADDR WRITE(2,9000) TAB, TAB, VAL, TAB, TAB 9000 FORMAT(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1, + '; VFE exponent width') ELSE VAL=0 CALL COPY_BYTE(ADDR,VAL) ADDR=ADDR+1 WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; exponent width'')') + TAB, TAB, VAL, TAB, TAB ENDIF C RETURN C END SUBROUTINE WRITE_PSECT_TBL(BASE,NAME,FLAGS,ALIGN,ALLOC) C IMPLICIT NONE C BYTE ALIGN CHARACTER*(*) NAME INTEGER*2 FLAGS INTEGER*4 BASE, ALLOC C INCLUDE 'DISMISDTBL.INC' C INTEGER*4 I, J C IF(BASE.NE.-1)THEN I=1 DO WHILE (I.LE.ISD_NUM.AND. + (BASE.LT.ISD_BASEVA(I).OR. + BASE.GT.ISD_PGEND(I))) I=I+1 ENDDO IF(I.LE.ISD_NUM)THEN J=1 DO WHILE (J.LE.PSECT_NUM.AND. + (PSECT_ISD(J).NE.I.OR. + PSECT_BASEADR(J).GE.BASE)) J=J+1 ENDDO ENDIF ELSEIF(NAME.NE.' ')THEN ENDIF C RETURN C END