	program scrunch
d    &_d

*
*	Use at your own risk! Program scruncher to remove
*	debugger and traceback records from an EXE file
*
*	Author:	Eric F. Richards
*	Date:	08-May-85
*	System:	Hiram College VAX/VMS V3.6
*
*	Revised 30-Jul-85 by EFR for V4 compatibility
*	Revised 09-Oct-85 by EFR to "de-traceback" images compiled strangely
*
*	To compile:
*
*	$ FOR/CHECK=NONE SCRUNCH	/D_LINES if you've patched EXE headers
*	$ LINK/NOTRACE SCRUNCH, SYS$INPUT/OPT
*	STACK=10
*	DZRO=1
*	^Z
*
*	Scrunch must be run on itself after linking, due to a linker
*	bug involving referencing SYS$IMGSTA.
*

	implicit  integer(a-z)
	logical	  not_traced
d	logical	  must_kludge
	integer*4 header_long(128)
	integer*2 header_word(256)
	byte	  header_byte(512)

	character*512 header_block
	character*78  infname, outfname, str

	equivalence(infname, str)
	equivalence(header_byte(1), header_block)
	equivalence(header_byte(1), header_word(1))
	equivalence(header_byte(1), header_long(1))

	common header_block

d	external sys$qiow			! for use as
d	external sys$imgsta			! reference to old SYS$IMGSTA

	parameter vers = 'V2.03'
d    &				//'A'		! to show optional version
	parameter maj  = '02'			! majorid
	parameter min  = '05'			! minorid

	parameter reclen = 128
d	parameter s0_qiow = '80000000'X		! pre-V3 address for sys$qiow
	parameter fatal = 'Image file is corrupt'
	parameter error = 'error'
	parameter msg = 'Warning - major/minor ID mismatch - '//
     &			'compressed image may be unreliable.'

*
*	Determine the two entry points for SYS$IMGSTA - the
*	pre-V3 entry point is in system (S0) space, and the
*	V3+ entry point is in P1 space. V1 entry point is
*	at the end of the image, similar to V2 rtl stuff.
*	kludge handles those entry points.
*
d	sys_qiow   = %loc(sys$qiow)
d	sys_imgsta = %loc(sys$imgsta)
d	s0_imgsta  = (s0_qiow - sys_qiow) + sys_imgsta
	
	print 500, vers
	if ((lib$get_input(infname, 'Input file: ').and.1) .eq. 1) then
	  if ((lib$get_input(outfname, 'Output file: ').and.1) .eq. 1) then

	    open(	unit = 1,
     &			defaultfile = '.exe',
     &			file = infname,
     &			status = 'old',
     &			shared,
     &			readonly,
     &			recordtype = 'fixed',
     &			recl = reclen,
     &			form = 'unformatted',
     &			err = 10)

*
*	Get image header.  Is it a candidate for SCRUNCHing?
*

	    read(1) header_block

d	    must_kludge = (header_block(13:16) .eq. '0201')

	    if (header_word(256) .ne. -1) then
	      print *, 'Not a native mode VAX/VMS image, aborting.'

	    else if (header_word(5) .ne. 0) then
	      print *, 'Image has been patched and cannot be compressed.'

	    else
*
*	Try to remove SYS$IMGSTA transfer address, if present
*	Kludge to accept ident 0201 images
*
	      not_traced = .true.
	      t_adr = (header_word(2) / 4) + 1
	      if (t_adr .ne. 1) then
d		if ( (header_long(t_adr) .eq. sys_imgsta) .or.
d    &		     (header_long(t_adr) .eq. s0_imgsta) .or.
d    &		     must_kludge ) then

		  not_traced		= .false.
		  t_a_2			= t_adr + 1
	 	  t_a_3			= t_a_2 + 1
		  header_long(t_adr)	= header_long(t_a_2)
		  header_long(t_a_2)	= header_long(t_a_3)
		  header_long(t_a_3)	= 0

d		end if
	      end if

*
*	Determine if symbol table information is present.  If so, use
*	information to determine the length of the output EXE file.
*	Otherwise, just try to wing it and see what happens.
*

	      symtbl = (header_word(3) / 4) + 1
	      length = header_long(symtbl) - 1
	      if (
d    &		     (not_traced .or. must_kludge) .and.
     &		    ((symtbl .eq. 1) .or. (length .eq. -1))) then
		print *, 'Image cannot be compressed any further.'
	      else
		if (symtbl .eq. 1) then
		  length = -1
		else
*
*	Erase global symbol table pointers, saving length of actual code
*
		  endtbl = (header_word(4) / 4)
		  if (endtbl .lt. symtbl) endtbl = symtbl + 2
		  do i = symtbl, endtbl
		    header_long(i) = 0
		  end do

		end if
*
*	Remove the DEBUG flag from the link-flag array
*
		header_long(9) = (header_long(9) .and. -2)

*
*	Open the output file for the new version of the SCRUNCHed image
*

		open(	unit = 2,
     &			defaultfile = '.exe',
     &			file = outfname,
     &			status = 'new',
     &			recordtype = 'fixed',
     &			recl = reclen,
     &			form = 'unformatted',
     &			err = 20)

*
*	Begin copying everything over - Start with the modified header block
*	Check major/minor ID to see if this is an EXE we know about. If it
*	isn't, try to work on it anyway -- it's possible that it'll still work
*

		if ((header_block(13:14) .ne. maj) .or.
     &		    (header_block(15:16) .gt. min)) print *, msg

		write(2) header_block

*
*	Now do the rest, depending on wether the contents of the header
*	include traceback information, transfer address, or both.
*

d		if (length .ne. -1) then
		  call sys$fao('Image will be compressed to !UL block!%S.',
     &				strlen,
     &				str,
     &				%val(length))
		  print *, str(:strlen)

		  do i = 2, length
		    read(1,end=5,err=7) header_block
		    write(2,err=7) header_block
		  end do

d		else
d		  print *, 'Image will not be compressed - ',
d    &				'debugger transfer address will be removed.'
		

d		  do while (.true.)
d		    read(1,end=3,err=7) header_block
d		    write(2,err=7) header_block
d		  end do
d		end if
*
*	Clean up
*

3		close(2,err=4)
	      end if
	    end if
4	    close(1,err=30)
	  end if
	end if
	goto 30

5	print 1000, 'end-of-file',fatal
	goto 30

7	print 1000, error, fatal
	goto 30

10	print 1000, error, 'Cannot open input file'
	goto 30

20	print 1000, error, 'Cannot open output file'
	close(1)
30	call exit

500	format('0	VAX/VMS executable image compressor ',a/)
1000	format(' Unexpected ', a, ' - ', a, '.')
	end
