h33211
s 00574/00000/00000
d D 1.1 83/03/22 19:53:54 bog 1 0
c date and time created 83/03/22 19:53:54 by bog
e
u
4
U
t
T
I 1
fintel: proc options (main);

/* read intel object module format  9/28/82 */
/* write new object file - J.L	   10/4/82  */
/* fix up lengths -- bog	   17 Nov 82*/

%replace
	false by '0'b,
	true by '1'b;

declare
	typ (0:31) entry variable;

declare
	record_type (31) bit (8) static initial (
		'6E'b4,   /*   1: r-module header  */
		'70'b4,   /*   2: register initialization  */
		'72'b4,   /*   3: relocatable enumerated data  */
		'74'b4,   /*   4: relocatable iterated data  */
		'76'b4,   /*   5: overlay definition  */
		'78'b4,   /*   6: end  */
		'7A'b4,   /*   7: block definition  */
		'7C'b4,   /*   8: block end  */
		'7E'b4,   /*   9: debug symbols  */
		'80'b4,   /*  10: t-module header  */
		'82'b4,   /*  11: l-module header  */
		'84'b4,   /*  12: physical enumerated data  */
		'86'b4,   /*  13: physical iterated data  */
		'88'b4,   /*  14: comment  */
		'8A'b4,   /*  15: module end  */
		'8C'b4,   /*  16: external names definition  */
		'8E'b4,   /*  17: type definition  */
		'90'b4,   /*  18: public names definition  */
		'92'b4,   /*  19: local symbols  */
		'94'b4,   /*  20: line numbers  */
		'96'b4,   /*  21: list of names  */
		'98'b4,   /*  22: segment definition  */
		'9A'b4,   /*  23: group definition  */
		'9C'b4,   /*  24: fixup  */
		'9E'b4,   /*  25: (unused)  */
		'A0'b4,   /*  26: logical enumerated data  */
		'A2'b4,   /*  27: logical iterated data  */
		'A4'b4,   /*  28: library header  */
		'A6'b4,   /*  29: library module names  */
		'A8'b4,   /*  30: library module locations  */
		'AA'b4);  /*  31: library dictionary  */

declare
	record_name (31) char (6) static initial (
		'RHEADR',   /*   1: r-module header  */
		'REGINT',   /*   2: register initialization  */
		'REDATA',   /*   3: relocatable enumerated data  */
		'RIDATA',   /*   4: relocatable iterated data  */
		'OVLDEF',   /*   5: overlay definition  */
		'ENDREC',   /*   6: end  */
		'BLKDEF',   /*   7: block definition  */
		'BLKEND',   /*   8: block end  */
		'DEBSYM',   /*   9: debug symbols  */
		'THEADR',   /*  10: t-module header  */
		'LHEADR',   /*  11: l-module header  */
		'PEDATA',   /*  12: physical enumerated data  */
		'PIDATA',   /*  13: physical iterated data  */
		'COMENT',   /*  14: comment  */
		'MODEND',   /*  15: module end  */
		'EXTDEF',   /*  16: external names definition  */
		'TYPDEF',   /*  17: type definition  */
		'PUBDEF',   /*  18: public names definition  */
		'LOCSYM',   /*  19: local symbols  */
		'LINNUM',   /*  20: line numbers  */
		'LNAMES',   /*  21: list of names  */
		'SEGDEF',   /*  22: segment definition  */
		'GRPDEF',   /*  23: group definition  */
		'FIXUPP',   /*  24: fixup  */
		'(NONE)',   /*  25: (unused)  */
		'LEDATA',   /*  26: logical enumerated data  */
		'LIDATA',   /*  27: logical iterated data  */
		'LIBHED',   /*  28: library header  */
		'LIBNAM',   /*  29: library module names  */
		'LIBLOC',   /*  30: library module locations  */
		'LIBDIC');  /*  31: library dictionary  */

declare
	leaf_type (99:128) char (16) static initial (
		'interrupt',
		'file',
		'packed',
		'unpacked',
		'set',
		'<reserved>',
		'chameleon',
		'boolean',
		'true',
		'false',
		'char',
		'integer',
		'const',
		'<reserved>',
		'label',
		'long',
		'short',
		'procedure',
		'parameter',
		'dimension',
		'array',
		'<reserved>',
		'structure',
		'pointer',
		'scalar',
		'unsigned integer',
		'signed integer',
		'real',
		'list',
		'null');

declare
	source file,
	outfile file,
	library bit (1),
	eof bit (1),
	b bit (8),
	b8 bit (8),
	b16 bit (16),
	bb bit(16) ,
	globalf8 fixed (8),
	(i,j,k) fixed (15),
	group_type bit (8),
	offset fixed (15),
	group_index fixed (15),
	segment_index fixed (15),
	external_index fixed (15),
	lnames_number fixed (15),
	segdef_number fixed (15),
	grpdef_number fixed (15),
	typdef_number fixed (15),
	blkdef_number fixed (15),
	gcode fixed(15),
	gdata fixed(15),
	gextra fixed(15),
	buff (1024) bit (8),
	bufptr fixed (15),
	obuff (1024) bit (8),
	obufptr fixed (15),
	checksum fixed (8),
	ocheck fixed bin(8),
	name_length fixed (7),
	delta_length(255) fixed (15),
	del fixed(15),
	FileDel fixed (15),
	modnum fixed (15),
	record_length fixed (15);
	
declare
	loc_type (0:4) char (7) static initial (
		'lobyte', 'offset', 'base', 'pointer', 'hibyte');

declare
	g(30) char(31) varying;
declare
	fix_type (0:1) char (8) static initial ('self rel', 'segm rel');

declare
	target_method (0:2) char (3) static initial ('SI(', 'GI(', 'EI('),
	frame_method (4:6) char (8) static initial ('location', 'target',
	 'none');
declare
	p pointer,
	1 fil1,
	 2 drv1 char(1),
	 2 nam1 char(8),
	 2 typ1 char(3);
 dcl
	1 fil based (p),
	  2 drv char(1),
	  2 nam char(8),
	  2 type char (3); 

put skip list ('Modify Intel Object Files 17 Nov 82');
put skip;

on endfile (source) begin; end;

unspec (p) = '005C'b4;
drv1 = drv;
if type = '   ' then type = 'OBJ';
open file (source) input record title ('$1.$1') env(b(1024));

unspec (p) = '006C'b4;
drv = drv1;				/* same drive as $1 */
nam = 'TEMP    ';
type = '$$$';
open file (outfile) output record title ('$2.$2') env(b(1024));

bufptr = hbound (buff, 1);
del=0;
obufptr = 1;
modnum=0;	

do i = 1 to 31;
  typ(i) = put_ignore;
 end;
typ(0) = undefined_record_type;
typ(15) = put_module_end;
typ(21) = put_name_list;
typ(28) = put_library_header;

FileDel = 0;

library = false;

call pass_file;

open file(source) input record title('$2.$2') env(b(1024));
open file(outfile) output record title('$1.$1') env(b(1024));

bufptr = hbound (buff, 1);
obufptr = 1;
modnum=0;	

FileDel = 0;

do i = 1 to 31;
  typ(i) = put_ignore;
 end;

call pass_file;

pass_file: procedure;
  call reset_indexes;
  eof = false;

  do while (~eof);

    checksum = 0;
    ocheck = 0;

    record_length = 3;				/* type and length */

    b = get_bit8();
    i = get_index();

    record_length = get_word();

    call typ(i);

    b8 = get_bit8();
    ocheck = -ocheck;
    bb = unspec(ocheck);
    b8 = substr(bb,9,8);
    call put_bit8(b8);

    if ((b = '8a'b4) & (library = false)) | ((b = 'aa'b4) & (library = true))
      then do;
	do bufptr = 1 to obufptr-1;
	  write file(outfile) from (obuff(bufptr));
	 end;
	close file(outfile);
	close file(source);
	eof = true;
       end;
   end;
 end pass_file;

undefined_record_type: procedure;
  put skip list('undefined record type', b);
 end undefined_record_type;

put_module_end: procedure;
  call put_ignore;
  call reset_indexes;
 end put_module_end;

put_library_header: procedure;
  library = true;
  call put_ignore;
 end put_library_header;

put_ignore: procedure;
  call put_bit8(b);
  call put_word(record_length);
  call put_record;
 end put_ignore;

reset_indexes: procedure;
	modnum=modnum+1;
	delta_length(modnum)=0;
	external_index = 1;
	segdef_number = 1;
	grpdef_number = 1;
	typdef_number = 1;
	blkdef_number = 1;
	lnames_number = 1;
	end reset_indexes;

get_index: procedure returns (fixed (7));
	declare i fixed (7);
	do i = 1 to hbound (record_type, 1);
		if b = record_type (i) then return (i);
	end;
	return (0);
	end get_index;

get_bit8: procedure returns (bit (8));
	bufptr = bufptr + 1;
	if bufptr > hbound (buff, 1) then
		do;
			read file (source) into (buff);
			bufptr = 1;
		end;
	record_length = record_length - 1;
	if record_length = -1 then
		put skip list ('*** record length error ***');
	checksum = checksum + binary (buff (bufptr));
	return (buff (bufptr));
	end get_bit8;

put_bit8: procedure (bx);
	dcl bx bit(8);
	obuff(obufptr)=bx;
	obufptr = obufptr + 1;
	ocheck=ocheck+binary(bx);
	if obufptr > hbound (obuff, 1) then
		do;
			write file(outfile) from (obuff);
			obufptr = 1;
		end;
	end put_bit8;

put_word: procedure(px) ;
	dcl px fixed bin;
	dcl b2 bit(16);
	b2=unspec(px);
	call put_bit8(substr(b2,9,8));
	call put_bit8(substr(b2,1,8));
	end put_word;

put_char: procedure(cx);
	dcl cx char;
	call put_bit8(unspec(cx));
	end put_char;

get_bit16: procedure returns (bit (16));
	declare x bit (8);
	x = get_bit8 ();
	return (get_bit8 () || x);
	end get_bit16;

get_byte: procedure returns (fixed (7));
	return (binary (get_bit8 ()));
	end get_byte;

get_word: procedure returns (fixed (15));
	declare x bit (16);
	x = get_bit16 ();
	return (binary (x));
	end get_word;

getbw: procedure returns (fixed (15));
	declare t bit (8);
	t = get_bit8 ();
	if (t & '80'b4) = 0 then return (binary (t));
	return (binary ((t & '7f'b4) || get_bit8 ()));
	end getbw;

get_f8: procedure returns (fixed (8));
	return (binary (get_bit8 ()));
	end get_f8;

get_char: procedure returns (char);
	return (ascii (get_byte ()));
	end get_char;

put_name: procedure;
	declare c fixed (7);
	dcl g1 char(31) varying;
  	c = get_byte ();
	name_length = c;
 	g1=''; 
	if c = 0 then g1='';
	else do i = 1 to c;
		g1=g1 !! get_char();
		end;
/*	put edit (g1) (a);						*/
	if g1 = 'UGROUP' then g1 = 'CGROUP';
	g(lnames_number)=g1;
 end put_name;

put_name_list: procedure;
	dcl recl fixed;
	recl=record_length;
	do while (record_length > 1);
/*		put edit (deblank (lnames_number), ' ') (col(10), a, a);*/
		call put_name;
		lnames_number = lnames_number + 1;
	end;
	call put_bit8(b); /* write the op */
	call put_word(recl);
	do i=1 to lnames_number-1;
		k=length(g(i));
		bb=unspec(k);
		call put_bit8(substr(bb,9,8));
		if k ^=0 then do j=1 to k;
			call put_char(substr(g(i),j,1));
			end;	
		end;
	end put_name_list;

put_seg_def: procedure;
	declare
		a bit (3),
		c bit (3),
		b1 bit (1),
		p bit (1),
		foo bit (8),
		foo16 bit (16);
	dcl (cnam,snam,onam,l1,l2) fixed (15),
	    (c1,c2,gc) char(31) varying;
/*	put edit (deblank (segdef_number), ' ') (a, a);			*/
	call put_bit8(b); /* op */
	call put_word(record_length); /* this won't change */
	b8 = get_bit8 ();
	call put_bit8(b8); /* acbp */
	a = substr (b8, 1, 3);
	c = substr (b8, 4, 3);
	b1 = substr (b8, 7, 1);
	p = substr (b8, 8, 1);
/*	put edit ('a = ', a, ' c = ', c, ' b = ', b1, ' p = ', p)
	  (a, b3, a, b3, a, b1, a, b1);					*/
	if a = '0'b | a = '101'b then
/*		put edit ('frame number = ', get_bit16 (),
		  ' offset = ', get_bit8 ())
		  (skip, col(10), a, b4, a, b4);			*/
	    do;
		foo16 = get_bit16();
		foo = get_bit8();
	      end;
	if a = '110'b then
/*		put edit ('ltl dat = ', get_bit8 (),
		  ' max seg len = ', get_bit16 (),
		  ' group offset = ', get_bit16 ())
		  (skip, col(10), a, b4, a, b4, a, b4);			*/
	    do;
		foo = get_bit8();
		foo16 = get_bit16();
		foo16 = get_bit16();
	      end;
	call put_bit8(get_bit8()); /* segment length, no change */
	call put_bit8(get_bit8());
	if a ^= '101'b then
		snam=getbw();
		cnam=getbw();
		gc=g(cnam);  
		if (gc ^= 'CODE' & gc^='DATA' & gc^='STACK') then do;
			l1=length(g(snam));
			if l1>3 then c1=substr(g(snam),l1-3,4);
			else c1='';
			l2=length(g(cnam));
			if l2>3 then c2=substr(g(cnam),l1-3,4);
			else c2='';
/*			put skip list('switch to class ',c1);		*/
			if c1='CODE' | c2='CODE' then do;
				cnam=gcode;	
				end;
			else if c1='DATA' | c2='DATA' then do;
				cnam=gdata;
				end;
			else if g(snam) ^= '?SEG' then do;
				cnam=gextra;
				end;	
			end;
		onam=getbw();
		bb=unspec(snam); call put_bit8(substr(bb,9,8));
		bb=unspec(cnam); call put_bit8(substr(bb,9,8));
		bb=unspec(onam); call put_bit8(substr(bb,9,8));
/*		put edit ('segment name index = ', deblank (snam),
		  ' class name index = ', deblank (cnam),
		  ' overlay name index = ', deblank (onam))
		  (skip, col(10), 3(a, a));				*/
	segdef_number = segdef_number + 1;
	end put_seg_def;

put_group_def: procedure;
	declare foo15 fixed (15), foo8 bit (8), foo16 bit (16);
/*	put edit (deblank (grpdef_number), ' ') (a, a);
	put edit ('group name index = ', deblank (getbw ())) (a, a);	*/
	foo15 = getbw();
	do while (record_length > 1);
	group_type = get_bit8 ();
	if group_type = 'ff'b4 then
		do;
/*			put edit ('segment index = ', deblank (getbw ()))
			  (col(10), a, a);				*/
			foo15 = getbw();
		end;
	else if group_type = 'fe'b4 then
		do;
/*			put edit ('external index = ', deblank (getbw ()))
			  (col(10), a, a);				*/
			foo15 = getbw();
		end;
	else if group_type = 'fd'b4 then
		do;
/*			put edit ('segment name index = ', deblank (getbw ()),
			  'class name index = ', deblank (getbw ()),
			  'overlay name index = ', deblank (getbw ()))
			  (col(10), a, a, a, a, a, a);			*/
			foo15 = getbw();
			foo15 = getbw();
			foo15 = getbw();
		end;
	else if group_type = 'fb'b4 then
		do;
/*			put edit ('ltl dat = ', get_bit8 (),
			  'max group length = ', get_bit16 (),
			  'group length = ', get_bit16 ())
			  (col(10), a, b4, a, b4, a, b4);		*/
			foo8 = get_bit8();
			foo16 = get_bit16();
			foo16 = get_bit16();
		end;
	else if group_type = 'fa'b4 then
		do;
/*			put edit ('frame number = ', get_bit16 (),
			  ' offset = ', get_bit8 ())
			  (col(10), a, b4, a, b4);			*/
			foo16 = get_bit16();
			foo8 = get_bit8();

		end;
	else put skip list ('*** error ***');
	end;
	grpdef_number = grpdef_number + 1;
	end put_group_def;


put_libloc: procedure;
	dcl (bl,blnum,btnum,blnew,btnew) fixed (15);
	lnames_number = 1;
	del=0;
	call put_bit8(b); /* op */
	call put_word(record_length);
	do while (record_length > 1);
/*		put edit (deblank (lnames_number), ' ')
			(col (10), a, a);				*/
		blnum=get_word();		
		btnum=get_word();
		btnew=btnum+del; 
		bl=btnew/128 ;
		btnew=mod(btnew,128);
		blnew=blnum+bl;
		del=del+delta_length(lnames_number);
		call put_word(blnew);
		call put_word(btnew);
/*		put edit ('old block number = ',deblank(blnum),
			' byte number = ',deblank(btnum)) (a);		*/
		lnames_number = lnames_number + 1;
	end;
	end put_libloc;

put_record: procedure;
	do while (record_length > 1);
		call put_bit8(get_bit8 ());
	end;
	end put_record;

deblank: procedure (x) returns (char (20) varying);
	declare x fixed (15);
	declare c char (20) varying;
	declare i fixed (7);
	c = char (x);
	i = verify (c, ' ');
	return (substr (c, i));
	end deblank;

end fintel;
E 1
