0% found this document useful (0 votes)
336 views21 pages

Disasm For

Main program - Fortran-77 source code for 68000 dis-assembly for IBM Instruments CS/9000 Fortran. Resulting asm sources were assemblable with the CS/9000 assembler. Part of code I developed during Ph.D. research. This was a work-in-progress then, and is the last snapshot. Released under LGPL or Creative Commons 2 Attribution.

Uploaded by

kgrhoads
Copyright
© Attribution (BY)
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as DOC, PDF, TXT or read online on Scribd
0% found this document useful (0 votes)
336 views21 pages

Disasm For

Main program - Fortran-77 source code for 68000 dis-assembly for IBM Instruments CS/9000 Fortran. Resulting asm sources were assemblable with the CS/9000 assembler. Part of code I developed during Ph.D. research. This was a work-in-progress then, and is the last snapshot. Released under LGPL or Creative Commons 2 Attribution.

Uploaded by

kgrhoads
Copyright
© Attribution (BY)
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as DOC, PDF, TXT or read online on Scribd
You are on page 1/ 21

$CHAREQU

$SEGMENT DISASM
PROGRAM UNASMB
CHARACTER*1 CHR,IN,OFNEXT*3,OFNVOL*6
CHARACTER*20 INFILE,OUTFIL,INFIL,INFIL2,IIFIL,ARG,HLIN(2)*37,ADRFIL,SAVFIL
CHARACTER*8 TRADR,HEXOF,THEHEX,PAGE,MMADR,FN,OFN,FNEXT*3,FNVOL*6,TH2
CHARACTER*10 ASMOUT(7),LABEL,OPCODE,OPS(3),VAL,ADDR,ARG16*16
CHARACTER*74 LINES(1200),LABLE(3)*70,LABLE3*70
CHARACTER*2 CRLINE*72,PROGNM*18,MAINLN*54,CRKEY*12,ALLOPS*30
INTEGER*4 NEWLEN,TRADDR,MEMADR,LINPTR,KADDR,IM,IB,IL,IKOFST,BLKBEG,BLKEND
INTEGER*4 BRATRG(4096,2),JSRTRG(4096,2),BRANUM,JSRNUM,ADDREF(0:16383)
INTEGER*4 ADDRSQ(0:16384),ADRNDX
INTEGER*2 CODEW(0:16383),WHERE,END,OLDEND,COUNT,PAGENO
INTEGER*2 ASC,SCAN,KBF1,KBF2,ERR,NARG
INTEGER*1 CODEB(0:1,0:16383),BYTES(0:32767),TRBYTE(0:3),MEMBYT(0:3),ABYTE
INTEGER*1 NEWBYT(0:3),DSKBYT(0:2047)
LOGICAL*4 NEWSTL,V10,V11,FIRST,DOCR
LOGICAL*2 SCREEN,PAGEQQ,DISK,ENDFIL,DONE,NEW,RETRY,ONETH,SGNDSP,PGECOM,XQUIET
LOGICAL*2 DOABS,SPRSLX,SPRSXA,SRCWXR,DSTWXR,SHRTBR,ARRGH,ARRGH2,DOCORE,DOHEX
LOGICAL*2 DOBRA,DOJSR,ABORT,ESCAPE,INTRPT,DODCW,DODCL,REGSWP,FOUND
LOGICAL*1 A(10),DELTA,ASKED,SET,REDO
EQUIVALENCE (ADDRSQ(16384),ADRNDX),(ADDRSQ(0),ADDREF(0))
EQUIVALENCE (NEWLEN,NEWBYT(0)),(INFIL,INFILE),(LABLE(3),LABLE3)
EQUIVALENCE (CODEW(0),CODEB(0,0),BYTES(0)),(TRADDR,TRBYTE(0))
EQUIVALENCE (ASMOUT(1),LABEL),(ASMOUT(2),OPCODE),(ASMOUT(6),VAL)
EQUIVALENCE (ASMOUT(7),ADDR),(ASMOUT(3),OPS(1)),(MEMADR,MEMBYT(0))
EQUIVALENCE (ARG,ARG16)
COMMON /CODE/IPAD,CODEW,WHERE,END,TRADDR,MEMADR
COMMON
/DISASM/ASMOUT,LINES,MMADR,ALLOPS,/NEWSTF/NEWLEN,NEWSTL,DODCW,DODCL,FIRST
COMMON /HEADER/LABLE,/HEXDO/DOHEX
COMMON /HEADRE/COUNT,PAGENO,/DISNUM/LINPTR,/REFS/ADDRSQ,BLKBEG,BLKEND,FOUND
COMMON /FLAGS/SCREEN,PAGEQQ,DISK,ENDFIL,/SWPREG/REGSWP
COMMON /BRAJSR/BRATRG,JSRTRG,BRANUM,JSRNUM,DOBRA,DOJSR
COMMON /KEYGET/ASC,SCAN,KBF1,KBF2,ERR,/NTRVN/ABORT,ESCAPE,INTRPT
COMMON /MODESQ/DOABS,SPRSLX,SPRSXA,SRCWXR,DSTWXR,SHRTBR,SGNDSP
COMMON /GARRH/ARRGH,ARRGH2,PGECOM,XQUIET,/VERSNS/V10,V11
COMMON /NAMEPR/PROGNM,MAINLN,/GNORF9/CRKEY,CRLINE,DOCR
SAVE /VERSNS/,/GARRH/,/MODESQ/,/FLAGS/,/HEADRE/,/DISNUM/,/REFS/
SAVE /DISASM/,/NEWSTF/,/CODE/,/SWPREG/,IKOFST,LEN
EXTERNAL HEXOF,KADDR,NARG,GETARG,ENTHSH
SAVE
*
CALL TSTSCR
DOCR = .TRUE.
CRKEY = 'cOPYrIGHT@@@'
CRLINE = '1984,85 Kevin G. Rhoads & High Voltage Research Lab @ MIT.'
MAINLN = 'Disassembler for IBM System 9000 - ASM compatible'
PROGNM = 'DisAsm'
V10 = .FALSE.
V11 = .TRUE.
REGSWP = .TRUE.
SPRSLX = .FALSE.
SPRSXA = .FALSE.
DOABS = .FALSE.
SGNDSP = .TRUE.
SHRTBR = V11
NEWSTL = .FALSE.
NEWBYT(0) = 0
NEWBYT(1) = 0
NEWBYT(2) = 0
NEWBYT(3) = 0
IKOFST = 0
CALL ZAPIT(BYTES(0),8500)
SET = .FALSE.
* MOTOROLA STANDARD ASSEMBLER SYNTAX: SPRSLX = F, SPRSXA = F, DOABS = T, SHRTBR = T
PAGEQQ = .FALSE.
LABEL = '* LABEL'
OPCODE = ' OpCode'
OPS(1) = ' Operand'
OPS(2) = 'Fields &'
OPS(3) = 'Comments'
VAL = ' HexaD'
ADDR = 'ecimal'
LABLE(1) = LABEL//OPCODE//OPS(1)//OPS(2)//OPS(3)//VAL//ADDR
VAL = ' Value'
ADDR = ' Address'
LABLE(2) = LABEL//OPCODE//OPS(1)//OPS(2)//OPS(3)//VAL//ADDR
NUMARG = NARG()
DO 4553 I = 1,10
A(I) = .FALSE.
4553 CONTINUE
DO 4554 I = 1,NUMARG
A(I) = .TRUE.
4554 CONTINUE
4545 CONTINUE
IKOFST = 0
CALL RDYHSH(ADDREF,14)
FOUND = .FALSE.
ASKED = .FALSE.
DODCW = .FALSE.
DODCL = .FALSE.
DOBRA = .FALSE.
DOJSR = .FALSE.
ADRNDX = 1
BLKBEG = -1
BLKEND = -1
INFIL2 = ' '
IIFIL = ' '
INFIL = ' '
REDO = .FALSE.
CALL CRCLS
ARG = ' '
4664 CONTINUE
IF (A(1)) THEN
CALL GETARG(1,ARG)
INFIL2 = ARG
A(1) = .FALSE.
ELSE
PRINT *,'WHAT FILE TO BE DISASSEMBLED? (or #CORE or #ROM)'
READ (*,'(A)',ERR=2434,END=2434) INFIL2
ENDIF
SAVFIL = INFIL2
4646 CONTINUE
IKOFST = 0
ARG = ' '
BRANUM = 1
JSRNUM = 1
NEW = .TRUE.
RETRY = .FALSE.
ONETH = .TRUE.
COUNT = 0
PAGENO = 1
END = 0
DONE = .FALSE.
ENDFIL = .FALSE.
IIFIL = SAVFIL
ARG = SAVFIL
CALL STRIPF(SAVFIL)
IF (SAVFIL.EQ.' '.AND.IIFIL(1:1).NE.'#') GOTO 6882
IIFIL(2:20) = SAVFIL(1:19)
2434 CLOSE (UNIT=10,ERR=2435)
2435 CALL FNCHCK(SAVFIL,'BIN',INFILE)
IF (IIFIL(1:1).EQ.'#') THEN
DOCORE = .TRUE.
ARG(1:1) = '0'
ICORE = INTOF(ARG)
IF (A(2)) THEN
CALL GETARG(2,INFIL2)
A(2) = .FALSE.
ELSEIF (ICORE.GE.0.AND.ARG.NE.' ') THEN
INFIL2 = ARG
GOTO 6612
ELSE
PRINT *,' What base address? '
READ (*,'(A)',ERR=6610) INFIL2
ENDIF
6610 ICORE = INTOF(SAVFIL)
6612 IF (ICORE.LT.0) GOTO 4545
ICORE = IAND(ICORE,$0FFFFFE)
THEHEX = HEXOF(ICORE)
PRINT *,' Base address = ',ICORE,' $',THEHEX
BLKBEG = ICORE
CALL ENTHSH(ADDREF(0),14,BLKBEG,ADRNDX)
IF (A(3)) THEN
CALL GETARG(3,SAVFIL)
A(3) = .FALSE.
ELSE
PRINT *,'How much? (_,= for end address)'
READ (*,'(A)',ERR=6611) INFIL2
ENDIF
DELTA = .FALSE.
CHR = INFIL2(1:1)
IF (CHR.EQ.'_'.OR.CHR.EQ.'=') THEN
IF (INFIL(2:2).EQ.'$') THEN
INFIL2(1:2) = '$0'
ELSE
INFIL2(1:1) = '0'
ENDIF
DELTA = .TRUE.
ENDIF
6611 NEWLEN = INTOF(INFIL2)
IF (DELTA) NEWLEN = NEWLEN - ICORE
IF (NEWLEN.LT.0) GOTO 4545
NEWLEN = NEWLEN + 2
BLKEND = NEWLEN + BLKBEG
MMADR = HEXOF(ICORE)
IF (ICORE.GE.$F00000) THEN
INFILE = 'RO'//MMADR(3:8)//'. '
ELSE
INFILE = 'MEM'//MMADR(4:8)//'. '
ENDIF
MEMADR = ICORE
DSKBYT(0) = 3
GOTO 6602
ENDIF
DOCORE = .FALSE.
CLOSE (UNIT=10,ERR=7701)
7701 OPEN (UNIT=10,FILE='DIR.DIR',ERR=7702)
7702 CONTINUE
OPEN (UNIT=10,FILE=INFILE,FORM='BINARY',STATUS='OLD',ERR=6601)
GOTO 6602
6601 CALL FNCHCK(INFIL2,'DRV',INFILE)
OPEN (UNIT=10,FILE=INFILE,FORM='BINARY',STATUS='OLD',ERR=5445)
6602 CONTINUE
CALL EXPAND(INFILE,FNVOL,FN,FNEXT)
IF (RETRY) GOTO 9999
LABLE3 = '*Disassembly of: '//INFILE
LABEL = FN
DISK = .FALSE.
CALL EXPAND(INFILE,OFNVOL,OFN,OFNEXT)
OFNEXT = 'ADR'
ADRFIL = OFNVOL//':'//OFN//'.'//OFNEXT
CALL STRIPF(ADRFIL)
OPEN (UNIT=92,FILE='DIR.DIR',ERR=6996)
6996 CLOSE (UNIT=92,ERR=6997)
6997 OPEN
(UNIT=92,FILE=ADRFIL,STATUS='OLD',FORM='BINARY',ACCESS='SEQUENTIAL',ERR=6799)
GOTO 6977
ADRFIL = OFN//'.'//OFNEXT
CALL STRIPF(ADRFIL)
6799 OPEN
(UNIT=92,FILE=ADRFIL,STATUS='OLD',FORM='BINARY',ACCESS='SEQUENTIAL',ERR=6613)
6977 PRINT *,'ADDRESS REFERENCE FILE FOUND: ',ADRFIL
CALL READDR
PRINT *,'ADDRESS REFERENCE FILE LOADED, ',ADRNDX-1,' ENTRIES'
FOUND = .TRUE.
6613 CONTINUE
IF (NUMARG.EQ.0) THEN
PRINT *,'DO YOU WANT OUTPUT ON DISK? (Y/n)'
I = MENU(1,0,1)
DISK = I.EQ.1
OUTFIL = ' '
ELSE
OUTFIL = ' '
IF (A(2)) THEN
CALL GETARG(2,OUTFIL)
A(2) = .FALSE.
ELSEIF (A(3)) THEN
CALL GETARG(3,OUTFIL)
A(3) = .FALSE.
ELSEIF (A(4)) THEN
CALL GETARG(4,OUTFIL)
A(4) = .FALSE.
ENDIF
CALL STRIP(OUTFIL)
PGECOM = .FALSE.
XQUIET = .FALSE.
IF (OUTFIL(1:1).EQ.'#') THEN
DISK = .TRUE.
OPEN (UNIT=9,FILE=OUTFIL,ERR=9999)
SCREEN = .TRUE.
GOTO 9999
ENDIF
DISK = .TRUE.
ENDIF
XQUIET = .FALSE.
DOHEX = .FALSE.
DOJSR = .FALSE.
DOBRA = .FALSE.
JRSNUM = 1
BRANUM = 1
IF (DISK) THEN
IF (NUMARG.LE.0) THEN
PRINT *,'WHAT FILE FOR DISASSEMBLED OUTPUT?'
READ (*,'(A)') OUTFIL
PRINT *,' Do page labels in disk output? (y/N)'
IJ = MENU(0,0,1)
PGECOM = IJ.EQ.1
IF (ASC.EQ.10) GOTO 5447
PRINT *,'Add extra comment lines on extension words? (y/N)'
PRINT *,'^E to turn ON, !E to turn OFF while running'
IJ = MENU(0,0,1)
XQUIET = IJ.EQ.0
IF (ASC.EQ.10) GOTO 5447
PRINT *,'DO HEX ALSO? (y/N) '
PRINT *,'^H to turn ON, !H to turn OFF while running'
IJ = MENU(0,0,1)
DOHEX = IJ.EQ.1
IF (ASC.EQ.10) GOTO 5447
IF (XQUIET.OR.FOUND) THEN
PRINT *,' Keep a list of BRA/Bcc/JMP targets? (y/N)'
PRINT *,'^B to turn ON, !B to turn OFF while running'
IJ = MENU(0,0,1)
ELSE
PRINT *,' Keep a list of BRA/Bcc/JMP targets? (Y/n)'
PRINT *,'^B to turn ON, !B to turn OFF while running'
IJ = MENU(1,0,1)
ENDIF
DOBRA = IJ.EQ.1
IF (ASC.EQ.10) GOTO 5447
IF (.NOT.DOBRA) THEN
PRINT *,' Keep a list of BSR/JSR targets? (y/N)'
PRINT *,'^J to turn ON, !J to turn OFF while running'
IJ = MENU(0,0,1)
ELSE
PRINT *,' Keep a list of BSR/JSR targets? (Y/n)'
PRINT *,'^J to turn ON, !J to turn OFF while running'
IJ = MENU(1,0,1)
ENDIF
DOJSR = IJ.EQ.1
IF (ASC.EQ.10) GOTO 5447
ASKED = .TRUE.
PRINT *,' PROCESSING: (1=STRINGS, 2=dc.w, 3=dc.l, 4=no strings)'
I = MENU(1,0,4)
DODCW = I .EQ. 2 .OR. I .EQ. 1
DODCL = I .GE. 3 .OR. I .EQ. 1
ELSE
DO 7710 IJ = 3,10
IF (A(IJ)) THEN
JI = IJ
CALL GETARG(JI,ARG)
CALL STRIP(ARG)
CHR = ARG(2:2)
IF (CHR.EQ.'X') THEN
XQUIET = ARG(1:1).EQ.'-'
ELSEIF (CHR.EQ.'B'.OR.CHR.EQ.'J') THEN
DOBRA = ARG(1:1).EQ.'+'
ELSEIF (CHR.EQ.'H') THEN
DOHEX = ARG(1:1).EQ.'+'
ELSEIF (CHR.EQ.'S') THEN
DOJSR = ARG(1:1).EQ.'+'
ELSEIF (CHR.EQ.'Q') THEN
XQUIET = ARG(1:1).NE.'-'
DOBRA = DOBRA .AND. .NOT.XQUIET
DOJSR = DOJSR .AND. .NOT.XQUIET
DOHEX = DOHEX .AND. .NOT.XQUIET
ELSEIF (CHR.EQ.'P'.OR.CHR.EQ.'M') THEN
CHR = ARG(3:3)
DODCL = CHR.EQ.'3' .OR. CHR.EQ.'4'
DODCW = CHR.EQ.'2' .OR. CHR.EQ.'4'
SET = .TRUE.
ENDIF
ENDIF
7710 CONTINUE
ENDIF
5447 CONTINUE
CALL STRIPF(OUTFIL)
OFNVOL = ' '
OFN = ' '
OFNEXT = ' '
CALL EXPAND(OUTFIL,OFNVOL,OFN,OFNEXT)
IF (OFN.EQ.' ') OFN = FN
IF (OFNEXT.EQ.' ') OFNEXT = 'DSM'
OUTFIL = OFNVOL//':'//OFN//'.'//OFNEXT
CALL STRIPF(OUTFIL)
5 CONTINUE
INFIL2 = OUTFIL
CALL FNCHCK(INFIL2,'DSM',OUTFIL)
PRINT *,' OPENING FILE: ',OUTFIL,' FOR OUTPUT'
CLOSE (UNIT=9,ERR=2453)
2453 OPEN (UNIT=9,FILE=OUTFIL,STATUS='NEW',ERR=8990)
CALL EXPAND(OUTFIL,OFNVOL,OFN,OFNEXT)
WRITE (9,'(A)') OFN(1:6)//' IDNT 1,0'
IF (PGECOM) THEN
WRITE (PAGE,'(''Page '',I3)') PAGENO
LABLE(2)(43:50) = PAGE
ENDIF
IF (PGECOM) WRITE (9,'(A)') LABLE(1)
IF (PGECOM) WRITE (9,'(A)') LABLE(2)
* WRITE (9,'(A)') LABLE3
IF (V11) WRITE (9,'(A)') ' NOFORMAT'
IF (V11) WRITE (9,'(A)') ' OPT A,FRL,BRL'
SCREEN = .FALSE.
IF (NUMARG.GT.0) GOTO 9999
PRINT *,'DO YOU WANT OUTPUT ON SCREEN ALSO? (y/N)'
I = MENU(0,0,1)
SCREEN = I.EQ.1
IF (ASKED) GOTO 9999
ASKED = .TRUE.
PRINT *,' PROCESSING: (1=STRINGS, 2=dc.w, 3=dc.l, 4=no strings)'
I = MENU(1,0,4)
DODCW = I .EQ. 2 .OR. I .EQ. 1
DODCL = I .GE. 3 .OR. I .EQ. 1
ELSE
SCREEN = .TRUE.
PRINT *,' Do you want additional comment lines? (y/N)'
PRINT *,'^E to turn ON, !E to turn OFF while running'
IJ = MENU(0,0,1)
XQUIET = IJ.EQ.0
IF (ASC.EQ.10) GOTO 9999
PRINT *,'DO HEX ALSO? (y/N) '
PRINT *,'^H to turn ON, !H to turn OFF while running'
IJ = MENU(0,0,1)
DOHEX = IJ.EQ.1
IF (ASC.EQ.10) GOTO 9999
IF (XQUIET.OR.FOUND) THEN
PRINT *,' Keep a list of BRA/Bcc/JMP targets? (y/N)'
PRINT *,'^B to turn ON, !B to turn OFF while running'
IJ = MENU(0,0,1)
ELSE
PRINT *,' Keep a list of BRA/Bcc/JMP targets? (Y/n)'
PRINT *,'^B to turn ON, !B to turn OFF while running'
IJ = MENU(1,0,1)
ENDIF
DOBRA = IJ.EQ.1
IF (ASC.EQ.10) GOTO 9999
IF (.NOT.DOBRA) THEN
PRINT *,' Keep a list of BSR/JSR targets? (y/N)'
PRINT *,'^J to turn ON, !J to turn OFF while running'
IJ = MENU(0,0,1)
ELSE
PRINT *,' Keep a list of BSR/JSR targets? (Y/n)'
PRINT *,'^J to turn ON, !J to turn OFF while running'
IJ = MENU(1,0,1)
ENDIF
DOJSR = IJ.EQ.1
IF (ASC.EQ.10) GOTO 9999
ASKED = .TRUE.
PRINT *,' PROCESSING: (1=STRINGS, 2=dc.w, 3=dc.l, 4=no strings)'
I = MENU(1,0,4)
DODCW = I .EQ. 2 .OR. I .EQ. 1
DODCL = I .GE. 3 .OR. I .EQ. 1
ENDIF
IF (.NOT.FOUND) THEN
OFNVOL = ' '
OFN = ' '
OFNEXT = ' '
CALL EXPAND(OUTFIL,OFNVOL,OFN,OFNEXT)
IF (OFN.EQ.' ') OFN = FN
OFNEXT = 'ADR'
ADRFIL = OFNVOL//':'//OFN//'.'//OFNEXT
CALL STRIPF(ADRFIL)
OPEN (UNIT=92,FILE='DIR.DIR',ERR=6886)
6886 CLOSE (UNIT=92,ERR=6887)
6887 OPEN
(UNIT=92,FILE=ADRFIL,STATUS='OLD',FORM='BINARY',ACCESS='SEQUENTIAL',ERR=6788)
GOTO 6787
ADRFIL = OFN//'.'//OFNEXT
CALL STRIPF(ADRFIL)
6788 OPEN
(UNIT=92,FILE=ADRFIL,STATUS='OLD',FORM='BINARY',ACCESS='SEQUENTIAL',ERR=6888)
6787 PRINT *,'ADDRESS REFERENCE FILE FOUND: ',ADRFIL
CALL READDR
PRINT *,'ADDRESS REFERENCE FILE LOADED, ',ADRNDX-1,' ENTRIES'
FOUND = ADRNDX .GT. 1
6888 CONTINUE
ENDIF
GOTO 9999
8990 CONTINUE
PRINT *,'ERROR OPENING DISK FILE - OUTPUT TO SCREEN'
SCREEN = .TRUE.
DISK = .FALSE.
IF (NEW.AND.(.NOT.DOCORE)) THEN
NEW = .FALSE.
READ (10,ERR=8934,END=8999) (DSKBYT(I),I=0,4)
DONE = .TRUE.
ELSEIF (DOCORE) THEN
DSKBYT(0) = $03
DONE = .TRUE.
NEWSTL = .TRUE.
IKOFST = 0
FIRST = .FALSE.
MEMADR = ICORE
ENDIF
9999 CONTINUE
IF (.NOT.ASKED) THEN
IF (NUMARG.GT.0.AND..NOT.SET) THEN
DODCW = .FALSE.
DODCL = .FALSE.
ELSEIF (.NOT.SET) THEN
PRINT *,' PROCESSING: (1=STRINGS, 2=dc.w, 3=dc.l, 4=no strings)'
I = MENU(1,0,4)
DODCW = I .EQ. 2 .OR. I .EQ. 1
DODCL = I .GE. 3 .OR. I .EQ. 1
ENDIF
ASKED = .TRUE.
ENDIF
WHERE = 0
IKOFST = 0
IF (.NOT.FOUND) THEN
OFNVOL = ' '
OFN = ' '
OFNEXT = ' '
CALL EXPAND(OUTFIL,OFNVOL,OFN,OFNEXT)
IF (OFN.EQ.' ') OFN = FN
OFNEXT = 'ADR'
ADRFIL = OFNVOL//':'//OFN//'.'//OFNEXT
CALL STRIPF(ADRFIL)
OPEN (UNIT=92,FILE='DIR.DIR',ERR=6986)
6986 CLOSE (UNIT=92,ERR=6987)
6987 OPEN
(UNIT=92,FILE=ADRFIL,STATUS='OLD',FORM='BINARY',ACCESS='SEQUENTIAL',ERR=6688)
GOTO 6687
ADRFIL = OFN//'.'//OFNEXT
CALL STRIPF(ADRFIL)
6688 OPEN
(UNIT=92,FILE=ADRFIL,STATUS='OLD',FORM='BINARY',ACCESS='SEQUENTIAL',ERR=6988)
6687 PRINT *,'ADDRESS REFERENCE FILE FOUND: ',ADRFIL
CALL READDR
PRINT *,'ADDRESS REFERENCE FILE LOADED, ',ADRNDX-1,' ENTRIES'
FOUND = ADRNDX .GT. 1
6988 CONTINUE
ENDIF
FNEXT = ' '
IF (NEWSTL.AND.NEWLEN.GT.0.AND.(.NOT.DOCORE)) THEN
DONE = .TRUE.
MEMADR = MEMADR + LEN
DSKBYT(0) = 3
ELSEIF (DOCORE) THEN
DSKBYT(0) = 3
DONE = .TRUE.
NEWSTL = .TRUE.
WHERE = 0
IKOFST = 0
FIRST = .FALSE.
MEMADR = ICORE
CALL ENTHSH(ADDREF(0),14,MEMADR,ADRNDX)
ELSEIF (.NOT.(DONE.OR.DOCORE)) THEN
READ (10,END=8999) (DSKBYT(I),I=0,4)
WHERE = 0
IKOFST = 0
ENDIF
9998 CONTINUE
IF (NEWSTL.AND.NEWLEN.GT.0.AND.(.NOT.DOCORE)) THEN
DONE = .TRUE.
MEMADR = MEMADR + LEN
DSKBYT(0) = $03
ENDIF
NUMARG = 0
IF (DSKBYT(0).EQ.$16) THEN
DO 1 I = 0,3
TRBYTE(I) = DSKBYT(I+1)
1 CONTINUE
TRADR = HEXOF(TRADDR)
WRITE (11,'(A,A)') '*TRANSFER ADDRESS RECORD FOUND: $',TRADR
IF (DISK) WRITE (9,'(A,A)') '*TRANSFER ADDRESS RECORD FOUND: $',TRADR
CALL ENTHSH(ADDREF(0),14,TRADDR,ADRNDX)
DONE = .FALSE.
IF (DOJSR.AND.JSRNUM.LT.4096) THEN
JSRTRG(JSRNUM,1) = TRADDR
JSRTRG(JSRNUM,2) = -1
JSRNUM = JSRNUM + 1
ENDIF
IF (BLKBEG.EQ.-1) THEN
BLKBEG = TRADDR
ELSE
BLKBEG = MIN(BLKBEG,TRADDR)
ENDIF
WHERE = 0
IKOFST = 0
ELSEIF (DSKBYT(0).EQ.$03) THEN
FIRST = .TRUE.
IF (DOCORE.OR.NEWSTL) GOTO 4333
IKOFST = 0
DO 4332 I = 0,3
MEMBYT(I) = DSKBYT(I+1)
4332 CONTINUE
READ (10,ERR=4333,END=4333) NEWBYT(2),NEWBYT(3)
4333 CONTINUE
IF (BLKBEG.EQ.-1) THEN
BLKBEG = MEMADR
BLKEND = MEMADR + NEWLEN
CALL ENTHSH(ADDREF(0),14,BLKBEG,ADRNDX)
ELSE
BLKBEG = MIN(BLKBEG,MEMADR)
IF (BLKEND.EQ.-1) THEN
BLKEND = MEMADR + NEWLEN
ELSE
BLKEND = MAX(BLKEND,MEMADR+NEWLEN)
ENDIF
ENDIF
MMADR = HEXOF(MEMADR)
IF (FIRST) WRITE (11,'(A,I12,A,A)') '*(new) MEMORY IMAGE RECORD FOUND,
',NEWLEN,' BYTES @ $',MMADR
IF (.NOT.FIRST) WRITE (11,'(A,I12,A,A)') '*(new) MEMORY IMAGE RECORD
cont., ',NEWLEN,' BYTES @ $',MMADR
OLDEND = END
IF (NEWLEN.GT.32700) THEN
LEN = 32700
ELSE
LEN = NEWLEN
ENDIF
IF (LEN.GT.32720) LEN = 32720
IF ((LEN+IKOFST).GT.32760) LEN = 32760 - IKOFST
NEWLEN = NEWLEN - LEN
END = LEN - 1 + IKOFST
ICORE = MEMADR
IF (DOCORE) THEN
IB = KADDR(BYTES(0))
IM = MEMADR
IL = ((END + 128)/4)*4
IF (IL.GT.32760) IL = 32760
CALL IIC0PY(IM,IB,IL)
ELSE
IF (WHERE.NE.0.AND.IKOFST.NE.0) THEN
DO 7776 IJK = 0,IKOFST-1
BYTES(IJK) = BYTES(WHERE+IJK)
7776 CONTINUE
ENDIF
READ (10,ERR=7777,END=7777) (BYTES(I),I=IKOFST,IKOFST+END)
ENDIF
7777 CONTINUE
IF (MEMADR.NE.ICORE) THEN
PRINT *,'MEMADR SMASHED, RESTORING ..',MEMADR,' ',ICORE
MEMADR = ICORE
ENDIF
END = LEN - 1 + IKOFST
NEWSTL = NEWLEN .GT. 0
DONE = DOCORE
CALL DOIT
LINPTR = 1
FIRST = .FALSE.
IKOFST = END - WHERE + 1
IF (IKOFST.LT.0) IKOFST = 0
IF (NEWSTL) MEMADR = MEMADR + WHERE
IF (NEWSTL) GOTO 4333
FIRST = .TRUE.
ENDFIL = DOCORE
NEWLEN = 0
DONE = .FALSE.
GOTO 9900
ELSEIF (DSKBYT(0).EQ.$02) THEN
DO 2 I = 0,3
MEMBYT(I) = DSKBYT(I+1)
2 CONTINUE
MMADR = HEXOF(MEMADR)
OLDEND = END
READ (10,END=8997) ABYTE
12 LEN = ABYTE
LEN = IABS(MOD(LEN,256)+256)
LEN = MOD(LEN,256)
IF (BLKBEG.EQ.-1) THEN
BLKBEG = MEMADR
BLKEND = MEMADR + LEN
ELSE
BLKBEG = MIN(BLKBEG,MEMADR)
IF (BLKEND.EQ.-1) THEN
BLKEND = MEMADR + LEN
ELSE
BLKEND = MAX(BLKEND,MEMADR+LEN)
ENDIF
ENDIF
CALL ENTHSH(ADDREF(0),14,BLKBEG,ADRNDX)
WRITE (11,'(A,I3,A,A)') '*(old) MEMORY IMAGE RECORD FOUND, ',LEN,' BYTES @
$',MMADR
END = LEN - 1
IF (END.GT.255) END = 255
READ (10,END=8996) (BYTES(I),I=0,END)
READ (10,END=8996) (DSKBYT(I),I=0,4)
IF (DSKBYT(0).EQ.$02) THEN
IMMADR = MEMADR
DO 3 I = 0,3
MEMBYT(I) = DSKBYT(I+1)
3 CONTINUE
IF (MEMADR.EQ.(IMMADR+END+1)) THEN
DONE = .FALSE.
SAVEND = END + 1
READ (10,END=8999) ABYTE
LEN = ABYTE
LEN = IABS(MOD(LEN,256)+256)
END = MOD(LEN,256) - 1
WRITE (11,'(A,I3,A,A)') '*MORE MEM RECORD FOUND, ',LEN,' MORE
BYTES @ $',MMADR
IF (END.GT.255) END = 255
END = END + SAVEND
READ (10,END=8998) (BYTES(I),I=SAVEND,END)
GOTO 11
8998 ENDFIL = .TRUE.
GOTO 11
11 CONTINUE
ELSE
DONE = .TRUE.
MEMADR = IMMADR
ENDIF
MEMADR = IMMADR
ELSE
DONE = .TRUE.
ENDIF
GOTO 13
8997 ENDFIL = .TRUE.
GOTO 12
8996 ENDFIL = .TRUE.
13 CONTINUE
CALL DOIT
LINPTR = 1
ELSEIF (DSKBYT(0).EQ.0) THEN
DO 9 I = 0,3
DSKBYT(I) = DSKBYT(I+1)
9 CONTINUE
DSKBYT(4) = 0
IF (.NOT.ENDFIL) READ (10,END=8999) DSKBYT(4)
IF (ENDFIL) GOTO 9900
DONE = .TRUE.
GOTO 9998
ELSE
WRITE (11,'(A)') 'UNKNOWN RECORD TYPE FOUND - FILE PRESUMED NOT TO BE
BINARY'
WRITE (11,'(A,I3,A)') 'FIRST BYTE IS ',DSKBYT(0),' INSTRUCTIONS PLEASE?'
7 CALL GETKEY(ASC,SCAN,KBF1,KBF2,ERR)
IF (ERR.NE.0) GOTO 7
IF (ASC.EQ.3) GOTO 6882
IF (CHAR(ASC).EQ.'?') THEN
PRINT *,'^C = ABORT '
PRINT *,'^E = END PROCESSING OF CURRENT FILE'
PRINT *,'^A = ACCEPT IT ANYWAY ...'
PRINT *,'^T = REJECT n BYTES (n IS ASKED FOR)'
PRINT *,'^O = GO ON ...'
PRINT *,'^R = REWIND ...'
PRINT *,'^F = NEW FILE ...'
GOTO 7
ENDIF
IF (ASC.EQ.5) THEN
ENDFIL = .TRUE.
GOTO 9900
ELSEIF (ASC.EQ.6) THEN
A(1) = .FALSE.
GOTO 4664
ELSEIF (ASC.EQ.18) THEN
DONE = .FALSE.
CLOSE (UNIT=92,ERR=7993)
CLOSE (UNIT=91,ERR=7993)
REWIND (10,ERR=7993)
7993 REWIND (10,ERR=9999)
GOTO 9999
ELSEIF (ASC.EQ.1) THEN
BYTES(0) = DSKBYT(0)
BYTES(1) = DSKBYT(1)
BYTES(2) = DSKBYT(2)
BYTES(3) = DSKBYT(3)
BYTES(4) = DSKBYT(4)
PRINT *,'How many bytes total?'
READ (*,*,ERR=7) NTHROW
IF (NTHROW.LE.0.OR.NTHROW.GT.512) NTHROW = 512
READ (10) (BYTES(I),I=5,NTHROW)
LEN = NTHROW
4437 PRINT *,'What start address?'
READ (*,*,ERR=4437) NTHROW
IF (NTHROW.LT.0) NTHROW = 0
MEMADR = NTHROW
MMADR = HEXOF(MEMADR)
CALL DOIT
LINPTR = 1
ELSEIF (ASC.EQ.15) THEN
ELSEIF (ASC.EQ.20) THEN
PRINT *,'WHAT n?'
READ (*,*,ERR=7) NTHROW
READ (10) (BYTES(I),I=2,NTHROW)
READ (10) DSKBYT(0)
GOTO 7
ELSE
GOTO 7
ENDIF
DO 8 I = 0,3
DSKBYT(I) = DSKBYT(I+1)
8 CONTINUE
DSKBYT(4) = 0
IF (.NOT.ENDFIL) READ (10,END=8999) DSKBYT(4)
IF (ENDFIL) GOTO 9900
DONE = .TRUE.
GOTO 9998
ENDIF
9900 CONTINUE
IF (ENDFIL) THEN
IF (DONE.AND.ONETH) THEN
ONETH = .FALSE.
GOTO 9998
ENDIF
LINPTR = 1
DOJSR = JSRNUM.GT.1
IF (DOJSR) THEN
LINES(LINPTR) = '* '
LINPTR = LINPTR + 1
LINES(LINPTR) = '*Subroutine calls - destination and source are: '
LINPTR = LINPTR + 1
DO 9911 J = 1,JSRNUM-1,2
HLIN(1) = ' '
HLIN(2) = ' '
K = J + 1
THEHEX = HEXOF(JSRTRG(J,1))
TH2 = HEXOF(JSRTRG(J,2))
IF (JSRTRG(J,1).EQ.-2) THEN
HLIN(1) = '* RTS occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(J,1).EQ.-3) THEN
HLIN(1) = '* RTR occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(J,1).EQ.-4) THEN
HLIN(1) = '* RTE occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(J,1).EQ.-5) THEN
HLIN(1) = '* RTD occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(J,1).EQ.-1) THEN
HLIN(1) = '*$?????? called from $'//TH2(3:8)
ELSEIF (JSRTRG(J,2).EQ.-1) THEN
HLIN(1) = '*$'//THEHEX(3:8)//' is ENTRY POINT '
ELSE
HLIN(1) = '*$'//THEHEX(3:8)//' called from $'//TH2(3:8)
ENDIF
IF (K.LT.JSRNUM) THEN
THEHEX = HEXOF(JSRTRG(K,1))
TH2 = HEXOF(JSRTRG(K,2))
IF (JSRTRG(K,1).EQ.-2) THEN
HLIN(2) = '* RTS occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(K,1).EQ.-3) THEN
HLIN(2) = '* RTR occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(K,1).EQ.-4) THEN
HLIN(2) = '* RTE occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(K,1).EQ.-5) THEN
HLIN(2) = '* RTD occurs at $'//TH2(3:8)
ELSEIF (JSRTRG(K,1).EQ.-1) THEN
HLIN(2) = '*$?????? called from $'//TH2(3:8)
ELSEIF (JSRTRG(K,2).EQ.-1) THEN
HLIN(2) = '*$'//THEHEX(3:8)//' is ENTRY POINT '
ELSE
HLIN(2) = '*$'//THEHEX(3:8)//' called from $'//TH2(3:8)
ENDIF
ENDIF
LINES(LINPTR) = HLIN(1)//HLIN(2)
LINPTR = LINPTR + 1
9911 CONTINUE
ENDIF
IF (DOJSR.AND.SCREEN) THEN
DO 9812 I = 1,LINPTR-1
PRINT '(A74)',LINES(I)
9812 CONTINUE
ENDIF
IF (DISK.AND.LINPTR.GT.1) THEN
PRINT *,'WRITING LINES TO DISK ...'
INQUIRE (UNIT=9,IOSTAT=IOS)
IF (IOS.NE.0) PRINT *,' OUTPUT FILE IOS = ',IOS
DO 9821 J = 1,3
IOS = 0
WRITE (9,'(A)',ERR=9819,IOSTAT=IOS) LINES(1)
IF (IOS.EQ.0) GOTO 9820
9819 CONTINUE
PRINT *,' TRIES = ',J,' IOS = ',IOS
9821 CONTINUE
9820 CONTINUE
DO 9822 I = 2,(LINPTR-1)
WRITE (9,'(A)',ERR=9823,IOSTAT=IOS) LINES(I)
9822 CONTINUE
9823 CONTINUE
ENDIF
LINPTR = 1
DOBRA = BRANUM.GT.1
IF (DOBRA.AND.DOJSR) THEN
LINES(LINPTR) = '* '
LINPTR = LINPTR + 1
ENDIF
IF (DOBRA) THEN
LINES(LINPTR) = '*BRA''s & JMP''s - destination and source are: '
LINPTR = LINPTR + 1
DO 9910 J = 1,BRANUM-1,2
HLIN(1) = ' '
HLIN(2) = ' '
K = J + 1
THEHEX = HEXOF(BRATRG(J,1))
TH2 = HEXOF(BRATRG(J,2))
IF (BRATRG(J,1).EQ.-1) THEN
HLIN(1) = '*?????? jumped to from $'//TH2(3:8)
ELSE
HLIN(1) = '*'//THEHEX(3:8)//' jumped to from $'//TH2(3:8)
ENDIF
IF (K.LT.BRANUM) THEN
THEHEX = HEXOF(BRATRG(K,1))
TH2 = HEXOF(BRATRG(K,2))
IF (BRATRG(K,1).EQ.-1) THEN
HLIN(2) = '*?????? jumped to from $'//TH2(3:8)
ELSE
HLIN(2) = '*'//THEHEX(3:8)//' jumped to from $'//TH2(3:8)
ENDIF
ENDIF
LINES(LINPTR) = HLIN(1)//HLIN(2)
LINPTR = LINPTR + 1
9910 CONTINUE
ENDIF
IF (DOBRA.OR.DOJSR.AND.SCREEN) THEN
DO 9912 I = 1,LINPTR-1
PRINT '(A74)',LINES(I)
9912 CONTINUE
ENDIF
IF (SCREEN) PRINT *,' END'
IF (DISK) THEN
PRINT *,'WRITING LINES TO DISK ...'
INQUIRE (UNIT=9,IOSTAT=IOS)
IF (IOS.NE.0) PRINT *,' OUTPUT FILE IOS = ',IOS
IF (LINPTR.GT.1) THEN
DO 9921 J = 1,3
IOS = 0
WRITE (9,'(A)',ERR=9919,IOSTAT=IOS) LINES(1)
IF (IOS.EQ.0) GOTO 9920
9919 CONTINUE
PRINT *,' TRIES = ',J,' IOS = ',IOS
9921 CONTINUE
9920 CONTINUE
DO 9922 I = 2,(LINPTR-1)
IF (PGECOM) COUNT = COUNT + 1
WRITE (9,'(A)',ERR=9923,IOSTAT=IOS) LINES(I)
IF (PGECOM.AND.COUNT.GE.57) THEN
PAGENO = PAGENO + 1
WRITE (PAGE,'(''Page '',I3)') PAGENO
LABLE(2)(43:50) = PAGE
IF (PAGEQQ) WRITE (9,'(A,A)') CHAR(12),CHAR(13)
IF (.NOT.PAGEQQ) WRITE (9,'(A)') '*^L'
WRITE (9,'(A)') LABLE(1)
WRITE (9,'(A)') LABLE(2)
COUNT = 0
ENDIF
9922 CONTINUE
9923 CONTINUE
IF (IOS.EQ.0) THEN
PRINT *,'THIS DISK WRITE FINISHED ...'
ELSE
PRINT *,'DISK WRITE ABORTED, ERROR CODE = ',IOS
ENDIF
ENDIF
WRITE (9,'(A)',ERR=9924) ' END'
ENDIF
9924 CONTINUE
CLOSE (UNIT=9,ERR=9901)
9901 CONTINUE
IFOO = NARG()
IF (IFOO.GT.0) STOP
GOTO 5446
ENDIF
GOTO 9999
8999 CONTINUE
ENDFIL = .TRUE.
GOTO 9998
5445 PRINT *,'FILE NOT FOUND: ',INFILE
GOTO 4545
5446 CONTINUE
CALL CRCLS
WRITE (12,'(A)') ' '
PRINT *,'ADDRESS REFERENCE ENTRIES NUMBER ',ADRNDX-1
IF (.NOT.FOUND) THEN
PRINT *,' REDO w/ADDRESS REFERENCE DATA? (Y/n)'
IJ = MENU(1,0,1)
IF (IJ.EQ.1) THEN
FOUND = .TRUE.
ASKED = .FALSE.
IF (DOCORE) THEN
NEWLEN = BLKEND - BLKBEG
ICORE = BLKBEG
MEMADR = ICORE
DSKBYT(0) = 3
GOTO 6602
ENDIF
REWIND (10,ERR=4696)
4696 CLOSE (10,ERR=4695)
4695 OPEN (10,FILE='DIR.DIR',ERR=4694)
4694 CLOSE (10,ERR=4646)
GOTO 4646
ENDIF
PRINT *,' SAVE ADDRESS REFERENCE DATA? (Y/n)'
IJ = MENU(1,0,1)
ELSE
PRINT *,' SAVE ADDRESS REFERENCE DATA? (y/N)'
IJ = MENU(0,0,1)
ENDIF
IF (IJ.EQ.1) THEN
IF (FOUND) THEN
INFIL2 = ADRFIL
ELSE
OFNVOL = ' '
OFN = ' '
OFNEXT = ' '
CALL EXPAND(OUTFIL,OFNVOL,OFN,OFNEXT)
IF (OFN.EQ.' ') OFN = FN
OFNEXT = 'ADR'
INFIL2 = OFNVOL//':'//OFN//'.'//OFNEXT
CALL STRIPF(INFIL2)
ENDIF
J = 0
PRINT *,'OUTPUT TO ',INFIL2(1:19),' or specify file.'
6775 READ (*,'(A)',ERR=6883) IIFIL
IF (IIFIL.NE.' ') CALL FNCHCK(IIFIL,'ADR',INFIL2)
PRINT *,' '
PRINT *,'OUTPUT TO ',INFIL2(1:19)
CLOSE (UNIT=92,ERR=6773)
6773 CLOSE (UNIT=91,ERR=6883)
6883 OPEN (UNIT=91,FILE='DIR.DIR',ERR=6884)
6884 CLOSE (UNIT=91,STATUS='KEEP',ERR=6885)
6885 OPEN
(UNIT=91,FILE=INFIL2,STATUS='NEW',FORM='BINARY',ACCESS='SEQUENTIAL',ERR=6772)
GOTO 6774
6772 PRINT *,'OPEN ERROR ',INFIL2
PRINT *,'SPECIFY NEW FILE NAME'
J = J + 1
IF (J.LT.4) GOTO 6775
6774 CONTINUE
WRITE (91,ERR=6882) (ADDRSQ(I),I=0,16384)
CLOSE (91,STATUS='KEEP',ERR=6882)
ENDIF
6882 WRITE (12,'(A)') ' '
WRITE (12,'(A//////)') ' '
WRITE (12,'(A)') 'DO ANOTHER? (y/N)'
IJ = MENU(0,0,1)
DOCORE = .FALSE.
SET = .FALSE.
ASKED = .FALSE.
NUMARG = 0
IF (IJ.EQ.1) GOTO 4545
STOP
8934 RETRY = .TRUE.
GOTO 2434
END
*----------------------------------------------------------------------
$CHAREQU
SUBROUTINE DOIT
CHARACTER*1 TC,TCALGN(2),CHR,IN
CHARACTER*8 HEXOF,PAGE,MMADR,THB,THE
CHARACTER*10 ASMOUT(7),LABEL,OPCODE,OPS(3),VAL,ADDR,ALLOPS*30
CHARACTER*70 LABLE(3)
CHARACTER*74 LINES(1200),HEXLN
INTEGER*4 NEWLEN,LINPTR,TRADDR,MEMADR,ADDREF(0:16383),ADRNDX,BLKBEG
INTEGER*4 BRATRG(4096,2),JSRTRG(4096,2),BRANUM,JSRNUM,BLKEND
INTEGER*2 ASC,SCAN,KBF1,KBF2,ERR,IASC,ISCAN,IKBF1,IKBF2,IERR
INTEGER*2 COUNT,PAGENO,CODEW(0:16383),WHERE,END,OLDEND
INTEGER*1 CODEB(0:1,0:16383),BYTES(0:32767),TRBYTE(0:3),MEMBYT(0:3)
INTEGER*1 ABYTE
LOGICAL*4 NEWSTL,ISOPEN,FIRST
LOGICAL*2 ABORT,ESCAPE,INTRPT,RSH,LSH,CTRL,ALT,SCRL,NUML,CAPS,INS
LOGICAL*2 SCREEN,PAGEQQ,DISK,ENDFIL,STOPFL,ABORTF,DODCW,DODCL,FOUND
LOGICAL*2 ARRGH,ARRGH2,PGECOM,XQUIET,TRUNCF,DOHEX,SKIPF,DOSTR
LOGICAL*2 DOABS,SPRSLX,SPRSXA,SRCWXR,DSTWXR,SHRTBR,SGNDSP,DOBRA,DOJSR
EQUIVALENCE (ASC,IASC),(SCAN,ISCAN),(KBF1,IKBF1),(KBF2,IKBF2),(ERR,IERR)
EQUIVALENCE (TCALGN(1),IASC),(TCALGN(2),TC)
EQUIVALENCE (ASMOUT(1),LABEL),(ASMOUT(2),OPCODE),(ASMOUT(6),VAL)
EQUIVALENCE (ASMOUT(7),ADDR),(ASMOUT(3),OPS(1))
EQUIVALENCE
(CODEW(0),CODEB(0,0),BYTES(0)),(TRADDR,TRBYTE(0)),(MEMADR,MEMBYT(0))
COMMON /BRAJSR/BRATRG,JSRTRG,BRANUM,JSRNUM,DOBRA,DOJSR
COMMON
/CODE/IPAD,CODEW,WHERE,END,TRADDR,MEMADR,/NEWSTF/NEWLEN,NEWSTL,DODCW,DODCL,FIRST
COMMON /DISASM/ASMOUT,LINES,MMADR,ALLOPS,/HEADER/LABLE
COMMON /KEYGET/IASC,ISCAN,IKBF1,IKBF2,IERR,/NTRVN/ABORT,ESCAPE,INTRPT
COMMON /SHFSTA/RSH,LSH,CTRL,ALT,SCRL,NUML,CAPS,INS,/HEXDO/DOHEX
COMMON /MODESQ/DOABS,SPRSLX,SPRSXA,SRCWXR,DSTWXR,SHRTBR,SGNDSP
COMMON
/GARRH/ARRGH,ARRGH2,PGECOM,XQUIET,/REFS/ADDREF,ADRNDX,BLKBEG,BLKEND,FOUND
COMMON /FLAGS/SCREEN,PAGEQQ,DISK,ENDFIL
COMMON /DISNUM/LINPTR,/HEADRE/COUNT,PAGENO
SAVE /KEYGET/,/SHFSTA/,/NTRVN/,/REFS/,DOSTR
EXTERNAL DISLIN
SAVE
DOSTR = (DODCL.AND.DODCW)
IF (DOSTR) THEN
DODCW = .FALSE.
DODCL = .FALSE.
ENDIF
ARRGH = .FALSE.
ARRGH2 = .FALSE.
STOPFL = .FALSE.
SKIPF = .FALSE.
ABORTF = .FALSE.
TRUNCF = .FALSE.
SRCWXR = .FALSE.
DSTWXR = .FALSE.
LINPTR = 3
WHERE = 0
LINES(1) = '* THIS SECTION ORIGINATES AT $'//MMADR
LINES(2) = LABLE(3)
IF (DOHEX) THEN
CALL DOIDMP(HEXLN,BYTES(0))
LINES(3) = '* '//HEXLN
LINPTR = 4
ENDIF
IF (FIRST) THEN
OPCODE = 'EQU '
LINES(LINPTR) = LABEL//OPCODE//'*'
LINPTR = LINPTR + 1
THB = HEXOF(BLKBEG)
THE = HEXOF(BLKEND)
LINES(LINPTR) = '* block limits are $'//THB//' to $'//THE
LINPTR = LINPTR + 1
ENDIF
IF (BLKBEG.EQ.-1) BLKBEG = MIN(MEMADR,TRADDR,$DC08)
IF (BLKEND.LT.BLKBEG) BLKEND = TRADDR + NEWLEN
LABEL = ' '
LSTLIN = 1
IHC = WHERE
1 CONTINUE
LLM = LSTLIN
IF (SCREEN) THEN
DO 5465 LLL = LLM,(LINPTR-1)
PRINT '(A75)',LINES(LLL)
5465 CONTINUE
ENDIF
CALL ISNTRP
IF (ERR.NE.0) THEN
ASC = 0
ELSE
IF (INTRPT) THEN
IF (STOPFL) STOP ' USER INITIATED ABORT'
STOPFL = .TRUE.
WRITE (11,*) 'ANOTHER ^C TO HALT ...'
ELSE
STOPFL = .FALSE.
ENDIF
IF (ESCAPE) RETURN
IF (ABORT) STOP ' USER INITIATED ABORT'
IF (ASC.EQ.1) THEN
IF (ABORTF) THEN
WHERE = END + 1
RETURN
ENDIF
ABORTF = .TRUE.
WRITE (11,*) 'ANOTHER ^A TO ABORT REST OF BLOCK ...'
ELSE
ABORTF = .FALSE.
ENDIF
IF (ASC.EQ.0.AND.SCAN.EQ.$1E) THEN
IF (SKIPF) THEN
WHERE = END + 1
NEWLEN = 0
RETURN
ENDIF
SKIPF = .TRUE.
WRITE (11,*) 'ANOTHER !A TO ABORT REST OF DISASSEMBLY ...'
ELSE
SKIPF = .FALSE.
ENDIF
IF (ASC.EQ.20) THEN
IF (TRUNCF) THEN
WHERE = END + 1
GOTO 7887
ENDIF
TRUNCF = .TRUE.
WRITE (11,*) 'ANOTHER ^T TO TRUNCATE REST OF BLOCK ...'
ELSE
TRUNCF = .FALSE.
ENDIF
IF (ASC.EQ.15) THEN
SCREEN = .NOT.SCREEN
PRINT *,'^O ...'
ELSEIF (ASC.EQ.17) THEN
SCREEN = .TRUE.
ELSEIF (ASC.EQ.19) THEN
SCREEN = .FALSE.
ELSEIF (ASC.EQ.8) THEN
DOHEX = .TRUE.
PRINT *,' HEX COMMENTARY ENABLED'
ELSEIF (ASC.EQ.0.AND.SCAN.EQ.$23) THEN
DOHEX = .FALSE.
PRINT *,' HEX COMMENTARY DISABLED'
ELSEIF (ASC.EQ.2) THEN
DOBRA = .TRUE.
PRINT *,' BRANCH LIST ENABLED'
ELSEIF (ASC.EQ.0.AND.SCAN.EQ.$30) THEN
DOBRA = .FALSE.
PRINT *,' BRANCH LIST DISABLED'
ELSEIF (ASC.EQ.10) THEN
DOJSR = .TRUE.
PRINT *,' JSR LIST ENABLED'
ELSEIF (ASC.EQ.0.AND.SCAN.EQ.$24) THEN
DOJSR = .FALSE.
PRINT *,' JSR LIST DISABLED'
ELSEIF (ASC.EQ.23) THEN
DODCW = .TRUE.
PRINT *,' DC.W ENABLED'
ELSEIF (ASC.EQ.0.AND.SCAN.EQ.$11) THEN
DODCW = .FALSE.
PRINT *,' DC.W DISABLED'
ELSEIF (ASC.EQ.12) THEN
DODCL = .TRUE.
PRINT *,' DC.L ENABLED'
ELSEIF (ASC.EQ.0.AND.SCAN.EQ.$26) THEN
DODCL = .FALSE.
PRINT *,' DC.L DISABLED'
ELSEIF (ASC.EQ.25) THEN
ARRGH2 = .NOT. ARRGH2
ELSEIF (ASC.EQ.26) THEN
ARRGH = .NOT. ARRGH
ELSEIF (ASC.EQ.5) THEN
XQUIET = .FALSE.
ELSEIF (ASC.EQ.0.AND.SCAN.EQ.$12) THEN
XQUIET = .TRUE.
ELSEIF (TC.EQ.'"') THEN
DOSTR = .TRUE.
PRINT *,' STRINGS ENABLED'
ELSEIF (TC.EQ.'~') THEN
DOSTR = .FALSE.
PRINT *,' STRINGS DISABLED'
ELSEIF (TC.EQ.'?') THEN
CALL CRCLS
PRINT *,' '
PRINT *,' ^S ^O turn OFF screen output, when also writing to disk'
PRINT *,' ^Q turn ON screen output, when also writing to disk'
PRINT *,' '
PRINT *,' ^E turn ON EXTENDED comments '
PRINT *,' !E turn OFF EXTENDED comments '
PRINT *,' ^H turn ON HEX comments !H turn OFF HEX
comments '
PRINT *,' ^B turn ON BRA/Bcc/JMP list !B turn OFF
BRA/Bcc/JMP list'
PRINT *,' ^J turn ON BSR/JSR list !J turn OFF
BSR/JSR list '
PRINT *,' ^W ENABLE DC.W OUTPUT !W DISABLE DC.W
OUTPUT'
PRINT *,' ^L ENABLE DC.L OUTPUT !L DISABLE DC.L
OUTPUT'
PRINT *,' " ENABLE strings ~ DISABLE
strings'
PRINT *,' '
PRINT *,' ^T^T Truncate - write output to disk, ignore rest of
block'
PRINT *,' ^A^A Abort - DO NOT write to disk, ignore rest of block'
PRINT *,' !A!A ABORT - DO NOT write to disk, ignore REST '
PRINT *,' ^C^C QUIT - EXITS PROGRAM!'
CALL PAUSE(' ')
ENDIF
ENDIF
LSTLIN = LINPTR
IWHGE = WHERE
CALL TSTDCB
IF (DOSTR.AND.LINPTR.EQ.LSTLIN) CALL TSTSTR
IF (LINPTR.EQ.LSTLIN) THEN
IF (DOHEX) THEN
K = WHERE - IHC
IF (K.GE.16) THEN
IHC = WHERE
CALL DOIDMP(HEXLN,BYTES(WHERE))
LINES(LINPTR) = '* '//HEXLN
LINPTR = LINPTR + 1
ENDIF
ENDIF
CALL DISLIN
ENDIF
IF (IWHGE.GE.WHERE) THEN
LINES(LINPTR) = '**DISASM ERROR: WHERE NOT ADVANCED!'//LINES(LINPTR-
1)(61:70)
WHERE = IWHGE + 2
IF (.NOT.SCREEN) THEN
PRINT *,' '
PRINT *,LINES(LINPTR)
PRINT *,' '
ENDIF
LINPTR = LINPTR + 1
ENDIF
IF (LINPTR.LT.1100) THEN
IF ((NEWLEN.EQ.0.OR.END.LE.256).AND.WHERE.LT.END) GOTO 1
IF ((WHERE+8).LT.END) GOTO 1
ENDIF
7887 CONTINUE
IF (DISK) THEN
PRINT *,'WRITING ',LINPTR-1,' LINES TO DISK ...'
INQUIRE (UNIT=9,IOSTAT=IOS,OPENED=ISOPEN)
IF (IOS.NE.0) PRINT *,' OUTPUT FILE IOS = ',IOS
IF (.NOT.ISOPEN) THEN
PRINT *,' OUTPUT FILE CLOSED!!'
ENDIF
DO 2 I = 1,(LINPTR-1)
IF (PGECOM) COUNT = COUNT + 1
WRITE (9,'(A)',ERR=3,IOSTAT=IOS) LINES(I)
IF (PGECOM.AND.COUNT.GE.57) THEN
PAGENO = PAGENO + 1
WRITE (PAGE,'(''Page '',I3)') PAGENO
LABLE(2)(43:50) = PAGE
IF (PAGEQQ) WRITE (9,'(A,A)') CHAR(12),CHAR(13)
IF (.NOT.PAGEQQ) WRITE (9,'(A)') '*^L'
WRITE (9,'(A)') LABLE(1)
WRITE (9,'(A)') LABLE(2)
COUNT = 0
ENDIF
2 CONTINUE
3 CONTINUE
IF (IOS.EQ.0) THEN
PRINT *,'THIS DISK WRITE FINISHED ...'
ELSE
PRINT *,'DISK WRITE ABORTED, ERROR CODE = ',IOS
ENDIF
ENDIF
IF (SCREEN) THEN
DO 6554 LLL = LSTLIN,(LINPTR-1)
PRINT '(A75)',LINES(LLL)
6554 CONTINUE
ENDIF
IF (LINPTR.GE.1100) THEN
LINPTR = 1
IF ((NEWLEN.EQ.0.OR.END.LE.256).AND.WHERE.LT.END) GOTO 1
IF ((WHERE+8).LT.END) GOTO 1
ENDIF
9999 CONTINUE
IF (SCREEN) THEN
DO 6564 LLL = LSTLIN,(LINPTR-1)
PRINT '(A75)',LINES(LLL)
6564 CONTINUE
ENDIF
RETURN
END
*----------------------------------------------------------------------
SUBROUTINE READDR
INTEGER*4 ADRNDX,ADDREF(0:16383),ADDRSQ(0:16384),BLKBEG,BLKEND
LOGICAL*2 FOUND
EQUIVALENCE (ADDRSQ(16384),ADRNDX),(ADDRSQ(0),ADDREF(0))
COMMON /REFS/ADDRSQ,BLKBEG,BLKEND,FOUND
SAVE /REFS/
ITRY = 0
ADRNDX = 1
CLOSE (UNIT=91,STATUS='KEEP',ERR=1)
1 CONTINUE
ITRY = ITRY + 1
IF (ITRY.EQ.2) THEN
PRINT *,'READ ERROR ON ADR FILE, RETRY ... '
REWIND (92,ERR=4)
ELSEIF (ITRY.EQ.3) THEN
CALL REWIND(92)
ELSEIF (ITRY.GE.4) THEN
GOTO 3
ENDIF
4 READ (92,ERR=1,END=3) (ADDREF(I),I=0,16383)
READ (92,ERR=1,END=2) ADRNDX
2 RETURN
3 ADRNDX = 1
GOTO 2
END

You might also like

pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy