


/* EPC Imp to C Translation Release 4 Version Apr 95 */


#include "imptoc.h"


/*               ***********************************                         */
/*               *                                 *                         */
/*               *       ELF  PUT INTERFACE        *                         */
/*               *                                 *                         */
/*               *     Produces  to  UNIX5ABI      *                         */
/*               *  Object Compatibility Standard  *                         */
/*               *      Release 1.0   Jan 90       *                         */
/*               *                                 *                         */
/*               ***********************************                         */
/*                                                                           */
/*                                                                  elfput17.6*/
/*         Added changes for DGUXrevendian hiiden behind #ifdef DGUXRE        */
/*         which may be set by -D at compile time or in the elf.p6.h include  */
/*                                                                  elfput17.4*/
/*          Checks added that dictstart initialised and also some F90 changes  */
/*          from AndyK have been merged in                                     */
/*         Added psetfiles2 which returns the file descriptor                  */
/*         Used eprocs external Pic and dropped our own static int             */
/*                                                                  elfput17.3*/
/*  31May96 Extra test in PPproc for case when dict has not been initialised */
/*         Added routine Psettargetflags                                     */
/*                                                                  elfput17.2*/
/* 21Jan96  Saved Lastca when pushing and popping files to avoid unwanted    */
/*          overwriting of line nos                                          */
/*          Used unaligned fix for line number tables. Sparc linker          */
/*          objects in the table is not aligned and word fix used(pds)       */
/*                                                                  elfput17.1*/
/* 17Jan96  Reset lastline to -1 in Ppushfile. (AHi)                         */
/* 17Jan96  Remove code to word align individual line number tables in       */
/*          Ppushfile.  This did not seem to be required and was upsetting   */
/*          dump utilities. (AHi)                                            */
/*                                                                  elfput17 */
/* 25Oct95  Added code to deal with tags section for PPC by amending 88k     */
/*          Tdesc section. Relaxed restrictions on fixing initialised        */
/*          common area. Added Pcdataarea in place on unused PCcommon        */
/*                                                                  elfput16.2*/
/* 11Aug95   Added the swopping routines and call of Eswapmode so put        */
/*           will work correctly when compiling in cross Endian mode         */
/*                                                                  elfput16.1*/
/* 27Jly95   Correction to the new line no tables                            */
/*                                                                  elfput16 */
/* 21Jly95   Substantial changes to line no tables. Newrts Ppushfile         */
/*           & ppopfile added. Also Pgivecurrentsize. These are to           */
/*           support debugging of source in included textfiles(pds)          */
/*                                                                  elfput15 */
/* 26Jun95    Added Tdesc sections for M88k which need relocation(pds)       */
/*                                                                  elfput14.9*/
/* 22Jun95    C++/Pascal/Imp merger. (mcb)                                   */
/* 24Apr95    Close object file at end Pgenerateobject                       */
/*                                                              elfput14.8   */
/* 17Apr95    Template repository                               (CDM)        */
/*            PReinitialise                                                  */
/*            Area tables zeroed when freed                                  */
/*            Remaining area tables freed and zeroed at Pgenerate exit       */
/*            Rels malloced space remembered and freed at Pgenerate exit     */
/*            Fix to 'expand area' for zeroth area.                          */
/*            Psetfiles creates necessary path components                    */
/*                                                                  elfput14.7*/
/* 21Mar95    Added 5 additional symbols for m88k which does not deal        */
/*            with offsets correctly in PIC mode                             */
/*                                                                  elfput14.6*/
/* 24Feb95   Added very hairy optimisation of local calls on MIPS.           */
/*           see commentary when processing relocations circa line 3890      */
/*                                                                  elfput14.5*/
/* 13Feb95   Additions to allow an optional underscore to be appended        */
/*           to Fortran common names. The char appended is in the elf        */
/*           include file to permit local variations                         */
/*                                                                  elfput14.4*/
/* 14Jan95    Changes to facilitate translation to C                         */
/*                                                                  elfput14.3*/
/* 30//1//94  Change to Mips Got16-Low16 pairs to a local function so        */
/*            that pyramids loader will work on then. Need to change         */
/*            so that it is relative to the EPC text symbol                  */
/*                                                                  elfput14.2*/
/* 07/09/94   Change to use debugtabfix in linenotable on 88K (legend insists!)*/
/*                                                                  elfput14.1*/
/* 06/06/94   50 years after Dday                                            */
/*            Removed ancient error from look up in pxname                   */
/*            Restricted externalintegerspec Debugptr to DwarfProducer=Backend*/
/*            Reset lastline lin plinestart for F90 internal routines which  */
/*            come after the end of the enclosing routine                    */
/*                                                                  elfput14.i*/
/*            Changed MIPgot16 to shift down the addend. needed for          */
/*            local data. External data the addend SHOULD always be 0        */
/*            Added no reorder bits for MIPS                                 */
/*            Added code to deal with the case of allocated are being defined*/
/*            in Eterminate bigger than the buffer space allocated           */
/* 10/01/94    Changes to improve IMP dwarf information                      */
/*                                                                  elfput13.5*/
/* 29/12/93    Change to deal with zero code area size which                 */
/*             can happen in block data subprogs(pds)                        */
/*                                                                  elfput13.4*/
/* 28/10/93   Changes for PIC on Mips. Also use debugtabfix                  */
/*             For foxes to debug area                                       */
/*                                                                  elfput13.3*/
/* 06/07/93    Changes to pfiller to allow balance of area to be             */
/*             be filled if data already given                               */
/*                                                                  elfput13.2*/
/* 28/06/92    Incorporated changes from the BSD Put for Fortran90:          */
/*                                                                           */
/*          :- In Pdbytes, return if the data size is zero (else             */
/*             later if GST is otherwise empty, Pterminate will              */
/*             complain that the area has incorrect length).                 */
/*                                                                           */
/*          :- In Pfiller, perform a no-op if the area is Bss and            */
/*             correct if the area is a Common.  Also call Pd for            */
/*             any Common area which is currently uninitialised,             */
/*             otherwise Common areas which have no initialisations          */
/*             will not be filled with the defined pattern.                  */
/*                                                                           */
/*          :- In Pentry2, redefine the first argument to be the             */
/*             ENTRY's properties rather than its Index (Index is            */
/*             never used and Fortran90 ENTRYs may be private).              */
/*             - compatible with sprocs21.7 onwards                          */
/*                                                                           */
/* 26/06/93 :- Removed DwarfProducer decln back into dwarf.inc               */
/*                                                                  elfput13 */
/* 26/04/93 :- Substantial amendment to incorporate INIT & FINI              */
/*             area and their relocations for C++. Also a general            */
/*             revision of space managemnt which has become untidy(pds)      */
/*                                                                elfput12.2 */
/* 23/04/93 :- Addition to Dwarf for procedure heading to assist EDB         */
/*             in finding the end of the prologue(pds for AH)                */
/*                                                                elfput12.i */
/* 16/04/93 :- Minor corrections to output correct dwarf                     */
/*             when running on byte swopped hosts(pds)                       */
/*                                                                elfput12.i */
/* 09/03/93 :- Merge 88k and Sparc (sl) with Mips (pds)                      */	/*gm*/
/*                                                                elfput11.3.i*/
/*  4/02/93 :- Sparc support for PIC                                         */
/*                                                                elfput11.2.i*/
/* 26/01/93 :- Add ATprogram for MAIN SUB DIE                                */
/* 22/01/93 :- Add vtype masks to psdbvar to make more readable              */
/*           - Modify vtype meanings for records                             */
/*                                                                elfput11.1.i*/
/* 21/01/93 :- Fix problem where volatile characters were being              */
/*             treated as arrays instead of tagstringtype                    */
/*           - Handle pointer based vars by negating their vtype             */
/*             so we get half meaningful dwarf. This needs to                */
/*             be handled better so the user can see its a ptr,              */
/*             ie by using mod_ptr_to                                        */
/*           - PSDBVAR allow record parameters                               */
/* 18/01/93 :- Generate Stack Loc add sparc code for location                */
/*             of Fortran automatic variables                                */
/*           - Check blank common dwarf name is "" for blank                 */
/*             common on non-88k too                                         */
/*           - Pproc and Tagentry strip traling underscore for               */
/*             routine names                                                 */
/*           - Generate Stack Loc use PARAMBASE, which is constant           */
/*             on SPARC code gens, to get offset from %FP of                 */
/*             each parameter for dwarf gen                                  */
/*           - Remove add loc code to pick 1st six sparc args up             */
/*             from %I0-%I5                                                  */
/*                                                                           */
/*                                                  (simon)       elfput11.i */
/* 12/01/93 :- Merge in Fortran -CS option changes for Case                  */
/*             Sensitivity                                                   */
/*          :- Allow displacement in pdpattern and pdbyte to be              */
/*             x'7fffff' instead of 4M bytes (b187)                          */
/* 24Sep92     Dwarf support for IMp added (brought from beetle)(pds) elfput11.i*/
/* 16Jan92     Minor changes to PIC code following definition of      elfput10.9*/
/*              of the relevant bits in Psetoptions. One change to           */
/*              Sparc relocations in PIC mode                                */
/*                                                                elfput10.8f.6.i*/
/* 12/01/93 :- In Pterminate change 'DwarfProducer=fortran' test             */
/*             to 'DwarfProducer=PUT'                                        */
/* 08/01/93 :- Comment out initdataad as it already exists in                */
/*             eprocs                                                        */
/*                                                                elfput10.8f.5.i*/
/* 17/12/92 :- In PDataEntry, only avoid PSymbol if the PUT is the dwarf     */
/*             producer.                                   (si)              */
/*                                                                elfput10.8f.4.i*/
/* 15/12/92 :- When creating the .debug, .rela.debug, .line and .rela.line   */
/*             section headers, use SHT_null for empty sections, do not place */
/*             the names in the symbol tables if empty.  Also do not attempt to*/
/*             align the .debug section at all.                              */
/*             Also replace the "SourceLang = Fortran" idea with the         */
/*             'DwarfProducer' constant.                   (si)              */
/*                                                                elfput10.8f.3.i*/
/* 11/12/92 :- Placed all Dwarf production under "SourceLang = Fortran"      */
/*             flag.  It is now assumed that all other languages generate    */
/*             Dwarf independently of the PUT module.  The line number table */
/*             is still generated by the PUT module.  The integer DebugPtr needs*/
/*             to be changed to an extern in the fortran compiler      (si)  */
/*                                                                elfput10.8f.2.i*/
/* 11/12/92 :- commented out line in pfix2 for dwarf to work                 */
/*                                                                elfput10.8f.1.i*/
/* 13/11/92 :- Altereations to get SI put to compile with our compiler -     */
/*             set nusoption to be owninteger, value 1.                      */
/*                                                                   elfput10.8f*/
/* 02Mar92     Further Enhancements for mxdb and ENTRY stmts                 */
/*             Fix assummed size array last high bound                       */
/*                                                                   elfput10.8e*/
/* 18Feb92     Support for Volatile type description FTvolatile              */
/* 17Feb92     Changes to generate dwarf for Entry Statements                */
/*                                                                   elfput10.8d*/
/* 06Feb92     Changes for Fortran Dwarf made at DG RTP                      */
/*             byte->Ftsingedchar,log1->Ftunsignedchar                       */
/*             log2->Ftunsignedshort                                         */
/*             Fix char arg bug where chars were output                      */
/*             as Tag_local_variables                                        */
/*             Blank common name given as "" fo mxdb                         */
/*             New Entry Point Info routine to set up dwarf                  */
/*             function return info in PPROC                                 */
/*             Add mxdb case info to TAGcompileunit via ATlouser             */
/*             Make MAIN_ -> main for mxdb TAGglobalsubname                  */
/*             New Fortran Tagstring routine to generate                     */
/*             TAGstringtype for all fortran character vars                  */
/*             in normal case,function returns and record fields             */
/*                                                                           */
/* 15Jan92     Changes for Dwarf generation a la Data General        elfput10.8c*/
/*             New elf.inc which specifies frame reg as stack                */
/*             pointer, as 88k uses sp. Framsize is offset                   */
/*             for params and autos given by eprocend.                       */
/*             This version of put is no longer compatible                   */
/*             with sdb as it adheres to the dwarf standard!                 */
/*                                                                           */
/* 18Dec91     Set type on 4 debug sections as 'nobits, if unused    elfput10.8b*/
/*             rather than 'null' and fill in rest of entry.                 */
/* 12Dec91     Change fixup type in word 2 of .line section to       elfput10.8a*/
/*             Debugtabfix since dtl translator objects.                     */
/*             Don't set SHF_ALLOC on .rela.line                              */
/*             Don't set "section" in section's symbol entry                 */
/*             Don't set _addr field in .data and .bss sects                 */
/*             Make pentry2 create local symbol if offset < 0                */
/* 12Dec91     More care with area alignments                        elfput10.8*/
/* 03Oct91     Modifications to SDB code  and alias names            elfput10.7*/
/*             Also removal of comreg refs since this method of setting      */
/*             options has gone with EMAS.                                   */
/* 01Oct91     Merge in of Lindas extensions to SDB code                     */
/* 25Sep91     Correction to expand area to zero all the extra space         */
/*             previously last 8 bytes were not cleared                      */
/* 11Dec90      added procedure Pgetbytes which, if possible,        elfput10.1*/
/*              returns the address at which the initialisation              */
/*              of a specified data location has been stored                 */
/*              - required by eprocs24.9 onwards                             */
/* 08Oct90   Elfput10 with first shot at extended SDB interface as per SDBblurb*/
/* 18Sep90    Elfput9.4 Fixes problem in files with no globals also in Checkcodesize*/
/* 30Aug90     Elfput9.3 More fixes in PFIX2 to allow code scheduler         */
/*             to separate hi-lo fixups                                      */
/* 21Aug90     Elfput9.1&.2 Changes to SDB code to make it swop proof        */
/* 07Aug90     Elfput9 Changes from Linda for byteswopping on 486            */
/* 01Aug90     Elfput8.2  Changes to Pinit to initialise symtab to avoid     */
/*             problems with C programs with no symbols                      */
/* 20June90    Elfput8    Changes for 386 version which include              */
/*             some rearrangement of include files                           */
/* 13Jun90    Elfput7.4. Changes to sort out confusions                      */
/*            between strings and arrays of characters in SDB                */
/*            Also to remove empty debugsection from objects compiled        */
/*            without debugging since this appears to confuse utilities      */
/* 28Mar90      elfput7 Major extensions to incorporate .debug section       */
/*              being the SDB information as per a doc from ICL              */
/* 14Mar90      elfput6.6&6.7  Fixes to common ares                          */
/* 28Feb90      elfput6.5    Adds Pentry2 enhanced vsn of Pentry             */
/* 15Feb90      elfput6      pds adds other adhoc changes to try to          */
/*                          avoid load problems on unicorn. Local proc are patched in*/
/*                          instead of done by relocation                    */
/* 13Feb90     elfput5        pds adds code to put all locals before globals */
/*                           in the symbol table                             */
/* 29jan90     elfput3        pds incorporating GB changes (elfput2)         */
/*             Cmpcstring corrected                                          */
/*             external symbol prefix (often sub"_") now in include file     */
/*             Pproc enters the name if necessary                            */
/*               Original version based on m88kput8.i                        */
/*                                                                           */
/* all the COFF sdb code is untouched except that call of psymbol are        */
/* commented out. However the ELF symbol table is smaller than the COFF      */
/* one and any use of the SDB code will tramp over the symbol table          */
/* Data to work out what to do is not available as yet.                      */
/*                                                                           */

/* Tracing control */

/* Trace all significant calls on interface if: */
/* comreg(26)&1#0  */

/* Seldom required info controlled by bits of comreg(26) as follows: */

/* 4  -  switch on sdb */
/* 16 -  File use monitoring */
/* 32 -  Dump output in HEX on writing */
/* 128 - Requests for more space by Malloc, Expand Area etc. */


#define trusted 0	/* 0 =  check inputs */
/**                                                                          */
static int sdb=0;
/**                                                                          */
#define imp 1
#define fortran 2
#define ccomp 11
#define pascal 14
/**                                                                          */
static int procstartline=-1;	/*=> undefined*/
static int lastline=-1;
static int lastca=-1;
static char objectname [255+1];	/*For PASCAL to delete object file if required*/

/**                                                                          */

/**                                                                          */
/* %EXTERNALINTEGERFNSPEC GetSDBfntype                                       */	/* C specific */

/*  System or C library routines used */

/*%EXTERNAL %INTEGER %FN %SPEC TIME(%INTEGER zero)                           */
extern int creat( int ,int );
extern void unlink( int );
extern int close( int );
#define filewrite write
extern int filewrite( int ,int ,int );
extern int lseek( int ,int ,int );
/*byte ad*/
extern int access( int ,int );
extern int mkdir( int ,int );

/* IMP library routines used */

static int unasscheck=1;
/*%EXTERNAL %INTEGER %MAP %SPEC Comreg(%INTEGER n)                           */
extern char * itos( int );	/**~np1 %alias "s_itos"*/
#define fill s_fill
extern void fill( int ,int ,int );	/**~np1*/
extern void bytemove( int ,int ,int );
extern char * htos( int ,int );
extern int eswapmode( void );
/**                                                                          */
void psymbol( char * ,int ,int ,int ,int ,int );
static void fix( int ,int ,int ,int ,int );
/********************************************************************************/

#define defaultareasize (4096-8)	/*8 added by malloc for red tape            */
#define initialsymboltablesize defaultareasize
#define onemegabyte (1048576)
#define twomegabyte (2097152)
#define infinity (0xFFFFFE)
#define mode 436	/* mode of object creat, read/write for all */
#define dirmode 508	/* dircetory mode R+W+X self and group */

/*fortran triad mode to size conversions*/
static const unsigned char modetobytes [17+1] = {
	2,
	4,8,4,8,16,8,16,
	32,1,2,4,8,1,0,1,
	0,1};

static int dictindex=0;	/* offset into dictionary of latest item */
static int objid;	/* File descriptor ID of object file */
static int impp=0;
static int faulty=1;
static char srcfile [255]="source unknown";
static char objname [33]="object Unknown";
static int curlexlev=0;
static int endpending=0;
static int debuglevel=0;
static int mon=0;	/* Put call monitoring control */
static int mainentrypoint=0;
static int line=0;	/* Current Line number as set by Plinestart*/
static int sourcelang;
static int sourcelangvariant;
static int targetvariant;
static int casesense=0;

#include "elf.h"	/*<--- PIC VARIABLES --->*/
#include "elf6.p5.h"
#include "vers.h"
#include "dwarf4.h"

/*<--- PIC VARIABLES --->*/

#define unshared 0
#define smallmodel 1
#define largemodel 2

/*    Unshared - the default, absolute addresses generated in code           */
/* Small Model - allows a restricted number of external refs from code       */
/* Large Model - allows for unlimited different references from code         */

extern int Pic;
#ifdef DGUXRE
extern char *ecsnameprefix;		/* to allow funny prefixes in RE mode */
#endif

static int gotsym=0;	/* The symbol table for our GOT entry                   */



#if(DwarfProducer==PUT) 
static int debugptr=0;	/* Current address of debug area                      */
/* %if DwarfProducer = Backend */

#else
extern int debugptr;

#endif;


#if(target==elfsparc) 
#define parambase (0x44)	/* offset from %FP where sparc codegen dumps args   */

#endif;

/*<-- SYMBOL VARIABLES -->*/


#define symsize 255	/* max name length in string table */
#define symboltableentrysize 16


struct auxblockfm{
	int spare1;
	int lnno;
	int spare2;
	int spare3;
	int endindex;
};


struct auxtagfm{
	int spare1;
	int spare2;
	int size;
	int spare3;
	int endindex;
};



static Elf32_Sym *syms;
static int maxsyms;



/*<--- Section index field --->*/

#define reginfosect 1
#define textsect 2
#define datasect 3
#define datagptabsect 4
#define bsssect 5
#define bssgptabsect 6
#define symsect 7
#define textrelsect 8
#define datarelsect 9
#define mdebugsect 10
#define stringsect 11
#define shstringsect 12
#define rodatasect 13
#define linenosect 14
#define linerelsect 15
#define debugsect 16
#define debugrelsect 17
#define initsect 18
#define initrelsect 19
#define finisect 20
#define finirelsect 21
#define tdescsect 22
#define tdescrelsect 23
#define maxsect 23	/* Must be next in sequence to datasect */	/* Must be next in sequence to bsssect */

#if(target==elfmips) 
#define regsectsize 24

#else
#define regsectsize 0

#endif;
/*                                                                           */
/* tdesc section doubles as tags section for PPC                             */
/* define any consts here that are needed to enable common code              */
/* to be used                                                                */
/*                                                                           */

#if(target==elfppc) 
#define tdescname (".tags")
#define tdesctype (shtordered)
#define tdescprops (((4<<24)|(8<<16))|SHF_ALLOC)

#else
#define tdescname (".tdesc")
#define tdesctype SHT_PROGBITS
#define tdescprops ((4<<24)|SHF_ALLOC)

#endif;
static int nsects=1;
static char * sectnametext [maxsect+1] = {
	"",".reginfo",
	".text",".data",
	".gptab.data",".bss",".gptab.bss",".symtab",
	".rela.text",".rela.data",".mdebug",".strtab",
	".shstrtab",".rodata",".line",".rela.line",
	".debug",".rela.debug",".init",".rela.init",
	".fini",".rela.fini",".tdesc",".rela.tdesc"
};

static int maxloc;	/* The last local in the shuffled symbol table*/
static int regsectdata [5+1] = {
	0,0,0,0,0,0};
static int sectionposition [maxsect+1];	/* Hold file offsets*/

static int sectionsizes [maxsect+1];
static int sectionentryno [maxsect+1];	/* Position in table */



/*                                                                           */
/* Declarations and formats for SDB                                          */
/*                                                                           */
/*<--- TYPE FIELD --->*/

#define tnull 0				/* Type not assigned */
#define tchar 1				/* character */
#define tschar 2			/* byte in fortran*/
#define tuchar 3			/* unsigned character */
#define tshort 4			/* short integer */
#define tushort 6			/* unsigned short */
#define tint 7				/* integer */
#define tsint 8				/*signed integer*/
#define tuint 9				/* unsigned integer */
#define tlong 10			/* long integer */
#define tfloat 14			/* floating point */
#define tdouble 15			/* double word */
#define tulong 12			/* unsigned long */
#define tcomplex 17			/*complex ie 2 floats*/
#define tdcomplex 18			/*Dcomplex ie 2 doubles*/
#define tbool (0x15)			/*any boolean*/



			/* - Auxiliary entry formats - */

struct debugf{
	int len;
	short int tag;
	unsigned char data [255+1];
};

struct locf{
	int dis;
	int offset;
	int area;
	int dref;
	int offset2;
};

#define epcf77structtypes 25	/*starting number for dbx ATuserdeftypes*/


#define lrecsize 10	/* bytes for each line number record */


/*<-- RELOCATION VARIABLES -->*/


/* This format for internal storage of reloc details */

struct rfm{
	short int hostarea;
	short int tgtarea;
	int hostdisp;
	int tgtdisp;
};


#define maxrels (defaultareasize/sizeof(struct rfm))
static int relsmalloc;
static struct rfm *rels;
static struct rfm *startrels;
static int crel=0;	/* current relocation pointer */




/*<-- CODE AREA VARIABLES -->*/

static int *codearea;
#define maxlexlev 20	/* Maximum Lexical Level - assured */
/* IMP cannot go deeper than this. */
struct blockfm{
	int ad;
	int ca;
	int sym;
	int highpcoffset;
	int postploffset;
	int siblink [10+1];
};

static struct blockfm blocks [maxlexlev+2];
static struct blockfm *parentblock;	/*descriptor of surrounding procedure*/
static struct	/*descriptor of current procedure */ blockfm *curblock;

/*<--- OBJECT AREAS --->*/

#define code 1
#define gla 2
#define plt 3
#define sst 4
#define gst 5
#define diags 6
#define scalar 7
#define iotab 8
#define zgst 9
#define cnst 10
#define init 11
#define fini 12
#define auxbss 13
#define tdesc 14
#define debugtab 16
#define linetab 17
#define dicttab 18
#define symtab 19

/* Negative area hold relocations after processing    */

#define coderels (-1)
#define datarels (-2)
#define initrels (-3)
#define finirels (-4)
#define debugrels (-5)
#define linenorels (-6)
#define tdescrels (-7)
#define lineworkarea (-8)
#define lowestarea (-8)


/* The following array translates epc areas to elf areas as defined by the   */
/* symbol table. Code is symtable entry 2, data=3, bss=4, debug=5, line=6, rodata=7, GOTsym=8*/
/* these could be parameterised!   */


#if(target==elf88k) 
static const unsigned char epcareatoelfsym [symtab+1] = {
	0,
	2,3,13,9,10,3	/*7*/,11,
	12,4,8,0,0,0,0,0,
	5,6,0};

#else
static const unsigned char epcareatoelfsym [symtab+1] = {
	0,
	2,3,13,3	/*7*/,3,3	/*7*/,3,
	3,4,3	/*7*/,0,0,0,0,0,
	5,6,0};

#endif;
/* remove RO area to data cos of suspecet OS bug; Changes in lien above too  */
static const unsigned char epcareatosectndx [symtab+1] = {
	0,
	textsect,datasect,datasect,	/*RO*/datasect,datasect,	/*RO*/datasect,datasect,datasect,
	bsssect,	/*RO*/
	datasect,0,0,0,tdescsect,0,debugsect,linenosect,
	0};


/* the next two arrays are to help with relocations. The first is the correspondence*/
/* between the EPC area holdint the data & the EPCarea holding the relocation.*/
/* A zero means relocations to this area are barred  */
/* Nrels count the relocations encountered for each  */

static const int epcareatorelarea [symtab+1] = {
	0,
	coderels,datarels,datarels,0,datarels,0,datarels,datarels,0,
	0,initrels,finirels,0,0,0,debugrels,linenorels,
	0};
static int nrels [symtab+1] = {
	0};




#define setareas 20
static int maxarea=0;	/* Number of areas there is  */
/* space for in the current slot */
static int toparea=21;	/* Highest area number used */

struct areafm{
	int base;
	int max;
	int length;
	int sym;
	int type;
	int linkdisp;
	int align;
	int highuse;
};


static struct areafm *areas;

struct linehdrform{
	int backlink;
	int offset;
	int last;
	int prevlastca;
	int length;
	int codeaddr;
};

static int linehdroffset=-1;
#define linehdrsize 24


static int filemon=0;
static int swapmode;

static int dictad=0;	/* symbol table dictionary pointer */
static int maxdictad=0;	/* current ad of dictionary end */
static int dictstart;
static int malmon=0;
static int maxdata=0;
static int level [255];
static int lev=0;
#define stfixedentries 13
static int nextsym=stfixedentries-1;	/* Index to symbol table. +1 for each entry */
static unsigned char shnames [255+1];
static int shptr=1;
static int lastdiagsrec=-1;
struct diagsrecfm{
	int doffset;
	int endline;
};

#define maxdiagsrec 64
static struct diagsrecfm diagsrecs [maxdiagsrec+1];


static void addtype( struct debugf *,int *,int ,int ,int );
static int privatehdrflags;
static void addname( struct debugf *,int *,char * );
static void addloc( struct debugf *,int *,int ,int ,int ,int );
static void addstringlen( struct debugf *,int *,int ,int );
static void writedbr( struct debugf *);
static void fillsiblink( int ,int );
static void addsiblink( struct debugf *,int *,int ,int );
void psdbvar( int ,int ,int ,int ,int ,int ,int ,int ,int );
static void impsdb( int );
static int impinnerblk( int );
static void doimpsdbblock( int );
static void completeend( void );
static void expandarea( int );
static void insertfilename( int );
static char * checkblankcommon( char * );
void pd4( int ,int ,int );
void pd2( int ,int ,int );
void pdbytes( int ,int ,int ,int );



/* two dummies for testing on np only    */

/*%externalinteger initdataad*/


#if(target==elf88k) 
static int nusoption=1;	/*returns 1 if -nus used, 0 if -us*/
static int framesize;	/* as 88k uses sp instead of fp need size from eprocend*/
#endif;
#if(target==elfmips) 
static int framesize; /* as mips uses sp instead of fp need size from eprocend*/
#endif

#ifdef DGUXRE
extern int commonus;		/* allows underscores on commons */

#endif
static short int funcrettype;	/* function result type set by Entry Point Info*/
static short int funcretsize;	/* size of function result  */
static int parenthighpc;	/* HIGHPC of ENTRY stmt parent routine   */


/************************/
/**  SERVICE ROUTINES  **/
/************************/




static void puterror(char * s) {
/*************************************************************************/
/**    Compilation ends in disarray. Message and stop tidily            **/
/*************************************************************************/
extern int errno;
	printf("** PUT error **\n");
	errno=0;					/* if not zero perror adds text !*/
	perror( s);
	;	 
	imp_stop();
}	/*PutError*/



static void outsymbol(int symno) {
/*************************************************************************/
/**    print a symbol table entry for diags purposes                    **/
/*************************************************************************/
int ad,x;
Elf32_Sym *sym;

	sym=&syms [symno];
	if (ELF32_ST_BIND(sym->st_info)==STB_LOCAL)  printf("L "); 
	else printf("G ");
	printf("%08x ",(unsigned)sym->st_value);
	ad=dictstart+sym->st_name;
	printf(" ");
	do {
		x=(*(unsigned char  *)(ad));
		if (x==0)   break ;
		printf("%c",x);
		ad++;
	} while (1) /* FOR EVER */;
}



/*************************************************************************/
/** Swapping Routines                                                   **/
/** These are only used in cross Endian compilations when Eswapmode     **/
/** returns a non zero value                                            **/
/*************************************************************************/





static int wordswap(int x) {
	return (((x<<24)|((x<<8)&0xFF0000))|(((unsigned)x>>8)&0xFF00))|((unsigned)x>>24);
}



static int halfswap(int x) {
	return (((x&255)<<8)|(((unsigned)x>>8)&255));
}



static void areaswap(int basead,int len) {
	int i;
	i=0;
	while (i<len) {
		(*(int  *)(basead+i))=wordswap((*(int  *)(basead+i)));
		i+=4;
	}
}



static void stentryswap(Elf32_Sym *st) {
/********************************************************************************/
/** Swpa a single symbol table entry                                           **/
/********************************************************************************/
	st->st_value=wordswap(st->st_value);
	st->st_name=wordswap(st->st_name);
	st->st_size=wordswap(st->st_size);
	st->st_shndx=halfswap(st->st_shndx);
}



static void elfhdrswap(Elf32_Ehdr *e) {
/********************************************************************************/
/** Swaps the File header                                                      **/
/********************************************************************************/
	e->e_version=wordswap(e->e_version);
	e->e_entry=wordswap(e->e_entry);
	e->e_phoff=wordswap(e->e_phoff);
	e->e_shoff=wordswap(e->e_shoff);
	e->e_flags=wordswap(e->e_flags);
	e->e_type=halfswap(e->e_type);
	e->e_machine=halfswap(e->e_machine);
	e->e_ehsize=halfswap(e->e_ehsize);
	e->e_phentsize=halfswap(e->e_phentsize);
	e->e_phnum=halfswap(e->e_phnum);
	e->e_shentsize=halfswap(e->e_shentsize);
	e->e_shnum=halfswap(e->e_shnum);
	e->e_shstrndx=halfswap(e->e_shstrndx);
}



/********************************************************************************/
/*   PINITIALISE - CODE GENERATION BEGINS WITH THIS CALL                        */
/********************************************************************************/
void pinitialise(int version,int release,int language) {
char lang [33] ;
static struct areafm zeroarea;
int i;

	faulty=0;			/* Always faulty unless initialised properly */
	swapmode=eswapmode();
	sourcelang=language&0xFFFF;
	sourcelangvariant=((unsigned)language>>16)&255;
	targetvariant=(unsigned)language>>24;	/* Defined in cgtarget & passed on*/
	if (sourcelang==imp) {
		strcpy(lang,"IMP80"); 
		impp=1;
	} else if (sourcelang==fortran)  strcpy(lang,"FORTRAN77")
		; 
	else if (sourcelang==ccomp)  strcpy(lang,"CC"); 
	else if (sourcelang==pascal)  strcpy(lang,"Pascal");



	curblock=&blocks [0+1];		/* Set pointer to dummy outer level */

	relsmalloc=(int )malloc(defaultareasize);
	rels=(struct rfm *)(relsmalloc);
					/* grab an area for reloc table */
	startrels=rels;			/* Note reloc table sections are not */
					/* contiguous so dont need to be 'areas' */

	areas=(struct areafm *)((int)&zeroarea+(lowestarea*sizeof(struct areafm)));	/* Start of area table */

	expandarea(0);
	areas [zgst-lowestarea].sym=epcareatoelfsym [zgst];	/* .bss */

	/* Initialise symtab in case psymbol never called  */

	expandarea(symtab);
	syms=(Elf32_Sym*)((areas [symtab-lowestarea].base));
	maxsyms=areas [symtab-lowestarea].max/symboltableentrysize;
	for (i=0; i<=symtab; i++)  nrels [i]=0;	/*Incase put ever reusable          */
#if (DwarfProducer==PUT)
	if (sdb!=0) {
		insertfilename(sourcelang);	/*sets up dwarf compile_unit DIE */
	}
#endif

	/* For position independent code set up a symbol for the GOT                 */

	if (((target==elfsparc)||(target==elfmips)||(target==elf386))&&(Pic!=0)) {
		psymbol(gotnametext,0,0,STT_OBJECT,STB_GLOBAL,0);
		gotsym=nextsym;
		if (gotsym!=epcareatoelfsym [plt])  puterror("Put not set for sharing");
	}
}	/*Pinitialise*/
/**                                                                          */



void preinitialise() {
/*************************************************************************/
/** Reinitialise                                                        **/
/*************************************************************************/
	static struct areafm zeroarea;
	int i;
	if (mon!=0) printf("Preinitialise\n");
			/* first reinitialise the owns   */
	unasscheck=1;
	dictindex=0;
	impp=0;
	curlexlev=0;
	endpending=0;
	debuglevel=0;
	mainentrypoint=0;
	line=0;
	gotsym=0;

#if(DwarfProducer==PUT) 
	debugptr=0;
#endif;
	maxsyms=0;
	nsects=1;
	maxloc=0;
	for (i=0; i<=5; i++) {
		regsectdata [i]=0;
	}
	for (i=0; i<=maxsect; i++) {
		sectionposition [i]=0;
		sectionsizes [i]=0;
		sectionentryno [i]=0;
	}
	crel=0;
	maxarea=0;
	toparea=21;
	dictad=0;
	maxdictad=0;
	dictstart=0;
	maxdata=0;
	lev=0;
	shptr=1;
	lastdiagsrec=-1;
	linehdroffset=-1;			/* no line number entries yet */
	/*                                                                           */
	faulty=0;				/* Always faulty unless initialised properly */
	curblock=&blocks [0+1];			/* Set pointer to dummy outer level */
	relsmalloc=(int )malloc(defaultareasize);
	rels=(struct rfm *)relsmalloc;

			/* grab an area for reloc table */
	startrels=rels;	/* Note reloc table sections are not */
			/* contiguous so dont need to be 'areas' */
	areas=(struct areafm *)((int)&zeroarea+(lowestarea*sizeof(struct areafm)));
			/* Start of area table */
	expandarea(0);
	areas [zgst-lowestarea].sym=epcareatoelfsym [zgst];	/* .bss */
			/* Initialise symtab in case psymbol never called                            */

	expandarea(symtab);
	syms=(Elf32_Sym*)((areas [symtab-lowestarea].base));
	maxsyms=areas [symtab-lowestarea].max/symboltableentrysize;
	for (i=0; i<=symtab; i++)  nrels [i]=0;	/*Incase put ever reusable          */

			/* Source lang still set from Pinitialise */

#if (DwarfProducer==PUT)
	if (sdb!=0) {
		insertfilename(sourcelang);	/*sets up dwarf compile_unit DIE */
	}
#endif

	/* For position independent code set up a symbol for the GOT  */

	nextsym=stfixedentries-1;
	if (((target==elfsparc)||(target==elfmips)||(target==elf386))&&(Pic!=0)) {
		psymbol(gotnametext,0,0,STT_OBJECT,STB_GLOBAL,0);
		gotsym=nextsym;
		if (gotsym!=epcareatoelfsym [plt])  puterror("Put not set for sharing");
	}
	procstartline=-1;		/*=undefined*/
	lastline=-1;
	nextsym=stfixedentries-1;
	lastca=-1;
}	/*PReinitialise*/

void psettargetflags(int flags){
/*************************************************************************/
/** allows special seting of flags in elf header                        **/
/*************************************************************************/
	privatehdrflags=flags;
}




void freespace(int ad) {
/*************************************************************************/
/**    This is EPCs interface to FREE                                   **/
/**    Enables monitoring or checking to take place                     **/
/*************************************************************************/
	if (malmon!=0) printf(" FREE %2d\n",ad);	 
	free((char *)ad);
}	/* Free space   */
/**                                                                          */



int getspace(int size/*bytes*/) {
/*************************************************************************/
/**     This is EPC's interface to MALLOC                               **/
/**    Enables monitoring or checking to take place                     **/
/*************************************************************************/
int flag;

	size=(size+7)&(-8);	/* keep everything d-w aligned */
	if (malmon!=0) {
		printf(" MALLOC %d",size);	 
		flag=(int )malloc(size);
		printf(" flag = %x\n",flag);	 
		if ((flag+size)>maxdata)  maxdata=flag+size;
	} else flag=(int )malloc(size);
	if (flag==0)  puterror(" MALLOC out of space ");
	return flag;
}


static void writetofile(int objid,int bytead,int len,char * sname) {
/*************************************************************************/
/**    Outputs the object file. Really just an interface to             **/
/**    the Unix write routine. Useful for monitoring on when on a       **/
/**    non unix system                                                  **/
/*************************************************************************/
	int i,j,sym;
	if (mon!=0) {
		printf("File Write of %s   %d  %d  %d\n",sname,objid,bytead,len);
		i=0;
		while (i<len) {
			printf("(%08x)   ",i);	 
			for (j=0; j<=7; j++) {
				printf("%08x ",(*(int  *)((bytead+i)+(4*j))));	 
			}
			for (j=0; j<=31; j++) {
				sym=(*(unsigned char  *)((bytead+i)+j));
				if ((32<=sym)&&(sym<=127))  printf("%c",sym); 
				else printf(" ");
				;
			}
			printf("\n");
			i+=32;
		}
	}
	j=filewrite(objid,bytead,len);
	if (j<len) 	/* Data not all written out */{
		puterror("Write to Disc fails - Disc Full or Faulty!");
	}
}	/*WritetoFile*/




static void fileposition(int objid,int byteoffset,int whence) {
/*************************************************************************/
/**    Selects the position for the next write                          **/
/*************************************************************************/
int newptr;

	if (mon!=0) printf("\nLSEEK %d %d %d\n",objid,byteoffset,whence);
	newptr=lseek(objid,byteoffset,whence);
	if (mon!=0) printf(" New Ptr = 2%d\n",newptr);
}	/*File Position*/




static void expandarea(int id) {
/*************************************************************************/
/**    This is crude way of implementing segmentation                   **/
/**    by getting a new hole twice the old size and                     **/
/**    copying the data into the front half of it.                      **/
/*************************************************************************/
int from,ad,newsize,oldsize,filler,type;

	from=areas [id-lowestarea].base;
	oldsize=areas [id-lowestarea].max;
	type=areas [id-lowestarea].type;
	if ((id==5)||(id>20))  filler=0; 
	else filler=(unsigned)type>>24;

	if (malmon!=0) printf("EXPAND AREA %d from, oldsize %x %x\n",id,from,oldsize);

	if (oldsize==0) 	/* First use of this area */{
		newsize=defaultareasize;
		ad=getspace(newsize);
		if (ad==0)  puterror("Get Space fails");
		fill(newsize,ad,filler);
		if ((0<id)&&(id<=setareas))  areas [id-lowestarea].sym=epcareatoelfsym [id];
	} else {		/* Expansion of existing area */

		newsize=(oldsize+oldsize)+8;	/*= twice OLDSIZE + malloc red tape space*/
						/* so space can be reused efficiently in bits */
		ad=(int )realloc((char *)from,newsize);
		if (ad==0)  puterror("REALLOC out of space");
		fill(newsize-oldsize,ad+oldsize,filler);
	}

	if (malmon!=0) printf("\nRealloc from to newsize %x %x %x\n",from,ad,newsize);

	if (id==0) {
		areas=(struct areafm*)((struct areafm *)(ad));	/* have moved the area table */
		maxarea=(newsize/sizeof(struct areafm))+(lowestarea-1);
	}

	areas [id-lowestarea].base=ad;
	areas [id-lowestarea].max=newsize;

}	/*Expand Area*/





/*******************************************************************/
/** PUT interface Code passing routines                            */
/*******************************************************************/

static void checkcodesize(int ca,int len) {
/*******************************************************************/
/*      Check that len bytes can be added to the current code area */
/*******************************************************************/
	while ((ca+len)>areas [code-lowestarea].max) {
		expandarea(code);
		codearea=((int *)(areas [code-lowestarea].base));
	}

}	/*CheckCodeSize*/


void pcword(int offset,int n) {
/*******************************************************************/
/*      Put 32 bits into code stream                               */
/*******************************************************************/

	if (mon!=0) printf(" PcWord: offset = %d  word = %x\n",offset,n);

	if (faulty!=0)  return ;
	checkcodesize(offset,4);
	codearea [(unsigned)offset>>2]=n;

}	/*PcWord*/




void pcbytes(int offset,int len,int ad) {
/*******************************************************************/
/*      Put 'Len' bytes of code into code stream                   */
/*******************************************************************/
int i,from,to;

	if (mon!=0) {
		printf(" Pcbytes  len  = %d Disp = %d",len,offset);
		if (len==1)  printf("%02x",(*(unsigned char  *)(ad))); 
		else {
			for (i=ad; i<=(ad+len)-1; i++) {
				if (((i-ad)&0x3F)==0)  printf("\n");
				printf("%02x",(*(unsigned char  *)(i)));
			}
		}
		printf("\n");
	}

	checkcodesize(offset,len);
	from=ad;
	to=areas [code-lowestarea].base+offset;
	for (i=1; i<=len; i++) {
		(*(unsigned char  *)(to))=(*(unsigned char  *)(from));
		to++;
		from++;
	}
	if (areas [code-lowestarea].highuse<(offset+len))  areas [code-lowestarea].highuse=offset+len;
}

/*---------------------------------------------------------------------------*/
/*------------------------ LINE NUMBER TABLE --------------------------------*/
/*---------------------------------------------------------------------------*/





int pgivecurrentsize(int area) {
/*************************************************************************/
/**    Returns the current size of area 'area' if it exists             **/
/*************************************************************************/

	if (!(((1<=area)&&(area<=toparea))&&(areas [area-lowestarea].base!=0)))  return -1;
	return areas [area-lowestarea].highuse;
}	/*Pgivecurrentsize*/
/**                                                                          */


/*   Line No tables are built in the Line Work Area under headers  the       */
/* current header is the atthe global offset LineHdrOffset.                  */
/*                                                                           */
/*   If a pushfile is encountered a new header is built at the current       */
/* end of the work area and linked back to the current one.   New line       */
/* numbers then go under the new current header.    If  a  popfile  is       */
/* encountered the fragment under the current header is completed with       */
/* a terminator and written into the line number area.    The  current       */
/* header reverts to that active before the previous pushfile.               */
/*                                                                           */




static void setlineheader(int offset) {
/*************************************************************************/
/** Build a new header in the Line Work area at offset. Pdbytes         **/
/** is used since this takes care of creating or expanding the line     **/
/** work Area as required                                               **/
/*************************************************************************/
	struct linehdrform newhdr;

	offset=(offset+3)&(-4);	/* Word Align*/
	memset(&newhdr,0,sizeof( struct linehdrform));
	newhdr.backlink=linehdroffset;
	newhdr.offset=16+offset;
	newhdr.length=8;	/* Size of empty fragment*/
	newhdr.codeaddr=0;	/* Needs a fixup after moving to Line sect */
	newhdr.last=lastline;
	newhdr.prevlastca=lastca;
	pdbytes(lineworkarea,offset,linehdrsize,(int)&newhdr);
	linehdroffset=offset;
	lastline=-1;		/* New file must reset */
	if (mon!=0) printf("hew hdr set up at %d [%x %x %x %x %x]\n",
			offset,newhdr.backlink,newhdr.offset,newhdr.last,
			newhdr.prevlastca,newhdr.length);	 
}	/* set line header*/
/*zzzzz*/



static void remline(int lineno,int codead	/*create line map*/) {
/*************************************************************************/
/**      Format of map is length                                        **/
/**                       addr =0  text section (via relocation)        **/
/**        and then repeated 10 byte entries:-                          **/
/**        4 bytes : line number                                        **/
/**        2 bytes statement no Xffff indicates not known               **/
/**        4 bytes : ad of code for this line                           **/
/*************************************************************************/
	int pos;
	struct linehdrform *linehdr;
	if (mon!=0) printf("REMline %d %x\n",lineno,codead);	 
	if (((impp==1)&&(lineno>9998)))  return ;	/*ignore IMP epilogue lines*/
	linehdr=(struct linehdrform*)(areas [lineworkarea-lowestarea].base+linehdroffset);
	pos=linehdr->offset+linehdr->length;
	linehdr->length=linehdr->length+lrecsize;
	pd4(lineworkarea,pos,lineno);
	pd2(lineworkarea,pos+4,-1);
	pd4(lineworkarea,pos+6,codead);
}	/*remline*/
/**                                                                          */



void ppushfile() {
/*************************************************************************/
/** Set up a header  for a new block of line nos                        **/
/*************************************************************************/
	struct linehdrform *linehdr;
	if (mon!=0) printf("Ppushfile \n");
	if (linehdroffset<0)  setlineheader(0);
	linehdr=(struct linehdrform*)(areas [lineworkarea-lowestarea].base+linehdroffset);
	setlineheader(linehdr->offset+linehdr->length);
}	/*Ppushfile*/
/**                                                                          */



int ppopfile() {
/*************************************************************************/
/** Terminate a block of line nos for an included file                  **/
/** Write the completed block to the .line sectio                       **/
/** returns its position relative to section start                      **/
/** Reverts so that further lines are added to the enclosing block      **/
/*************************************************************************/
	int posn,ftype;
	struct linehdrform *linehdr;
	if (mon!=0) printf("Ppopfile \n");

	remline(0,areas [code-lowestarea].highuse);
	linehdr=(struct linehdrform*)(areas [lineworkarea-lowestarea].base+linehdroffset);
	/* upsets utilities      LineHdr_length=(LineHdr_length+3)&(-4)              */
	posn=areas [linetab-lowestarea].highuse;
	pdbytes(linetab,posn,linehdr->length,(int)&linehdr->length);
	ftype=fullwordfix;

#if(target==elf88k) 
	ftype=debugtabfix
#endif;
	    fix(ftype,linetab,posn+4,code,0)	/* To head of code */;

	linehdroffset=linehdr->backlink;
	if (linehdroffset>=0) {
		linehdr=(struct linehdrform*)(areas [lineworkarea-lowestarea].base+linehdroffset);
		lastline=linehdr->last;	 
		lastca=linehdr->prevlastca;
	}
	return posn;
}	/*Ppopfile*/
/**                                                                          */



void plinestart(int lineno,int codead) {
/*************************************************************************/
/** Note the start of a new line                                        **/
/*************************************************************************/
	struct linehdrform *linehdr;

	if (faulty!=0)  return ;
	if (mon!=0) printf("\nLINE:%4d at %x\n",lineno,codead);

	if (linehdroffset<0)  setlineheader(0);
	if (codead>areas [code-lowestarea].highuse)  areas [code-lowestarea].highuse=codead;
	if (lineno==0) {
		if (procstartline>=0)  return ;
	} else {
		if (procstartline<0) {
			if ((sdb!=0)&&(curblock->postploffset!=0)) {
				fix(debugtabfix,debugtab,curblock->postploffset,code,codead);
				curblock->postploffset=0;
				/* marks the point where EDB set Proc brak point*/
			}
			codead=curblock->ca;
			procstartline=lineno-1;
			if (lastline>=procstartline)  lastline=procstartline-1;
		}
	}
	line=lineno;
	if (sdb!=0) {
		/* sdb gets confused by repeated line numbers */
		if ((lineno>lastline)||(procstartline<0)) {
			linehdr=(struct linehdrform*)(areas [lineworkarea-lowestarea].base+linehdroffset);
			if ((codead<=lastca)&&((linehdr->length-lrecsize)>=8))  linehdr->length=linehdr->length-lrecsize;	/*
			    Overwrite previous one */
			remline(lineno,codead);
			lastline=lineno;
		}
		lastca=codead;
	}
}	/*PLineStart*/




static int codeforline(int line) {
/*************************************************************************/
/**   Return codeaddress for 'line' from line number map                **/
/*************************************************************************/
	int i,base,codead,lineno;
	struct linehdrform *linehdr;
	linehdr=(struct linehdrform*)(areas [lineworkarea-lowestarea].base+linehdroffset);
	base=areas [linetab-lowestarea].base+linehdr->offset;
	i=base+linehdr->length;
	while (base<i) {
		bytemove(4,base,(int)&lineno);
		if (lineno>=line) {
			bytemove(4,base+6,(int)&codead);
			return codead;
		}
		base+=lrecsize;
	}
	return 0;
}







/************************************                                        */
/**                                 *                                        */
/** Put Interface Passing of Data   *                                        */
/**                                 *                                        */
/************************************                                        */

struct rdfm{
	int disp;
	int len;
	int copies;
};

#define rdsize 12

/********************************************************************************/
int pgetbytes(int curarea,int disp,int len) {
	/*                                                                           */
	/*returns the address of the initialisation for area CurArea at              */
	/*offset Disp covering Len bytes - returns ZERO if either the                */
	/*location has not been initialised or if Put is unwilling to                */
	/*delve into murky corners.                                                  */
	/*                                                                           */
	/*---as currently implemented, this Put will only accept queries             */
	/*   on Gla initialisations                                                  */

	int ad,bad,i;

	if (faulty!=0)  return 0;
	if (mon!=0) printf("  Pgetbytes ( %1d  Len = %1d  Disp= %1d",curarea,len,disp);	 

	if ((curarea==gla)&&(areas [gla-lowestarea].max>=(disp+len)))  ad=areas [gla-lowestarea].base+disp
	; 
	else ad=0;

	if (mon!=0) {
		if (ad!=0) {
			printf(" ");
			bad=ad;
			if (len==1)  printf("%02x",(*(unsigned char  *)(bad))); 
			else {
				for (i=bad; i<=(bad+len)-1; i++) {
					printf("%02x",(*(unsigned char  *)(i)));
				}
			}
		}
		printf("\n");
	}

	return ad;
}	/*of Pgetbytes                                                             */

/********************************************************************************/



void pdbytes(int curarea,int disp,int len,int ad) {
	struct areafm *a;
	int i,bad,to,encoded,from;
	struct rdfm *r;

	if (faulty!=0)  return ;
	if (mon!=0) {
		printf("  PDBytes ( %d len  = %d Disp=%d ",curarea,len,disp);
		bad=ad;
		if (len==1)  printf("%02x",(*(unsigned char  *)(bad))); 
		else {
			for (i=bad; i<=(bad+len)-1; i++) {
				printf("%02x",(*(unsigned char  *)(i)));
			}
		}
		printf("\n");
	}

	if (len==0)  return ;
	if ((sourcelang==imp)&&(curarea==diags)&&(len>=24)&&(lastdiagsrec<maxdiagsrec)) {
		lastdiagsrec++;
		diagsrecs [lastdiagsrec].doffset=disp;
		diagsrecs [lastdiagsrec].endline=line;
	}
	if ((curarea==5)||(curarea>20))  encoded=1; 
	else encoded=0;
	if (curarea>20)  curarea=syms [curarea-20].st_value;	/* common */
	a=&areas [curarea-lowestarea];


#if(trusted==0) 
	if ((disp<0)||(disp>0x7FFFFF))  puterror("bad displacement ");

#endif;

	from=ad;	/* copy to byte boundaries */
	if (encoded!=0) 	/* encoded area */{
		if (a->max==0) {
			expandarea(curarea); 
			a->linkdisp=0;
		}	/*first use */
		r=(struct rdfm*)(a->base+a->linkdisp);
		while (((((((a->linkdisp+rdsize)+rdsize)+r->len)+len)+6))>a->max) {
			/*@of last fragment + hdr of last frag                                       */
			/*                  + hdr for new frag + (len of last frag+rounding)         */
			/*                                     + (len of new frag+rounding)          */
			expandarea(curarea);
			r=(struct rdfm*)(a->base+a->linkdisp);
		}
		if ((disp==(r->disp+r->len))&&(r->copies<=1)) 	/*adjacent areas */{
			to=((a->base+a->linkdisp)+rdsize)+r->len;
			r->len=r->len+len;
			/* new start required */
		} else {
			to=((((a->base+a->linkdisp)+rdsize)+r->len)+3)&(-4);	/*4b bnd*/
			r=(struct rdfm*)(to);
			a->linkdisp=to-a->base;
			r->disp=disp;
			r->len=len;
			r->copies=1;
			to+=rdsize;
		}
		/* normal mapped area */
	} else {
		while ((disp+len)>=a->max)  expandarea(curarea);	/* suspicion that byte swopped m-cs go 1 byte too 
		far                                                                          */
		to=a->base+disp;
	}

	bytemove(len,from,to);
	/*                                                                           */
	/* The next line is needed for C++ who does its own thing. The final         */
	/* size of the debug area is not passed into PTERMINATE so put               */
	/* has to work it out. Write DBR must be careful to ensure debugptr          */
	/* is advanced before a call of pdbytes.                                     */
	/*                                                                           */
	if (a->highuse<(disp+len))  a->highuse=disp+len;

}	/*PDBytes*/


/********************************************************************************/



void pd(int area,int disp,int databyte) {
	int ad;
	if (faulty!=0)  return ;
	if ((databyte==0)&&(unasscheck==0))  return ;
	ad=(int)&databyte;
	if (((targetdata==elfdatamsb)&&(swapmode==0))||((targetdata==elfdatalsb)&&(swapmode!=0)))  ad+=3;
	pdbytes(area,disp,1,ad);
}	/*PD*/

/********************************************************************************/



void pd2(int area,int disp,int datadoublebyte) {
	int ad;
	if (faulty!=0)  return ;
	if ((datadoublebyte==0)&&(unasscheck==0))  return ;
	ad=(int)&datadoublebyte;
	if (((targetdata==elfdatamsb)&&(swapmode==0))||((targetdata==elfdatalsb)&&(swapmode!=0)))  ad+=2;
	pdbytes(area,disp,2,ad);
}	/*PD2*/

/********************************************************************************/



void pd4(int area,int disp,int dataquadbyte) {
	if (faulty!=0)  return ;
	if ((dataquadbyte==0)&&(unasscheck==0))  return ;
	pdbytes(area,disp,4,(int)&dataquadbyte);
}	/*PD4*/

/********************************************************************************/



void pdpattern(int area,int disp,int ncopies,int len,int ad) {
	int i,bad;
	struct areafm *a;
	int to,encoded,from;
	struct rdfm *r;

	if (faulty!=0)  return ;

	if (mon!=0) {
		printf("  PDPattern( area = %2d, disp = %2d, ncopies = %2d, length = %2d  ",
			area,disp,ncopies,len);
		bad=ad;
		for (i=bad; i<=(bad+len)-1; i++) {
			printf("%02x",(*(unsigned char  *)(i)));
		}
		printf("\n");
	}

	if ((area==5)||(area>20))  encoded=1; 
	else encoded=0;
	if (area>20)  area=syms [area-20].st_value;	/* common */
	a=&areas [area-lowestarea];
	if ((len==4)&&((*(int  *)(ad))==0)&&(((unsigned)a->type>>24)==0)&&(unasscheck==0))  return ;
	if (ncopies==0)  ncopies=1;



#if(trusted==0) 
	if ((disp<0)||(disp>0x7FFFFF))  puterror("bad displacement ");

#endif;

	from=ad;	/* copy to byte boundaries */

	if (encoded!=0) 	/* encoded area */{
		if (a->max==0) {
			expandarea(area); 
			a->linkdisp=0;
		}	/*first use */
		r=(struct rdfm*)(a->base+a->linkdisp);
		while (((((((a->linkdisp+rdsize)+rdsize)+r->len)+len)+6))>a->max)  expandarea(area);
		to=((((a->base+a->linkdisp)+rdsize)+r->len)+3)&(-4);	/*4b bnd*/
		r=(struct rdfm*)(to);
		a->linkdisp=to-a->base;
		r->disp=disp;
		r->len=len;
		r->copies=ncopies;
		bytemove(len,from,to+rdsize);
		/* normal mapped area */
	} else {
		for (i=1; i<=ncopies; i++) {
			while ((disp+len)>=a->max)  expandarea(area);	/*again byte swopped mcs as pdbytes*/
			bytemove(len,from,a->base+disp);
			disp+=len;
		}
	}

}	/*PDPattern*/



/*******************************************************************************/




void pfiller(int area,int filler) {
	int id,encoded;
	struct areafm *areafill;
	id=area;
	if ((area==5)||(area>20))  encoded=1; 
	else encoded=0;
	if (id!=zgst) {
		if (id>=20)  id=syms [id-20].st_value;	/*common*/
		areafill=&areas [id-lowestarea];
		if (((unsigned)areafill->type>>24)==filler)  return ;	/*Already filled */
		areafill->type=filler<<24;
		if ((encoded!=0)&&(areafill->max==0)) {
			pd(area,0,filler)	/* make sure area is initialised */;
		}
		if ((encoded==0)&&(areafill->max>0)) 	/* Data present */{
			fill(areafill->max-areafill->highuse,areafill->base+areafill->highuse,filler);
		}
	}
}	/*PFiller*/





static void placeinshdict(char * name,Elf32_Word *place) {
/*************************************************************************/
/**    As place in dict but contains only section names                 **/
/*************************************************************************/
	int l;
	l=strlen(name)+1;
	*place=shptr;
	strcpy((char *)&shnames [shptr],name);
	shptr+=l;
}


/***************************************************************             */



static void placeindict(char * name,Elf32_Word *place) {
/*************************************************************************/
/**      Put new name into dictionary (String table)                    **/
/*************************************************************************/
	int l,first;
	l=strlen(name)+1;	/* adding 1 for terminating zero */
	if ((dictad+l)>maxdictad) 	/* have to make dict bigger */{
		first=maxdictad;	/* 0 on first entry                                        */
		expandarea(dicttab);
		dictstart=areas [dicttab-lowestarea].base;	/* the new dict base after expansion */
		dictad=dictstart+dictindex;	/* go to end of previous dict in new area*/
		maxdictad=dictstart+areas [dicttab-lowestarea].max;

		/* Leave 1 bytes at front of dict for null string (ELF standard) */
		if (first==0) {
			dictstart=dictad;
			dictad++;
			dictindex++;
		}
	}

	*place=dictad-dictstart;	/*=  ptr from sym tab to dict */
	strcpy((char *)dictad,name);
	dictad+=l;	/* address of item added in dictionary*/
	dictindex+=l;	/* current offset into dictionary */
}	/*place in dict*/


/***********************************************                             */
/**                                            *                             */
/** Put Interface RELOCATION and REFERENCES    *                             */
/**                                            *                             */
/***********************************************                             */

#define lbrac (0xCA)

int pputbrac(int key,int level,int ca) {
	struct auxblockfm auxblock;
	int at;

	if (key==lbrac) {
		/*       Psymbol(".bb",ca,Textsect,Tnull,Cblock,0,1)                         */
	} else {
		/*       Psymbol(".eb",ca,Textsect,Tnull,Cblock,0,1)                         */
	}
	at=nextsym;
	memset(&auxblock,0,sizeof( struct auxblockfm));
	/*      Paux(addr(AuxBlock))                                                 */
	return at;
}	/*PPutBrac*/

void psetopenblock(int id,int ca) {
	Elf32_Sym *sym;
	struct auxblockfm *auxblock;

	lev++;
	level [lev-1]=id;	/* remember block start records' posn. */
	sym=&syms [id];
	sym->st_value=ca;
	auxblock=(struct auxblockfm*)&syms [id+1];
	auxblock->lnno=line;

}	/*PsetOpenBlock*/

void psetcloseblock(int id,int ca) {
	Elf32_Sym *sym;
	struct auxblockfm *auxblock;

	sym=&syms [id];
	sym->st_value=ca;
	auxblock=(struct auxblockfm*)&syms [id+1];
	auxblock->lnno=line;
	/*                                                                           */
	/* Now set in the Block start records the index of the first record          */
	/* past the block.                                                           */
	/*                                                                           */
	auxblock=(struct auxblockfm*)&syms [level [lev-1]+1];
	auxblock->endindex=id+2;
	lev--;
}	/*PsetCloseBlock*/

void psymbol(char * name,int value,int size,int type,int class,int area) {
/*************************************************************************/
/**     remember a name and its properties for inclusion in the         **/
/**     object file symbol tables                                       **/
/**    Undefined symbols (references) have are=0 and value=0            **/
/*************************************************************************/
Elf32_Sym *sym;

	if (mon!=0) printf("PSYMBOL for %s at  %d \n",name,nextsym+1);	 
	nextsym++;
	if ((nextsym+1)>=maxsyms) 	/*+1 to always leave room for an aux symbol */{
		expandarea(symtab);
		syms=(Elf32_Sym*)((areas [symtab-lowestarea].base));
		maxsyms=areas [symtab-lowestarea].max/symboltableentrysize;
	}

	sym=&syms [nextsym];
	memset(sym,0,sizeof( Elf32_Sym));
	placeindict(name,&sym->st_name	/* remember name. */);

	sym->st_value=value;
	sym->st_size=size;
	sym->st_info=ELF32_ST_INFO(class,type);
	sym->st_shndx=area;
}	/*PSymbol*/




int preplynextsymbol() {
	if (mon!=0)  printf("PreplyNextSymbol\n");
	return nextsym+1;
}	/*PReplyNextsymbol*/




void pbackup(int ad) {
	Elf32_Sym *r;
	if (mon!=0)  printf("PbackupSymbol\n");
	r=(Elf32_Sym*)(ad);
	*r=syms [nextsym];
	nextsym--;
}	/*PBackup*/

void psetendindex(int id,int index) {
	struct auxtagfm *auxtag;

	auxtag=(struct auxtagfm*)&syms [id];
	auxtag->endindex=index;
}	/*PsetEndIndex*/



/********************************************************************************/
/*   PXNAME  -  EXTERNAL PROCEDURE SPEC                                      */
/********************************************************************************/



int pxname(int type,char * s) {
/**********************************************************************/
/* Xrefs are used many times so establish mapping to integer ID early */
/* and save on holding/passing of strings                             */
/**********************************************************************/
char name [256] ;
char temp [256] ;
int i,k,elftype;
Elf32_Sym *sym;

	if (faulty!=0)  return 0;
	strcpy(name,symbolprefix);
	if ((s[0]=='s') && (s[1]=='#')) {
		strcpy(temp,s);
		temp[1]='_';
		strcat(name,temp);
	} else {
		strcat(name,s);
	}

	/* look to see if this is a repeated reference */

	k=stfixedentries;
	for (i=k; i<=nextsym; i++) {
		sym=&syms [i];
		if (ELF32_ST_BIND(sym->st_info)==STB_GLOBAL && dictstart!=NULL &&
			strcmp(name,(char *)(dictstart+sym->st_name))==0) 	/*name already in place*/{
			if (mon!=0)  printf("  PXname:(rep) %s symID = %d\n",s,i+20);
			return i+20;
		}
	}

	elftype=(type&2)?STT_OBJECT: STT_FUNC;
	psymbol(name,0,0,elftype,STB_GLOBAL,0)	/* first occurrence of name */;
	if (mon!=0)  printf("  PXname: %s symID = %d\n",s,nextsym+20);
	return nextsym+20;

}	/*PXname*/




/********************************************************************************/
static void fix(int type,int area,int disp,int tgt,int tgtdisp	/* Remember a reloc. request */) {
	struct rfm *r;
	int ad;

	if (mon!=0) printf("FIX: type=%d ,area=%d ,disp=%d ,tgt=%d ,tgtdisp=%d\n",
			type,area,disp,tgt,tgtdisp);	 


#if(trusted==0) 
	if (area!=255 && area!=254) {
		if (area<1 || area>(nextsym+20) || tgt<1 || tgt>(nextsym+20) ||
		   (area>1 && areas [area-lowestarea].base==0))
			  puterror("Fix - Bad relocation request");	/* Unitialised area */
	}
#endif;


	do {
		crel++;
		r=&rels [crel-1];
		if ((crel+1)>maxrels) 	/* start next block of relocations */{
			if (malmon!=0)  printf("      Space for relocation tables\n");
			ad=getspace(defaultareasize);
			/* marker in type field that this is not a reloc*/
			/* , but contains addr of next block            */
			r->hostdisp=0xFF000000;
			r->tgtdisp=ad;
			crel=0;
			rels=(struct rfm*)((struct rfm *)(ad));
		} else break ;
	} while (1) /* FOR EVER */;

	if (type<200) 	/* if it is a genuine reloc request , count it */{
		if (area<=symtab)  nrels [area]=nrels [area]+1; 
		else nrels [gla]=nrels [gla]+1;
		;
	}

	r->tgtarea=tgt;
	r->tgtdisp=tgtdisp;
	r->hostarea=area;
	r->hostdisp=(type<<24)|disp;
}

/********************************************************************************/
/*   PFIX  -  REQUEST A RELOCATION                                              */
/********************************************************************************/



void pfix(int hostarea,int disp,int tgtarea,int tgtdisp) {
/*************************************************************************/
/*A relocation request: set word in Hostarea                             */
/*                      displacement =  disp  bytes                      */
/*                   to the address of area  tgtarea                     */
/*                      displacement = tgtdisp bytes                     */
/*************************************************************************/

int type;
	if (faulty!=0)  return ;

	if (mon!=0) printf("  PFIX(Fixup %d/%d ->%d/%d  type=%d)\n",hostarea,disp,tgtarea,tgtdisp,type);


#if(trusted==0) 
	if ((disp<0)||(disp>0xFFFFFF))  puterror("Pfix - bad displacement ");

#endif;

	if (!(hostarea==code)) {
		while ((disp+4)>areas [hostarea-lowestarea].max)  expandarea(hostarea);
	}

	type=fullwordfix;

#if(target==elfsparc) 
	if ((hostarea==code)&&(tgtarea>setareas))  type=R_SPARC_WDISP30;	/* Orrible frig   */

#endif;
	fix(type,hostarea,disp,tgtarea,tgtdisp);

}	/*Pfix*/


void 

pfix2(int hostarea,int disp,int tgtarea,int tgtdisp,int type) {
/*************************************************************************/
/**   PFIX2  -  REQUEST A RELOCATION of a given type                    **/
/**    A relocation request: type= 0 =>a normal fixup - 32 bit          **/
/**                          type= 1 => a hi/LO22   fixup               **/
/**                          type= 2 => a 32bit code to code  fixup     **/
/**                          type= 3 => a call   fixup - PC rel 30 bit  **/
/**                          type= 4 => a fix up in the GOT (offset only)*/
/**                          type= 5 => a fix up to the GOT(maybe hi-lo)**/
/**                          type= 6 => a (truncated) fix to GOT        **/
/**                                      suitable for small PIC only    **/
/**                          type= 7 => a relative fix to GOT           **/
/**                                      suitable for finding GOT only  **/
/**                          type=8&9 is type 1 as 2 separate fixups    **/
/**                          type=10&11 is type 4 as 2 separate fixups  **/
/**                          type=12&13 is type 5 as 2 separate fixups  **/
/**     Type 4 may be HI-LOW (Large PIC model) and result in the offset **/
/**     in the GOT of the symbols reference being loaded. A fix         **/
/**     is needed as the GOT is built by the linker not the compiler    **/
/**     Type 5 is used to find the GOT only and produces a relative addr**/
/**     the entry sequence has to do a BALR 0 to find out where it has  **/
/**     been loaded and add this to the relative offset provided by this**/
/**     fixup in order to set a pointer to the GOT                      **/
/*************************************************************************/
int mainfix,subfix;

	if (faulty!=0)  return ;

	if (mon!=0) printf("  Pfix2(Fixup %d/%d  -> %d/%d ---type=%d\n",hostarea,disp,tgtarea,disp,type);	 

#if(trusted==0) 
	if ((disp<0)||(disp>0xFFFFFF))  puterror("Pfix2 - bad displacement");
/**PutError("Pfix2 - bad reloc type") %IF type<0 %OR type>13**/

#endif;

	if (!(hostarea==code)) {
		while ((disp+4)>areas [hostarea-lowestarea].max)  expandarea(hostarea);
	}
	if (type<0) {
		mainfix=-type; 
		subfix=0;
	} else {
		mainfix=fixuprel [type]; 
		subfix=fixupauxrel [type];
	}
	if ((hostarea==debugtab)&&(mainfix==fullwordfix))  mainfix=debugtabfix;
	fix(mainfix,hostarea,disp,tgtarea,tgtdisp);

#if(target==elfsparc) 
	if (type==5)  tgtdisp+=4;	/*Special for sparc hi-lo relative                 */

#endif;
	if (subfix!=0)  fix(subfix,hostarea,disp+4,tgtarea,tgtdisp);
}	/*Pfix2*/



/********************************************************************************/



void pdxref(int area,int disp,int id) {

	if (faulty!=0)  return ;

	if (mon!=0) printf("  PDXREF( Fixup %d/%d -> %d/)\n",area,disp,id);

	fix(fullwordfix,area,disp,id,0)	/* I expect a Pname to have been done earlier */;

}	/*PDxref*/


int pcdataarea(int visibility,EPC_offset length,int align,char * name) {
/*************************************************************************/
/** Add a C initialised data area that can be rlocated. It is exactly   **/
/** like an initialised common without the common property. It will go  **/
/** into the data section but be accessed thro its own symbol and not   **/
/** as GLAREG+offset. This is needed for PIC to work on Intel and       **/
/** perhaps other machines. Initially sym_Value has the area no and     **/
/** sym_shdx is zero. The correct values are added in Pgenearteobject   **/
/*************************************************************************/
int symtype;
char s [256] ;
	if (faulty!=0)  return 0;

	if (mon!=0) printf("PCDataarea - %s vis=%d al=%d len=%d\n",name,
			visibility,align,length);

	strcpy(s,symbolprefix);
	strcat(s,name);
	toparea++;
	if (toparea>maxarea)  expandarea(0);
	symtype=STB_GLOBAL;
	if (visibility!=0)  symtype=STB_LOCAL;
	psymbol(s,toparea,length,STT_OBJECT,symtype,0);
	areas [toparea-lowestarea].sym=nextsym+20;
	areas [toparea-lowestarea].align=align;
	pd(toparea,0,0);	/* Force initialisation    */
	return nextsym+20;
}	/*PCcommon*/


void pdataentry(char * name,int area,EPC_offset maxlen,EPC_offset disp) {
/********************************************************************************/
/*  Defines point at offset in area as a visible data symbol of length maxlen   */
/********************************************************************************/
char s[256];

	if (faulty!=0)  return ;

	if (mon!=0) printf(" PDataEntry( %d/%d len= %d name=%s)\n",area,disp,maxlen,name);

#if(DwarfProducer==PUT) 
	if (sdb!=0)  return ;	/* externs declared at the end */
#endif;

	strcpy(s,symbolprefix); strcat(s,name);
	psymbol(s,disp,maxlen,STT_OBJECT,STB_GLOBAL,area);
}	/*PDataEntry*/




/*****************************************************************************/
/*                                                                           */
/*    The next three routines deal with PROCEDURES                           */
/*                                                                           */
/*****************************************************************************/


/********************************************************************************/
/*    PNextsymbol - LOCAL PROCEDURE SPEC                                        */
/********************************************************************************/
int pnextsymbol() {

	if (faulty!=0)  return 0;

	nextsym++;
	if (nextsym>=maxsyms) {
		expandarea(symtab);
		syms=(Elf32_Sym*)((areas [symtab-lowestarea].base));
		maxsyms=areas [symtab-lowestarea].max/symboltableentrysize;
	}

	if (mon!=0)  printf("Symbol reserved: %d \n",nextsym+20);
	return nextsym+20;

}	/*PNextsymbol*/

/********************************************************************************/
/*    PENTRY    - SIDE CODE ENTRY                                               */
/********************************************************************************/



int pentry2(int props,int codedisp,int id,char * name) {
/*************************************************************************/
/**    Note a side entry. If id>=0 then it has already been define as a **/
/**    reference so alter the existing symbol entry                     **/
/*************************************************************************/
Elf32_Sym *sym;
char s [256] ;
int scope,type;

	if (faulty!=0)  return 0;
	if (mon!=0) printf(" Pentry2: %s Codedisp =%x  id=%d\n",name,codedisp,id);
	/* make a local copy of name adding such prefixes as the various
	   options and operatiing systems demand                         */

#ifdef DGUXRE
	if (ecsnameprefix==NULL) s[0]=0; else strcpy(s,ecsnameprefix); strcat(s,symbolprefix);
#else
	strcpy(s,symbolprefix);
#endif
	strcat(s,name);
	if (codedisp<0) {
		scope=STB_LOCAL;
		type=STT_NOTYPE;
		codedisp=-codedisp;
	} else {
		if ((props&1)==0)  scope=STB_LOCAL; 
		else scope=STB_GLOBAL;
		;
		type=STT_FUNC;
	}
	if (id>0) {
		sym=&syms [id-20];
		sym->st_value=codedisp;
		sym->st_info=ELF32_ST_INFO(scope,type);
		sym->st_shndx=code;
		if (dictstart!=NULL && (*(unsigned char  *)(dictstart+sym->st_name))==0)  placeindict(s,&sym->st_name);
	} else {
		psymbol(s,codedisp,0,type,scope,code)	/* make symbol table entry */;
		id=nextsym+20;
	}
	if (mon!=0) printf("  Pentry2_ID= %d\n",id); 

	return id;

}	/*Pentry2*/



int pentry(int index,int codedisp,char * name) {
/*************************************************************************/
/**    Old version no prvision for providing ID                         **/
/*************************************************************************/
	return pentry2(index,codedisp,-1,name);
}	/*Pentry*/




static void addbytesize( struct debugf *,int *,int );
static int fortrantagstring( int ,int );




void pproc(char * name,int props,int codead,int *id) {
/*************************************************************************/
/**    PPROC - START A NEW PROCEDURE                                    **/
/**       PROPS&1   = external                                          **/
/**       PROPS&2  = Main entry                                         **/
/**       PPROPS>>31 treated as PPROPS&2 for Historic reasons           **/
/*************************************************************************/
int scope,ptr,i,k,ttype,btype,sl;
short int Short;
char s [256] ;
char truncate [256] ;
Elf32_Sym *sym;
struct debugf debug;
#ifdef DGUXRE
	char rest[256];
#endif

	if (faulty!=0) {
		*id=1; 
		return ;
	}
	if (endpending==1)  completeend();

	if (mon!=0) {
		printf("  PProc: %s  ID = %d   address = %x   props = %x\n",name,
			*id,codead,props);
	}

	parentblock=curblock;	/* COPE WITH NESTED PROCEDURES */
	curlexlev++;
	curblock=&blocks [curlexlev+1];
	memset(curblock,0,sizeof( struct blockfm));
	debuglevel=0;
	if ((props&1)!=0)  scope=STB_GLOBAL; 
	else scope=STB_LOCAL;

	if ((name[0]=='s')&&(name[1]=='#')) {
		strcpy(s,symbolprefix);
		strcpy(truncate,name); truncate[1]='_';
		strcat(s,truncate);
	} else { 
#ifdef DGUXRE
		if (ecsnameprefix==NULL) s[0]=0; else strcpy(s,ecsnameprefix); strcat(s,symbolprefix);
#else
		strcpy(s,symbolprefix);
#endif
		strcat(s,name);
	}


	/* If this procedure has been declared as a spec previously then */
	/* a PNextsymbol will have reserved the symbol table entry 'ID'  */
	/* for it. If there was no spec then ID will = -1                */

	if ((impp==0)&&(*id==-1)) {

		/* Fortran may well have placed a reference to this entry earlier */
		/* Search backwards and overwrite (first case only) */

		k=stfixedentries;
		for (i=nextsym; i>=k; i--) {
			sym=&syms [i];
			if ((sym->st_value==0)&&((ELF32_ST_BIND(sym->st_info))==STB_GLOBAL)
			   && dictstart!=NULL && (strcmp(s,(char *)(dictstart+sym->st_name))==0))  *id=i+20;
		}
	}

	if ((props&0x80000002)!=0 || strcmp(s,imp_concat(symbolprefix,"s_go"))==0) {
		if (sourcelang==ccomp)  strcpy(s,centryname); 
		else {
#ifdef DGUXRE
		if (ecsnameprefix==NULL) s[0]=0; else strcpy(s,ecsnameprefix); strcat(s,ftentryname);
#else
		strcpy(s,ftentryname);	/*s = "main"*/
#endif
		}
	}
	if (*id==-1) {
		psymbol(s,0,0,0,0,0); 
		*id=nextsym+20;
	}
	if (((props&0x80000002)!=0)||(strcmp(s,imp_concat(symbolprefix,"s_go"))==0)) {
		mainentrypoint=*id-20;	/* remember symno till procend */
		/*gm*/
	}

	curblock->sym=*id-20;
	curblock->ca=codead;
	procstartline=-1;	/*ensure this ca is used in linemap                       */
	sym=&syms [*id-20];
	sym->st_value=codead;
	sym->st_info=ELF32_ST_INFO(scope,STT_FUNC);
	sym->st_shndx=code;
	if (dictstart!=NULL && (*(unsigned char  *)(dictstart+sym->st_name))==0)  placeindict(s,&sym->st_name);
#if (DwarfProducer==PUT)
	if (sdb!=0) {
		memset(&debug,0,sizeof( struct debugf));	 
		ptr=0;
		debug.tag=TAGsubroutine;
		if ((props&1)!=0)  debug.tag=TAGglobalsubroutine;
		addsiblink(&debug,&ptr,curlexlev-1,debuglevel);
		sl=strlen(name);
		while (name[strlen(name)-1]=='_') name[strlen(name)-1]=0;	/*strip trailing underscore for dwarf*/
		if ((props&0x80000002)!=0) strcpy(s,"MAIN"); else {
#ifdef DGUXRE
			if (ecsnameprefix!=NULL && strlen(ecsnameprefix)>0 && s[0]!=0) {
				if (strncmp(s,ecsnameprefix,strlen(ecsnameprefix))==0) {
					strcpy(rest,&s[strlen(ecsnameprefix)]);
					strcpy(s,rest);
				}
			}
#endif
		}
		addname(&debug,&ptr,s);
		if (strcmp(s,"MAIN")==0 || strcmp(s,"fmain")==0) {
			Short=ATprogram;
			bytemove(2,(int)&Short,(int)&debug.data [ptr]);
			ptr+=2;
			debug.data [ptr]=0;
			ptr++;
		}
		Short=ATlowpc;
		bytemove(2,(int)&Short,(int)&debug.data [ptr]);
		fix(debugtabfix,debugtab,(debugptr+ptr)+8,code,codead);
		ptr+=6;
		Short=AThighpc;
		bytemove(2,(int)&Short,(int)&debug.data [ptr]);
		curblock->highpcoffset=(debugptr+ptr)+8;
		ptr+=6;
		Short=ATEPCPrologue;
		bytemove(2,(int)&Short,(int)&debug.data [ptr]);
		curblock->postploffset=(debugptr+ptr)+8;
		ptr+=6;
		if (funcrettype!=0) {
			/* Function,gen return type                                                  */
			if (funcrettype==tchar) {
				btype=((debugptr+ptr)+4)+8;	/* TAGstring placed after TAGsub                */
				ttype=ATuserdeftype;
			} else {
				ttype=ATfundtype;
				btype=funcrettype;
			}
			addtype(&debug,&ptr,ttype,btype,0);
		}
		debug.len=ptr+6;
		writedbr(&debug);
		if (funcrettype==tchar) {
			/*if funcretsize 0 we have char* (*) function*/
			/*but don't know where length is use ATstringlen=0*/
			if (funcretsize==0) {
				btype=fortrantagstring(funcretsize,2);
			} else {
				btype=fortrantagstring(funcretsize,0);
			}
		}
	}
#endif

	if (mon!=0) printf(" symID = %d\n",*id); 

}	/*PProc*/


#if(target==elfmips) 
void preginfo(int iregs,int fregs) {
/*************************************************************************/
/** Mips requires register usage data to be collated                    **/
/*************************************************************************/
	if (mon!=0) printf("preginfo %x %x\n",iregs,fregs);	 
	regsectdata [0]=regsectdata [0]|iregs;
	regsectdata [2]=regsectdata [2]|fregs;
}

#endif;

/**************************************************************************  */



void pprocend(int codead,int framelength) {
/*************************************************************************/
/**    The end of a procedure. Fill in size param in ST                 **/
/**    Also the end address in SDB info where relevant                  **/
/**    and framesize from eprocend for sdb                              **/
/*************************************************************************/
	Elf32_Sym *sym;

	if (mon!=0) {
		printf("  PProcEnd: %x  framelength= %d \n",codead,framelength);	 
	}
	if (endpending!=0)  completeend();	/* nested propcs*/

	if ((trusted==0)&&(curlexlev==0))  puterror("PProcEnd - too many proc ends ");

	sym=&syms [curblock->sym];
	sym->st_size=codead-curblock->ca;
#if (DwarfProducer==PUT)
	if (sdb!=0) {
		fix(debugtabfix,debugtab,curblock->highpcoffset,code,codead);
		if ((lastdiagsrec>=0)&&(sourcelang==imp))  impsdb(lastdiagsrec);

#if(target==elf88k) || (target==elfmips)
		framesize=framelength;
#endif;
		    parenthighpc=codead;	/*save for any ENTRY statements*/
	}
#endif
	endpending=1;
}

static void completeend() {
/*************************************************************************/
/**    Since pproc & pprocend are called together fron Eprocend         **/
/**    the lexical links of debug info are screwed. This routine is     **/
/**    an attempt to hold off completing an end till the pproc          **/
/*************************************************************************/
	struct debugf dbr;
	if (mon!=0) 	printf("Complete end\n"); 
	endpending=0;
 #if DwarfProducer==PUT
	if (sdb!=0) {
		fillsiblink(curlexlev,debuglevel);
		dbr.len=4;	 
		writedbr(&dbr);	/* dummy record                                 */
	}
#endif

	curblock=parentblock;
	curlexlev--;
	parentblock=&blocks [curlexlev-1+1];
	debuglevel=0;

}	/*PProcEnd*/



#if(DwarfProducer!=frontend) 


/***********************************                                         */
/** Put Interface - Miscellaneous  *                                         */
/***********************************                                         */

/*                                                                           */
/*First some service routines for SDB records                                */
/*                                                                           */



static void addtype(struct debugf *dbr,int *ptr,int typeattr,int data,int modifier) {
/*************************************************************************/
/**    Adds the type attribute&value to the debug record                **/
/**    Basically two cases Fundamental types data=short const           **/
/**    User defined types data =offset to debug area                    **/
/**    modifier is the type modifier, this changes the type attribute   **/
/**    at present only volatile is supported for fortran                **/
/*************************************************************************/
	int i,len;
	short int Short;
	unsigned char mod;
	i=*ptr;
	if (typeattr==5)  typeattr=ATfundtype;
	if (typeattr==7)  typeattr=ATuserdeftype;
	if (modifier!=0) {
		if (typeattr==ATfundtype) {
			typeattr=ATmodfundtype;
		} else {
			typeattr=ATmodudtype;
		}
	}
	Short=typeattr;
	bytemove(2,(int)&Short,(int)&dbr->data [i]);
	if ((typeattr==ATmodfundtype)||(typeattr==ATmodudtype)) {
		if (typeattr==ATmodfundtype) {
			Short=3;	/* length- only 1 modifier at present!                             */
			len=Short+2;
		} else {
			Short=5;	/* user def type is a 4 byte ref                                   */
			len=Short;
		}
		bytemove(2,(int)&Short,(int)&dbr->data [i+2]);
		mod=modifier;
		bytemove(1,(int)&mod,(int)&dbr->data [i+4]);
	} else {
		len=2;
	}
	if ((typeattr==ATfundtype)||(typeattr==ATmodfundtype)) {
		Short=data;
		bytemove(2,(int)&Short,(int)&dbr->data [i+len]);
		*ptr=(*ptr+2)+len;
		return ;
	}
	if ((typeattr==ATuserdeftype)||(typeattr==ATmodudtype)) {
		fix(debugtabfix,debugtab,((debugptr+*ptr)+6)+len,debugtab,data);
		*ptr=(*ptr+4)+len;
		return ;
	}
	puterror("Bad debug type info");
}	/*add type*/
/**                                                                          */



static void addname(struct debugf *dbr,int *ptr,char * name) {
/*************************************************************************   */
/**    Adds the attribute&value for the text of a variable name         **/
/**    The coding assumes dbr has been zeroed!                          **/
/*************************************************************************   */
	int i,j,l;
	short int Short;
	i=*ptr;
	Short=ATname;
	bytemove(2,(int)&Short,(int)&dbr->data [i]);
	l=strlen(name);
	for (j=1; j<=l; j++)  dbr->data [(i+j)+1]=name[j-1];
	*ptr=(*ptr+l)+3;
}	/* add name*/




static void fillsiblink(int lexl,int dbl) {
/*************************************************************************/
/**    Sibling record are linked together for SDB                       **/
/*************************************************************************/
	struct blockfm *block;
	block=&blocks [lexl+1];
	if (block->siblink [dbl]!=0)  fix(debugtabfix,debugtab,block->siblink [dbl],debugtab,debugptr);
	block->siblink [dbl]=0;
}







static void addsiblink(struct debugf *dbr,int *ptr,int lexl,int dbl) {
/*************************************************************************/
/**    Add the sibling link to the record. The last link goes to a dummy**/
/**    since at this stage we do not know if this is the last SDB entry **/
/*************************************************************************/
	short int Short;
	fillsiblink(lexl,dbl);
	Short=ATsibling;
	bytemove(2,(int)&Short,(int)&dbr->data [*ptr]);
	blocks [lexl+1].siblink [dbl]=(debugptr+*ptr)+8;
	*ptr+=6;
}




static void generatestackloc(struct debugf *dbr,int *ptr,int offset,int params) {
/*************************************************************************/
/** generates the loc atoms required to locate an item at an offset from**/
/** the sp(88k) or fp(others). offset is the stack offset, updates the  **/
/** callers block ptr.                                                  **/
/** if params is non 0 then loc is for a parameter                      **/
/** For 88K parameters,(fortran area7),the offset is the offset into    **/
/** the parameter save area (parameters are saved on stack if -g). This **/
/** is added to the dynamic framesize (from eprocend) which is the      **/
/** amount of stack space required to hold any automatics and the       **/
/** stacked parameters eg:                                              **/
/**             sp on entry   ->  ...                    -----          **/
/**                              arg n                     :            **/
/**                              arg n-1                   :----------  **/
/**                              arg 1                     :   arg1 off **/
/**                              auto 1                    :----------  **/
/**                              auto n-1                  : framesize  **/
/**                              auto n                    :    /|\     **/
/**                              64 bytes of red tape(?)   :     |      **/
/**             sp after subu ->                         -------------- **/
/**                                                                     **/
/** For SPARC the code generator dumps arg 1 at %FP+PARAMBASE and       **/
/** arg n at %FP+PARAMBASE+sizeof(arg n)                                **/
/** PARAMBASE is a constant with value x'44' and is the same as the one **/
/** defined in sparc13.8.inc                                            **/
/*************************************************************************/

	int i,x;

	i=*ptr;
	dbr->data [i]=OPBASEREG;
	x=sdblnbreg;	/* frame pointer reg from include file                         */
	bytemove(4,(int)&x,(int)&dbr->data [i+1]);
	dbr->data [i+5]=OPCONST;

#if(target==elf88k) 
	/*88k uses sp,not fp                                                         */
	if (params==1) {
		offset+=framesize;
		/*autos on stack*/
	} else {
		offset=framesize-offset;
	}

#else

#if(target==elfsparc) 
	if (params==1) {
		offset+=parambase;
		/*autos on stack*/
	} else {

	}
	/*unknown target*/

#else

#if(Target==elfmips)
	offset+=framesize

#else
	if (params==1) {
		offset+=param1offset;
		/*autos on stack*/
	} else {

	}

#endif
#endif
#endif;
	bytemove(4,(int)&offset,(int)&dbr->data [i+6]);
	dbr->data [i+10]=OPADD;
	*ptr=i+11;

}	/*Generate Stack Loc                                                       */




static void addloc(struct debugf *dbr,int *ptr,int area,int offset,int ref,int offset2) {
/*************************************************************************/
/**    add the attribute & value pair to define variable location       **/
/**    if area is static a fixup is used. Otherwise a computation       **/
/**    must be included in the data                                     **/
/*************************************************************************/
	int i,j,x,k;
	short int Short;

	i=*ptr;
	j=i+4;
	Short=ATlocation;
	bytemove(2,(int)&Short,(int)&dbr->data [i]);

	if ((target==elf88k)&&((area==7)||(area==0))) 	/*params*/	/*stack*/{
		if (offset<0)  offset=-offset;	/* sp-off->sp+off as debuggers treat          */
		/* all addresses as unsigned                                                 */
		/* 88k codegen dumps arg regs to                                             */
		/* stack unlike sparc                                                        */
	}
	if (area==7) 	/*params*/{
		k=j;
		generatestackloc(dbr,&k,offset,1);
		j=k;
		/*stack*/		} else if (area==0) {
		/* compute from fp,(sp if 88k)                                               */
		k=j;
		generatestackloc(dbr,&k,offset,0);
		j=k;
	} else {
		if (area>0) {
			if (ref==-1)  x=4; 
			else x=3;
			;
			dbr->data [i+4]=x;	/*fixed up const or address follows                      */
			fix(debugtabfix,debugtab,(debugptr+*ptr)+11,area,offset);
			j=i+9;
		}
	};

	if (ref>0) {
		dbr->data [j]=6; 
		j++;
	}	/*deref*/
	if ((offset2!=0)||(area<0)) {
		dbr->data [j]=OPCONST;
		bytemove(4,(int)&offset2,(int)&dbr->data [j+1]);
		dbr->data [j+5]=OPADD;
		j+=6;
	}
	*ptr=j;
	Short=(j-i)-4;	/* fill in length                                            */
	bytemove(2,(int)&Short,(int)&dbr->data [i+2]);
}	/*add loc*/




static void addstringlen(struct debugf *dbr,int *ptr,int len,int param) {
/*************************************************************************/
/**    add the attribute varable pair for a (const) string length       **/
/**    if param is 1 then len is an offset into the param save area     **/
/**    which contains the character's length                            **/
/**    if param is 2 then we are writing out a zero stringlen for a     **/
/**    character*(*) function or entry, which is represented with an    **/
/**    ATstringlen of 0                                                 **/
/*************************************************************************/
	int i,j;
	short int Short;
	i=*ptr;
	Short=ATstringlength;
	bytemove(2,(int)&Short,(int)&dbr->data [i]);
	if (param==0) 	/*string len known at compile time-fortran uses bsize*/{
		Short=5;	/* 5 bytes follow (length of block)                                */
		bytemove(2,(int)&Short,(int)&dbr->data [i+2]);
		dbr->data [i+4]=OPCONST;
		bytemove(4,(int)&len,(int)&dbr->data [i+5]);
		*ptr=i+9;
	} else if (param==1) {
		j=i+4;
		generatestackloc(dbr,&j,len,1);
		dbr->data [j]=OPDEREF4;
		j++;
		*ptr=j;
		Short=(j-i)-4;	/* fill in length                                            */
		bytemove(2,(int)&Short,(int)&dbr->data [i+2]);
		/*char *(*) function return length*/
	} else if (param==2) {
		bytemove(2,(int)&Short,(int)&dbr->data [i+2]);
	};


}	/*add stringlen*/




static void addbytesize(struct debugf *dbr,int *dptr,int size) {
	int i;
	short int Short;
	i=*dptr;	 
	Short=ATbytesize;
	bytemove(2,(int)&Short,(int)&dbr->data [i]);
	bytemove(4,(int)&size,(int)&dbr->data [i+2]);
	*dptr+=6;
}




static void insertfilename(int lang) {
/*************************************************************************/
/**    Put the source file name as first entry in debug data            **/
/**    Sets up most of the compile_unit DIE                             **/
/**    Certain elements of this entry must be completed in Pterminate   **/
/**    as the info is not yet available                                 **/
/**    lang is the EPC language code                                    **/
/*************************************************************************/
	struct debugf dbr;
	int ptr,ptr1,len;
	int atlang;	/*dwarf language encoding*/
	short int Short;
	


static char cname [60+1];
	static const int elflang [20] = {
		0x8000	/*Imp*/,7	/*Fort*/,0,0	/*C*/,0,0,
		0,0,
		0,0,1,0,0,9,0	};

	memset(&dbr,0,sizeof( struct debugf));
	dbr.tag=TAGcompileunit;
	Short=ATlowpc;
	bytemove(2,(int)&Short,(int)&dbr.data [0]);
	fix(debugtabfix,debugtab,8,code,0);	/* fix Low PC to code start             */
	Short=AThighpc;
	bytemove(2,(int)&Short,(int)&dbr.data [6]);
	/* 8-11 will be fixed in Pterminate                                          */
	Short=ATsibling;
	bytemove(2,(int)&Short,(int)&dbr.data [12]);
	/* 14-17 will be fixed to end of debug data                                  */

	Short=ATlanguage;
	bytemove(2,(int)&Short,(int)&dbr.data [18]);
	atlang=elflang [lang-1];
	bytemove(4,(int)&atlang,(int)&dbr.data [20]);

	Short=ATstmtlist;
	bytemove(2,(int)&Short,(int)&dbr.data [24]);
	fix(debugtabfix,debugtab,32,linetab,0);	/* 26-29 point to linetab           */
	ptr=30;
	addname(&dbr,&ptr,srcfile);

	Short=ATproducer;
	bytemove(2,(int)&Short,(int)&dbr.data [ptr]);
	strcpy(cname,dwarfversion);
	len=strlen((char *)cname );
	bytemove(len,(int)&cname [0],(int)&dbr.data [ptr+2]);
	ptr=(ptr+3)+len;

	ptr1=(int )getcwd(NULL,512);
	if (ptr1!=0) {
		Short=ATcompdir;
		bytemove(2,(int)&Short,(int)&dbr.data [ptr]);
		len=strlen((char *)ptr1);
		bytemove(len,ptr1,(int)&dbr.data [ptr+2]);
		ptr=(ptr+3)+len;
	} else {
		puterror("getcwd");
	}

	Short=ATlouser|FORMDATA2;	/* DG dwarf extension for mxdb to indicate        */
	/* the compiler maps ident case                                              */
	bytemove(2,(int)&Short,(int)&dbr.data [ptr]);
	if (casesense==0) 	/*-CS option*/{
		Short=3;	/* DG dwarf extension 3 says compiler gives low case idents */
	} else {
		Short=1;	/* leaves as mixed case */
	}
	bytemove(2,(int)&Short,(int)&dbr.data [ptr+2]);
	ptr+=4;


	dbr.len=ptr+6;
	pdbytes(debugtab,0,dbr.len,(int)&dbr);
	debugptr=dbr.len;
}	/*insert filename*/




static void writedbr(struct debugf *dbr) {
/*************************************************************************/
/**    Outputs a debug record                                           **/
/*************************************************************************/
	int l,offset;
	l=dbr->len;
	offset=debugptr;
	debugptr+=l;	/* So pdbytes does not interefere qv */
	pdbytes(debugtab,offset,l,(int)dbr);
}	/*write DBR*/

/********************************************************************************/



static void addloc2(struct debugf *dbr,int *ptr,struct locf *loc) {
short int Short;
int i,j,x;

	i=*ptr;
	Short=ATlocation;
	bytemove(2,(int)&Short,(int)&dbr->data [i]);
	switch (loc->dis){
	case 0:
	case 1:

		dbr->data [i+4]=4+loc->dis;
		bytemove(4,(int)&loc->offset,(int)&dbr->data [i+5]);
		j=i+9;	 
		break;
	case 2:

		dbr->data [i+4]=1+loc->dref;
		dbr->data [i+8]=loc->offset;	/* >255 registers wont work   */
		j=i+9;	 
		break;
	case 3:

		if (loc->area==0) {
			/*compute from fp        */
			dbr->data [i+4]=OPREG;
			x=sdblnbreg;	/* frame pointer reg from include file     */
			bytemove(4,(int)&x,(int)&dbr->data [i+5]);
			dbr->data [i+9]=OPCONST;
			bytemove(4,(int)&loc->offset,(int)&dbr->data [i+10]);
			dbr->data [i+14]=OPADD;
			j=i+15;
		} else {
			dbr->data [i+4]=OPADDR;
			fix(debugtabfix,debugtab,(debugptr+*ptr)+11,loc->area,loc->offset);
			j=i+9;
		}
		if (loc->dref>0) {
			dbr->data [j]=6; 
			j++;
		}	/*deref*/
		break;
	default:	puterror("Bad diagnostic data in addloc2");
	}

	*ptr=j;
	Short=(j-i)-4;			/* fill in length    */
	bytemove(2,(int)&Short,(int)&dbr->data [i+2]);
}	/*add loc2*/



static void addbitsizeoff(struct debugf *dbr,int *ptr,int size,int offset) {
	short int Short;
	int i;
	i=*ptr;
	Short=ATbitoffset;
	bytemove(2,(int)&Short,(int)&dbr->data [i]);
	Short=offset;
	bytemove(2,(int)&Short,(int)&dbr->data [i+2]);
	Short=ATbitsize;
	bytemove(2,(int)&Short,(int)&dbr->data [i+4]);
	bytemove(4,(int)&size,(int)&dbr->data [i+6]);
	*ptr+=10;
}	/*add bit sizeof*/




int psdbbitentry(int tag,char * name,int type1,int type2,int bytes,int bitoffset,int bitsize,struct locf
*loc) {
/********************************************************************        */
/**   add an entry for a bit field                                  *        */
/********************************************************************        */
	short int Short;
	struct debugf dbr;
	int dptr,result;
	if (mon!=0) printf("PSDBbitENTRY %s type=%d %d\n",name,type1,type2);

	memset(&dbr,0,sizeof( struct debugf));	 
	dptr=0;	 
	result=0;
	if (((strcmp(name,".end")==0)||(strcmp(name,".END")==0))&&(debuglevel>0)) {
		dbr.len=4;
		fillsiblink(curlexlev,debuglevel);
		writedbr(&dbr);	/*dummy to terminate chain                                  */
		debuglevel--;
		return 0;
	}
	dbr.tag=tag;
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	addname(&dbr,&dptr,name);
	if (tag==4) {
		/* enumeration type                                                          */
		addbytesize(&dbr,&dptr,bytes);
		Short=0xF3;	/* shouldn't this be x'f0'!FORMBLOCK4??                         */
		bytemove(2,(int)&Short,(int)&dbr.data [dptr]);
		Short=loc->dis;	/* bytes following                                          */
		bytemove(2,(int)&Short,(int)&dbr.data [dptr+2]);
		bytemove(loc->dis,(int)&loc->offset,(int)&dbr.data [dptr+4]);
		dptr=(dptr+loc->dis)+4;
		return 0;
	}
	if (bitsize!=-1)  addbitsizeoff(&dbr,&dptr,bitsize,bitoffset);
	addtype(&dbr,&dptr,type1,type2,0);
	if (type2==0)  result=(debugptr+dptr)+4;
	addloc2(&dbr,&dptr,loc);
	return result;
}	/*PSDB Bitentry                                                            */



int psdbentry(int tag,char * name,int type1,int type2,int bytes,struct locf *loc) {
	return psdbbitentry(tag,name,type1,type2,bytes,-1,-1,loc);
}


static int fortrantagstring(int bytes,int tagmode) {
/*****************************************************************************/
/** Generates Fortran Tagstringtype for character items                      */
/** Fortran character variables are treated as user def types with either    */
/** at_bytesize if size known or at_stringlen if they are params             */
/** returns pointer to TAGstring die for use as userdefined type             */
/** mode=0, size known, mode=1 size is passed as an argument at runtime      */
/** and add stringlen generates location atoms                               */
/** if mode is 2 then add stringlen generates a 0 size at_stringlen to       */
/** indicate the return from a char* (*) function                            */
/*****************************************************************************/

	struct debugf dbr;
	int j,dptr;
	memset(&dbr,0,sizeof( struct debugf));	 
	dbr.tag=TAGstringtype;
	dptr=0;
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	if (tagmode==0) {
		/*length known at compile time                                               */
		addbytesize(&dbr,&dptr,bytes);
	} else if (tagmode==1) {
		addstringlen(&dbr,&dptr,bytes,tagmode);	/* length is param                  */
		/*char *(*) function return*/
	} else if (tagmode==2) {
		addstringlen(&dbr,&dptr,bytes,tagmode);	/* length is 0                      */
	};


	dbr.len=dptr+6;
	j=debugptr;
	writedbr(&dbr);
	return j;
}
/**                                                                          */



void gencommoninclusiondie(int cmnptr) {
/*****************************************************************************/
/** generates a common_inclusion_die in the current subroutine die          **/
/** cmnptr points to the aprropriate common_block_die                       **/
/*****************************************************************************/

	struct debugf dbr;
	static int dptr=0;
	static short int Short=0;

	memset(&dbr,0,sizeof( struct debugf));
	dbr.tag=TAGcommoninclusion;
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	Short=ATcommonreference;
	bytemove(2,(int)&Short,(int)&dbr.data [dptr]);
	bytemove(4,(int)&cmnptr,(int)&dbr.data [dptr+2]);
	dbr.len=dptr+12;
	writedbr(&dbr);

}	/* Gen Common Inclusion DIE                                                */


static const int tconv [17+1] = {
	tshort,tint,tnull,
	tfloat,tdouble,tnull,tcomplex,tdcomplex,
	tnull,tuchar,tushort,tbool,tnull,tchar,tchar,tschar,

	tint,tnull};
/**                                                                          */
/**                                                                          */
/**                                                                          */
int psdbarrctype(char * name,int type1,int type2,int bytes,int ndims,int order,int adbounds
#ifdef DGUXRE
	,int vtype
#endif
	) {
/*************************************************************************/
/**       Define an array in a record field with Known bounds           **/
/** record field types are modes,normal scalar or array types are       **/
/** classes straight out of the dict and are handled in psdbvar!        **/
/** hence this code can use the Tconv array to convert to dwarf types   **/
/** without having to check sizes. PSDB Struct Member is similar        **/
/** For DGUX Kevin has added an extra parameter may well cause problems **/
/*************************************************************************/
	short int Short;
	int i,j,ftype,aptr,atptr,modifier;
	struct debugf adbr;
	if ((mon!=0)&&(bytes!=0)) {
		printf("  PSDBarrc: %s type1,type2 = %d    %d\n",name,type1,type2);
	}
	atptr=debugptr;
	memset(&adbr,0,sizeof( struct debugf));	/* Clear record for array type info */
	adbr.tag=TAGarraytype;
	aptr=0;
	if (ndims>1) {
		/* Multi dimension needs ordering                                            */
		Short=ATordering;
		bytemove(2,(int)&Short,(int)&adbr.data [aptr])	/*ordering*/;
		Short=order;
		bytemove(2,(int)&Short,(int)&adbr.data [aptr+2]);
		aptr+=4;
	}
	i=aptr;
	Short=ATsubscrdata;
	bytemove(2,(int)&Short,(int)&adbr.data [aptr]);
	Short=11*ndims;	/* 11 bytes per dimension                                   */
	bytemove(2,(int)&Short,(int)&adbr.data [aptr+2]);
	aptr+=4;
	for (j=0; j<=ndims-1; j++) {
		adbr.data [aptr]=FMTFTCC;
		Short=tint;	/* Bound aresigned integers                                     */
		bytemove(2,(int)&Short,(int)&adbr.data [aptr+1]);
		bytemove(8,adbounds+(8*j),(int)&adbr.data [aptr+3]);	/* two consts          */
		aptr+=11;
	}
	adbr.data [aptr]=8;	/*element type defn next                                */
	aptr++;
	ftype=type2;
	if (type1<0) {
		type2=tconv [type2]; 
		type1=ATfundtype;
	}
	if (type2==tchar) {
		atptr=debugptr+18;	/* TAGstring comes first so adjust                       */
		type2=fortrantagstring(bytes,0);
		type1=ATuserdeftype;
	}
#ifdef DGUXRE
	if ((vtype&0x01000000)!=0) modifier=MODEPCrep88k;
#else
	modifier=0;
#endif
	addtype(&adbr,&aptr,type1,type2,modifier);
	Short=(aptr-i)-4;
	bytemove(2,(int)&Short,(int)&adbr.data [i+2]);
	addsiblink(&adbr,&aptr,curlexlev,debuglevel);
	if (strcmp(name,"")!=0)  addname(&adbr,&aptr,name);
	adbr.len=aptr+6;
	writedbr(&adbr);
	return atptr;
}	/* PSDBarrctype                                                            */




int psdbstructtype(char * name,int csu,int bytes) {
	struct debugf dbr;
	int dptr,j;

	if (mon!=0) printf("  PSDB Struct Type:%s  size=%d\n",name,bytes);

	memset(&dbr,0,sizeof( struct debugf));
	dbr.tag=TAGstructuretype;
	dptr=0;
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	if (!(strcmp(name,"")==0))  addname(&dbr,&dptr,name);
	addbytesize(&dbr,&dptr,bytes);
	j=debugptr;
	dbr.len=dptr+6;
	writedbr(&dbr);
	debuglevel++;
	return j;
}
/**                                                                          */



void psdbendstruct() {
	struct debugf dbr;
	struct blockfm *block;
	dbr.len=4;
	fillsiblink(curlexlev,debuglevel);
	writedbr(&dbr);
	block=&blocks [curlexlev+1];
	block->siblink [debuglevel]=0;
	debuglevel--;
	return ;
}
/**                                                                          */



int psdbptrtype(char * name,int type1,int type2) {
	struct debugf dbr;
	int dptr,j;
	memset(&dbr,0,sizeof( struct debugf));	 
	dbr.tag=TAGpointertype;	 
	dptr=0;
	if (!(strcmp(name,"")==0))  addname(&dbr,&dptr,name);
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	addtype(&dbr,&dptr,type1,type2,0);
	j=debugptr;
	writedbr(&dbr);
	return j;
}



void psdbfref(int marker,int key) {
	bytemove(4,(int)&key,areas [debugtab-lowestarea].base+marker);
}

/**                                                                          */



int psdbcmnstart(char * s,int id) {
/*************************************************************************/
/** Create dwarf common block DIE                                       **/
/** returns common block DIE ref so it can be referenced in any routine **/
/** which includes the common                                           **/
/** S is the common name,Id is its area                                 **/
/*************************************************************************/

	struct debugf dbr;
	int dptr,typeref;
	char str [64] ;

	if (mon!=0) printf("Psdbcmnstart %s    %d\n",s,id);

	memset(&dbr,0,sizeof( struct debugf));	 
	dptr=0;
	dbr.tag=TAGcommonblock;
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	strcpy(str,checkblankcommon(s));
	if (((strcmp(str,"_BLNK__")==0)||(strcmp(str,"_blank")==0))||(strcmp(str,"BLNK__")==0)) {
		strcpy(str,"");	/*    Mxdb expects null for blank common                    */
	}
	addname(&dbr,&dptr,str);
	addloc(&dbr,&dptr,id,0,-1,0);
	dbr.len=dptr+6;
	typeref=debugptr;
	writedbr(&dbr);
	debuglevel++;	/* common members are children                                */
	return typeref;	/* for later refs to common                                 */
}
/**                                                                          */



void psdbcmnend(char * s,int id) {
	struct debugf dbr;
	if (mon!=0) printf("Psdbcmnend %s    id=%d\n",s,id);
	dbr.len=4;
	fillsiblink(curlexlev,debuglevel);
	writedbr(&dbr);
	debuglevel--;
	return ;

}
/**                                                                          */


void psdbstructmember(char * name,int type1,int type2,int disp,int size,int nels
#ifdef DGUXRE
	,int vtype
#endif
	) {
/*********************************************************************************/
/** Set up a new dbx type for a structure. Called once for each structure member*/
/** name        - field name                                                 */
/** type1       - <0 if item is scalar else 0                                */
/** type2       - mode type of field                                         */
/** disp        - byte offset of field in struct                             */
/** size        - size in bytes of field type                                */
/** nels        - no. of elements (if array field)                           */
/*********************************************************************************/
	struct debugf dbr;
	int dptr;
	int type,ttype,ftype,modifier;

	if (faulty!=0)  return ;

	if (mon!=0) {
		printf("  PSDB Struct Member: %s type1=%x type2=%x",name,type1,type2);
		printf("disp =%d size=%d nels=%d\n",disp,size,nels);	 
	}

	if (type1<0) 	/*not array or record*/{
		ftype=ATfundtype;
		ttype=type2;
		type=tconv [ttype];
		if (type==tchar) {
			ftype=ATuserdeftype;
			type=fortrantagstring(size,0);
		}
	} else {
		ftype=ATuserdeftype;
		type=type2;
	}

	memset(&dbr,0,sizeof( struct debugf));	 
	dbr.tag=TAGmember;	 
	dptr=0;
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	if (!(strcmp(name,"")==0))  addname(&dbr,&dptr,name);
#ifdef DGUXRE
	if ((vtype&0x01000000)!=0) modifier=MODEPCrep88k;
#else
	modifier=0;
#endif
	addtype(&dbr,&dptr,ftype,type,modifier);
	addloc(&dbr,&dptr,-1,0,0,disp);
	dbr.len=dptr+6;
	writedbr(&dbr);
	return ;
}	/*of PSDB Struct Member                                                    */
/**                                                                          */
/**                                                                          */


#define iinteger 1
#define real 2
#define complex 3
#define logical 4
#define character 5	/*Fortran dictionary types*/


static int gettype(int ttype,int size) {
/*************************************************************************/
/** Convert Fortran dictionary class and size into dwarf basic type     **/
/** ftnend should really pass in mode like we do for records etc above  **/
/** ttype is Fortran Dict type,size is size of basic type               **/
/*************************************************************************/

	int type;

	if (ttype==iinteger) {
		if (size==4)  type=tint;
		if (size==2)  type=tshort;
		if (size==1)  type=tschar;
	} else {
		if (ttype==real) {
			if (size==8)  type=tdouble; 
			else type=tfloat;
			;
		} else {
			if (ttype==character) {
				type=tchar;
			} else {
				if (ttype==complex) {
					if (size==4)  type=tcomplex; 
					else type=tdcomplex;
					;
				} else {
					if (ttype==logical) {
						if (size==4)  type=tbool;
						if (size==2)  type=tushort;	/*kluge for dwarf as it*/
						if (size==1)  type=tuchar;	/*only has Tbool*/
					}
				}
			}
		}
	}
	return type;

}	/* Get Type (mxdb)                                                         */




void entrypointinfo(int type,int bytesize) {
/*************************************************************************/
/** called from ftnend before eprocend an subsequent pproc calls to put      */
/** which generate TAGglobalsubroutine dies                                  */
/** if type is non-zero then info is function return type                    */
/** Sets up the return type of subroutine or function                        */
/*************************************************************************/

	int ttype;

	if (mon!=0) printf("Entry Point Info: type=%d, bytesize=%d\n",type,bytesize);	 

	if (type==0) {
		funcrettype=0;	/* subroutine                                                */
		funcretsize=0;
	} else {
		ttype=gettype(type&7,bytesize);
		funcrettype=ttype;	/* used by PPROC for function result                     */
		funcretsize=bytesize;
	}

}	/* Entry Point Info                                                        */



void GenerateEntryDIE(char * name,int labad,int codead) {
/*************************************************************************/
/* Generates a TAG_ENTRY_POINT die for given entry point                     */
/** Called from ftnend via mprocs output dbx entrys routine                  */
/** labad is the address of the label in the parent routine which is         */
/** jumped to AFTER the prolog ie the 1st exec stmt after the ENTRY stmt     */
/** codead is the entry prolog start address                                 */
/*************************************************************************/

	short int Short;
	int ttype,ptr,btype;
	struct debugf debug;

	/* Mxdb user defined AT's for Entry Points                                   */
	/* AT_low_pc is offset to 1st executable after ENTRY stmt                    */
	/* ATprologstart the start of an entry points prolog for breakpoint          */
	/* setting, ATprologend allows the debugger to detect if it is still         */
	/* in the ENTRY prolog, it holds the code offset to the instr after          */
	/* the parents code including all the prologs                                */

	static const int ATprologstart=((ATlouser+0x10)|FORMADDR);
	static const int ATprologend=((ATlouser+0x20)|FORMADDR);

	if (mon!=0) printf("Generate Entry DIE: name=%s,ladad=%d,codead=%x\n",
			name,labad,codead);	 

	memset(&debug,0,sizeof( struct debugf));	 
	ptr=0;
	debug.tag=TAGentrypoint;
	addsiblink(&debug,&ptr,curlexlev,debuglevel);
	while (name[strlen(name)-1]=='_') name[strlen(name)-1]=0;	/*strip trailing underscore for dwarf*/

	addname(&debug,&ptr,name);
	Short=ATlowpc;
	bytemove(2,(int)&Short,(int)&debug.data [ptr]);
	bytemove(4,(int)&labad,(int)&debug.data [ptr+2]);
	ptr+=6;
	Short=ATprologstart;
	bytemove(2,(int)&Short,(int)&debug.data [ptr]);
	bytemove(4,(int)&codead,(int)&debug.data [ptr+2]);
	ptr+=6;
	Short=ATprologend;
	bytemove(2,(int)&Short,(int)&debug.data [ptr]);
	bytemove(4,(int)&parenthighpc,(int)&debug.data [ptr+2]);
	ptr+=6;
	if (funcrettype!=0) {
		/* Function,gen return type                                                  */
		if (funcrettype==tchar) {
			btype=((debugptr+ptr)+4)+8;	/* TAGstring placed after TAGsub                */
			ttype=ATuserdeftype;
		} else {
			ttype=ATfundtype;
			btype=funcrettype;
		}
		addtype(&debug,&ptr,ttype,btype,0);
	}
	debug.len=ptr+6;
	writedbr(&debug);
	if (funcrettype==tchar) {
		if (funcretsize==0) 	/*char *(*) entry,use ATstringlen=0*/{
			btype=fortrantagstring(funcretsize,2);
		} else {
			btype=fortrantagstring(funcretsize,0);
		}
	}

	debuglevel++;	/*for any params*/

}	/*  output DBX ENTRYS                                                      */



void endentryparams() {
/*************************************************************************/
/** changes debuglevel back to subroutine child when entry params are        */
/** completed                                                                */
/*************************************************************************/

	struct debugf dbr;
	if (mon!=0) printf("End Entry Params\n");	 
	dbr.len=4;
	fillsiblink(curlexlev,debuglevel);
	writedbr(&dbr);
	debuglevel--;
	return ;

}	/* End Entry Params                                                        */



void psdbvar(int swad,int vtype,int area,int disp,int bytesize,int nels,int ndims,int boundsarray,int boundtypearray
) {
/*************************************************************************/
/**       Take details of variables and encode for SDB                  **/
/** boundsarray and boundtypearray describe array dimensions            **/
/** For each dimension  there is a pair of elements in these arrays     **/
/** In the bounds array, the first of each pair is the low bound, and   **/
/** the 2nd the high bound. The boundtype array describes where each    **/
/** dimension is to be found, again lowbound first,hibound second. The  **/
/** possible values in this array are 0 - bound is known at compile time**/
/** 2 - bound is a an offset on the stack as it is a parameter, 3 -     **/
/** parameter array is assumed size                                     **/
/** A swad of 0 indicates a function result type is being passed for    **/
/** the current function                                                **/
/**                                                                     **/
/** vtype - bits 0-7 encode basic type                                  **/
/**                8 parameter                                          **/
/**               28 volatile                                           **/
/**               29 Record                                             **/
/**               30 Record Parameter                                   **/
/**               31 Pointer Based Variable (-vtype)                    **/
/**                                                                     **/
/** Record variables come thru here. For them the vtype contains the    **/
/** number of the DIE which defines their structure type. This will have**/
/** been set up previously by Psdb Struct Type. This means that it can  **/
/** interfe with with 'normal' info which is contained in the ls byte of**/
/** vtype. To differentiate records we therefoe use bits 29 and 30.     **/
/** (of course if we ever have >2^29 dies this will fail!!              **/
/*************************************************************************/

static const int ptr=1;	/*sdb type modifiers*/


	/*vtype masks*/

static const int ischaracter=5;
static const int isparam=0x80;
static const int isvolatile=0x10000000;
static const int isrecord=0x20000000;
static const int isrecordparam=0x40000000;
static const int ispbv=0x80000000;

char *s;
short int Short;
int i,j,k,type,ttype,ref,dptr,aptr,tag,ftype,start,fspec,lenmark;
int ischar;	/* 1 if item is character                                        */
short int subscrlen;	/* length of array subscript info in dwarf              */
short int len,len1;
struct debugf dbr,adbr;
static struct debugf lastadbr;
static int lastdebugptr=0;
int *bounds,*boundtype;
int modifier,vtype2;


	if (faulty!=0)  return ;
	if (swad==0)  return ;


	s=((char *)swad);
	if (ndims>0) {
		bounds=((int *)(boundsarray));
		boundtype=((int *)(boundtypearray));
	}

	if (mon!=0) {
		printf("  PSDBVAR: %s type =%d ",s,vtype);
		if (vtype<0)  printf(" Pointer Based Variable");
		printf("\n area= %d disp=%d bytesiz=%d ",area,disp,bytesize);	 
		if (bytesize>0) {
			printf("/nels/ndims= %d %d\n",nels,ndims);
			if (ndims!=0) {
				printf("bounds:");
				for (i=1; i<=ndims*2; i++) {
					if ((i&1)!=0) {
						printf("%2d :%2d,",bounds [i],bounds [i+1]);
					}
				}
				printf("\n");
				printf("boundtype:");
				for (i=1; i<=ndims*2; i++) {
					if ((i&1)!=0) {
						printf(",%2d :%2d",boundtype [i],boundtype [i+1]);
					}
				}
				printf("\n");
			}
			printf("\n");
		} else {
			printf("\n");
		}

	}

	ref=0;	 
	dptr=0;	 
	memset(&dbr,0,sizeof( struct debugf));
	tag=TAGlocalvariable;

	if ((vtype&ispbv)!=0) {
		vtype=-vtype;	/*quick and dirty way of handling Pointers*/
		ref=ptr;	/*to at least get correct value*/
	}

	if ((vtype&(isrecord|isrecordparam))==0) {

		ftype=ATfundtype;
		ttype=vtype&7;
		type=gettype(ttype,bytesize);

		vtype2=vtype&0x00ffffff;	/* removing swopped bit */
		if (vtype2==ischaracter || vtype2==(isvolatile|ischaracter) || vtype2==(isparam|ischaracter)) {
			if (boundtype [2]==2) {
				/* char length not known yet (param)                                         */
				type=fortrantagstring(bounds [2],1);	/*plants AT_string_len                 */
			} else {
				type=fortrantagstring(bounds [2],0);	/* 1st dim upper bound is len          */
			}
			ftype=ATuserdeftype;
			ischar=1;
		} else {
			ischar=0;
		}

		if ((vtype&isparam)!=0) {
			ref=ptr;	/* item is a parameter*/

			tag=TAGformalparameter;
		}

		/*we have a record variable*/
	} else {

		ftype=ATuserdeftype;
		type=vtype&0x9FFFFFFF;	/* strip record info                                 */

		if ((vtype&isrecordparam)!=0) {
			ref=ptr;	/* item is a parameter */

			tag=TAGformalparameter;
		}

		ischar=0;
	}

	if ((nels>1)&&!(((ischar==1)&&(ndims==1)))) {
		/* array                                                                     */
		memset(&adbr,0,sizeof( struct debugf));	/* Clear record for array type info */
		adbr.tag=TAGarraytype;
		aptr=0;
		if (ndims>1) {
			/* Multi dimension needs ordering                                            */
			Short=ATordering;
			bytemove(2,(int)&Short,(int)&adbr.data [aptr])	/*ordering*/;
			if (sourcelang==fortran) {
				Short=ORDcolmajor;
			} else {
				Short=ORDrowmajor;
			}
			bytemove(2,(int)&Short,(int)&adbr.data [aptr+2]);
			aptr+=4;
		}
		i=aptr;
		Short=ATsubscrdata;
		bytemove(2,(int)&Short,(int)&adbr.data [aptr]);
		lenmark=aptr+2;
		aptr+=4;
		if (ischar==1) {
			start=3;	/* skip length dim for chars                                       */
		} else {
			start=1;
		}
		subscrlen=0;
		for (j=start; j<=((ndims*2)-1); j+=2) {
			if (boundtype [j]==0) {
				if (boundtype [j+1]==0)  fspec=FMTFTCC; 
				else fspec=FMTFTCX;
				;
			} else {
				if (boundtype [j+1]==0)  fspec=FMTFTXC; 
				else fspec=FMTFTXX;
				;
			}
			if (boundtype [j+1]==3) 	/*assummed sized dimension*/{
				fspec=FMTFTCX;	/*eg integer a(1,8,*)always last dim*/
			}
			adbr.data [aptr]=fspec;	/* Format Specifier                                 */
			Short=tint;	/* Bound are signed integers                                    */
			bytemove(2,(int)&Short,(int)&adbr.data [aptr+1]);
			if (fspec==FMTFTCC) {
				bytemove(8,(int)&bounds [j],(int)&adbr.data [aptr+3]);	/* two consts        */
				aptr+=11;
				subscrlen=11+subscrlen;
			} else if (fspec==FMTFTCX) {
				bytemove(4,(int)&bounds [j],(int)&adbr.data [aptr+3]);	/* one const         */
				k=(aptr+7)+2;
				if (boundtype [j+1]==3) 	/*assummed sized dimension*/{
					len=0;	/* mxdb expects 0 sized high bound loc                               */
				} else {
					generatestackloc(&adbr,&k,bounds [j+1],1);	/* one location descr            */
					adbr.data [k]=OPDEREF4;
					adbr.data [k+1]=OPDEREF4;
					k+=2;
					len=k-(aptr+9);
				}
				bytemove(2,(int)&len,(int)&adbr.data [aptr+7]);	/*loc block len             */
				subscrlen=len+subscrlen;
				aptr=k;
			} else if (fspec==FMTFTXC) {
				k=(aptr+3)+2;
				generatestackloc(&adbr,&k,bounds [j],1);	/* one location descr              */
				adbr.data [k]=OPDEREF4;
				adbr.data [k+1]=OPDEREF4;
				k+=2;
				len=k-(aptr+5);
				bytemove(2,(int)&len,(int)&adbr.data [aptr+3]);	/*block len                 */
				aptr=k;
				bytemove(4,(int)&bounds [j+1],(int)&adbr.data [aptr]);
				aptr+=4;
				subscrlen=(len+4)+subscrlen;
			} else if (fspec==FMTFTXX) {
				k=(aptr+3)+2;
				generatestackloc(&adbr,&k,bounds [j],1);	/* one location descr              */
				adbr.data [k]=OPDEREF4;
				adbr.data [k+1]=OPDEREF4;
				k+=2;
				len=k-(aptr+5);
				bytemove(2,(int)&len,(int)&adbr.data [aptr+3]);	/*block len                 */
				aptr=k;
				k+=2;	/* skip upper bound loc info len                                      */
				generatestackloc(&adbr,&k,bounds [j+1],1);	/* one location descr            */
				adbr.data [k]=OPDEREF4;
				adbr.data [k+1]=OPDEREF4;
				k+=2;
				len1=(k-aptr)-2;
				bytemove(2,(int)&len1,(int)&adbr.data [aptr]);	/*loc block len              */
				subscrlen=(len+len1)+subscrlen;
				aptr=k;
			};



		}
		bytemove(2,(int)&subscrlen,(int)&adbr.data [lenmark]);	/*len of subs inf    */
		adbr.data [aptr]=FTsignedinteger;
		aptr++;
#ifdef DGUXRE
		if ((vtype&0x01000000)!=0) modifier=MODEPCrep88k;
#else
		modifier=0;
#endif
		addtype(&adbr,&aptr,ftype,type,modifier);
		ftype=ATuserdeftype;	 
		type=debugptr;	/* redefine as ATuserdeftype           */
		Short=(aptr-i)-4;
		bytemove(2,(int)&Short,(int)&adbr.data [i+2]);
		adbr.len=aptr+12;
		k=0;
		j=(int)&adbr;
		for (i=0; i<=adbr.len-1; i++) {
			if ((*(unsigned char  *)(j+i))!=(*(unsigned char  *)((int)&lastadbr+i))) {
				k=1;
				break ;
			}
		}
		if ((lastdebugptr==0)||(k==1)||(ref==ptr)||(ftype==ATuserdeftype)) {
			/*this array type is not same as previous one*/
			lastdebugptr=debugptr;
			lastadbr=adbr;
			addsiblink(&adbr,&aptr,curlexlev,debuglevel);
			writedbr(&adbr);
		} else {
			type=lastdebugptr;
		}
	}

	dbr.tag=tag;	/* set up dwarf etry for current variable                      */
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	addname(&dbr,&dptr,s);
	if (sourcelang==fortran && (vtype&isvolatile)!=0) {
		modifier=MODvolatile;
	} else {
		modifier=0;
	}
	if (nels>1 && !(ischar==1 && ndims==1)) {
		addtype(&dbr,&dptr,ftype,type,0);
	} else {
#ifdef DGUXRE
		if ((vtype&0x01000000)!=0) modifier=MODEPCrep88k;
#endif
		addtype(&dbr,&dptr,ftype,type,modifier);

	}
	addloc(&dbr,&dptr,area,disp,ref,0);
	dbr.len=dptr+6;
	writedbr(&dbr);
}	/*PSDBVAR*/



/**                                                                          */
/* LAYOUT OF DIAGNOSTIC TABLES                                               */
	/* THIS INFO EX_EMAS AND VERY OLD */
/******* ** ********* ******                                                 */
/* THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF            */
/* USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE        */
/* DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.                */
/* A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY      */
/* FIRST WORD IN THE SST).                                                   */
/* THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL         */
/* ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT                   */
/* FORM OF THE TABLES:-                                                      */
/* WORD 0    =   LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)     */
/* WORD 1    =   (12 LANG DEPENDENT BITS)<<20 ! ENVIRONMENT                  */
/*               (TOP 2 BITS FOR ROUTINE TYPE.B'01'==SYSTEM ROUTINE)         */
/*               (NEXT BIT SET FOR EBCDIC CHARS&STRINGS(ALGOLE ONLY))        */
/* WORD 2    =   DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO                  */
/* WORD 3    =   ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE                */
/*               RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED             */
/* WORD 6    =  LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC              */
/* THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY  */
/* A WORD OF X'FFFFFFFF'                                                     */
/*  EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY            */
/* THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF                       */
/* BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT           */
/* BIT  2**19  =0 UNDER LNB =1 IN GLA                                        */
/* BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES                    */
/* THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST      */
/* BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS               */
/* A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN                      */
/* IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.                      */
/*!                                                                          */
/*! NOTE: ALL DISPLACEMENTS ARE BYTE WITHIN THE DIAGNOSTIC TABLES.           */
/*!                                                                          */


static void impsdb(int ptr) {
	int tstart,i;

	tstart=diagsrecs [ptr].doffset+areas [diags-lowestarea].base;

	if (mon!=0) {
		printf(" IMPSDB: %d\n",ptr);
		for (i=0; i<=28; i+=4) {
			printf("%x ",(*(int  *)(tstart+i))); 
		}
	}
	doimpsdbblock(tstart);
	ptr--;
	while (ptr>=0) {
		ptr-=impinnerblk(ptr);
	}
	lastdiagsrec=-1;
}



static int impinnerblk(int ptr) {
/*************************************************************************/
/**   Process an imp begin-end and any previous begins totally enclosed **/
/*************************************************************************/
	int tstart,firstline,lastline,dptr,codead,result;
	short int Short;
	struct debugf debug;
	struct rtheadf{
		short int rtline;
		short int linenopos;
		short int rtflags;
		short int env;
		short int display;
		short int rttype;
		union {
			short int idhead;
			char rtname[12];
		} u0;
	};

	struct rtheadf *rthead;
	tstart=diagsrecs [ptr].doffset+areas [diags-lowestarea].base;
	rthead=(struct rtheadf*)(tstart);
	result=1;
	if ((*(int  *)(tstart+20))==-1)  return 1;	/* Block with no locals skip it*/
	memset(&debug,0,sizeof( struct debugf));	 
	dptr=0;
	debug.tag=TAGlexicalblock;
	addsiblink(&debug,&dptr,curlexlev,debuglevel);
	Short=ATlowpc;
	bytemove(2,(int)&Short,(int)&debug.data [dptr]);
	firstline=rthead->rtline;
	codead=codeforline(firstline);
	fix(debugtabfix,debugtab,(debugptr+dptr)+8,code,codead);
	dptr+=6;
	Short=AThighpc;
	bytemove(2,(int)&Short,(int)&debug.data [dptr]);
	lastline=line;
	codead=codeforline(lastline);
	fix(debugtabfix,debugtab,(debugptr+dptr)+8,code,codead);
	dptr+=6;
	debug.len=dptr+6;
	writedbr(&debug);
	debuglevel++;
	doimpsdbblock(tstart);
	while ((ptr-result)>=0) {
		tstart=diagsrecs [ptr-result].doffset+areas [diags-lowestarea].base;
		rthead=(struct rtheadf*)(tstart);
		if (!((firstline<=rthead->rtline)&&(rthead->rtline<=lastline)))   break ;
		result+=impinnerblk(ptr-result);
	}
	memset(&debug,0,sizeof( struct debugf));
	debug.len=4;
	fillsiblink(curlexlev,debuglevel);
	writedbr(&debug);
	debuglevel--;
	return result;
}

struct varf{
	short int flags;
	short int disp;
	char vname[12];
};

struct rtheadf{
	short int rtline;
	short int linenopos;
	short int rtflags;
	short int env;
	short int display;
	short int rttype;
	union {
		short int idhead;
		char rtname[12];
	} u0;
};

static void pvar(int type,int prec,int nam,int arr,int area,int offset,char * lname) {
	struct debugf dbr;
	int dptr,elftype,k,j,ftype;
	short int Short;
	if (mon!=0) {
		printf("PVAR: %s %d %d %d %d\n",lname,type,prec,area,offset);	 
	}
	memset(&dbr,0,sizeof( struct debugf));	 
	dptr=0;	 
	elftype=-1;	 
	ftype=5;
	if (type==3)  elftype=0xD000;	/*record as integers all we can do */
	if (type==1)  elftype=(3*prec)-8;
	if (type==2)  elftype=9+prec;
	if (type==5)  elftype=0x12;
	if (elftype<=0)  return ;
	if (elftype==0x12) {
		/*                                                                           */
		/* define a sting type for the string                                        */
		/*                                                                           */
		dbr.tag=elftype;	/*user defined*/
		ftype=7;
		dptr=0;
		addsiblink(&dbr,&dptr,curlexlev,debuglevel);
		Short=0x193;
		k=dptr;
		addloc(&dbr,&dptr,area,offset,0,0);
		bytemove(2,(int)&Short,(int)&dbr.data [k])	/* over location with stringlen*/;
		Short=0xB6;	/* byte size entry follows*/
		bytemove(2,(int)&Short,(int)&dbr.data [dptr]);
		dptr+=2;	 
		j=1;
		bytemove(4,(int)&j,(int)&dbr.data [dptr])	/* string length is 1 byte*/;
		dptr+=4;
		elftype=debugptr;
		dbr.len=dptr+6;
		writedbr(&dbr);
		offset++;	 
		memset(&dbr,0,sizeof( struct debugf));	 
		dptr=0;
	}
	if (area==7)  dbr.tag=5; 
	else dbr.tag=12;
	;	/* elfspeak for local variable*/
	addsiblink(&dbr,&dptr,curlexlev,debuglevel);
	addname(&dbr,&dptr,lname);
	addtype(&dbr,&dptr,ftype,elftype,0)	/*fundamental type*/;
	if (arr!=0) {
		addloc(&dbr,&dptr,area,offset,0,0);
		Short=0x8500|FORMSTRING;
		bytemove(2,(int)&Short,(int)&dbr.data [dptr]);
		dptr+=3;
	} else addloc(&dbr,&dptr,area,offset,nam,0);
	;
	dbr.len=dptr+6;
	writedbr(&dbr);
}



static void pscalar(struct varf *var,struct rtheadf *rthead) {
/*************************************************************************/
/**       OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK.                **/
/**       A VARIABLE ENTRY IN THE TABLES IS:-                           **/
/**       FLAG<<20!VBREG<<18!DISP                                       **/
/**       WHERE:-                                                       **/
/**         VBREG IS VARIABLE'S BASE REGISTER, DISP IS IT'S OFFSET      **/
/**         AND FLAGS=NAM<<6!PREC<<3!TYPE                               **/
/*************************************************************************/
	int vaddr;
	int i,k,area,type,prec,arr,nam;
	char lname [12] ;
	i=var->flags;
	/*      printstring(" var_flags = "); !phex(var_flags); !newline             */
	k=(unsigned)i>>4;
	type=k&7;
	prec=((unsigned)k>>4)&7;
	arr=((unsigned)k>>8)&3;
	nam=((unsigned)k>>10)&1;
	imp_strjam(lname,var->vname,11);
	if ((i&4)==0) 	/* For non Owns */{
		if (var->disp<rthead->display) {
			vaddr=var->disp; 
			area=7;
		} else {
			area=0;	 
			vaddr=rthead->display-var->disp;
			/* diag tables point at rhs of var - */
			/* we need the LHS so adjust by var size */
			if ((nam!=0)||(arr!=0))  vaddr-=4; 
			else {
				if ((1<=type)&&(type<=2))  vaddr-=(1<<prec)/8;
			}
		}
	} else {
		vaddr=var->disp; 
		area=2;
	};
	;
	pvar(type,prec,nam,arr,area,vaddr,lname);
	printf("\n");
}



static void plocals(int adata,struct rtheadf *rthead) {
/*************************************************************************/
/**      ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES**/
/*************************************************************************/
	struct varf *var;
	while ((*(int  *)(adata))>0) {
		var=(struct varf*)(adata);
		pscalar(var,rthead);
		adata+=(8+strlen(var->vname))&0xFFFFFFFC;
	}
}



static void doimpsdbblock(int tstart) {
/*************************************************************************/
/**       THE DIAGNOSTIC ROUTINE FOR IMP                                **/
/*************************************************************************/
struct rtheadf *rthead;
int rlen;
	rthead=(struct rtheadf*)(tstart);
	if (rthead->u0.idhead==0)  rlen=20; 
	else rlen=(20+strlen(rthead->u0.rtname))&0xFFFFFFFC;
	;
	plocals(tstart+rlen,rthead);
	return ;
}

/*DwarfProducer#FrontEnd*/

#endif;


static char * checkblankcommon(char * s) {
/*************************************************************************/
/** Special Action for Blank Common Names which on 88k are dependent    **/
/** on the -us flag.                                                    **/
/*************************************************************************/
static char namecopy[256];
#ifdef DGUXRE
static char work [256] ;
#endif

	strcpy(namecopy,s);

#if(target==elf88k) 
	if (nusoption==0) 	/*-us*/{
		if ((strcmp(namecopy,"_BLNK__")==0) ||
			(strcmp(namecopy,"f#blcm")==0))  {
			strcpy(namecopy,symbolprefix);
			strcat(namecopy,"_BLNK__"); 
		} else {
			strcpy(namecopy,symbolprefix);
			strcat(namecopy,s); strcat(namecopy,"_");
		}
	} else {		/*-nus default*/
		if ((strcmp(namecopy,"_BLNK__")==0) ||
			(strcmp(namecopy,"f#blcm")==0))  {
			strcpy(namecopy,symbolprefix);
			strcat(namecopy,"BLNK__"); 
		} else {
			strcpy(namecopy,symbolprefix);
			 strcat(namecopy,s);
		}
	}

#else
	if ((strcmp(namecopy,"F#BLCM")==0) ||
		(strcmp(namecopy,"f#blcm")==0) ||
		(strcmp(namecopy,"BLNK__")==0) ||
		(strcmp(namecopy,"_BLNK__")==0)) {
		strcpy(namecopy,symbolprefix); strcat(namecopy,"BLNK__");
	} else {
#ifdef DGUXRE
		if (ecsnameprefix==NULL) work[0]=0; else strcpy(work,ecsnameprefix);
		strcat(work,namecopy);
		if (commonus!=0) strcat(work,"_");
		strcpy(namecopy,work);
#else
		if (sourcelang==fortran)  strcat(namecopy,commonnamesuffix);
#endif
	}

#endif;
	return namecopy;

}	/* Check Blank Common  */




int pcommon(char * name) {
/*************************************************************************/
/* Define a common area now superceeded by pcommon2                      */
/*************************************************************************/
char namecopy [256] ;

	if (faulty!=0)  return 0;

	if (mon!=0) printf("  PCommon - %s\n",name); 

	strcpy(namecopy,checkblankcommon(name));

	toparea++;
	if (toparea>maxarea)  expandarea(0);
	psymbol(namecopy,toparea,0,STT_OBJECT,STB_GLOBAL,SHN_COMMON)	/*put area table index in _value pro tem*/;
	areas [toparea-lowestarea].sym=nextsym+20;
	areas [toparea-lowestarea].align=commonalign;	/*default  */

	return nextsym+20;

}	/*PCommon*/




void pendcommon(int id,int length) {
/*************************************************************************/
/* End of common area with 'standard' properties. Pendcommon2 is better  */
/*************************************************************************/

	if (faulty!=0)  return ;

	if (mon!=0) printf("  PEndCommon %d  length = %d\n",id,length);

	areas [syms [id-20].st_value-lowestarea].length=length;
	/* _value field has index to area table      */
	syms [id-20].st_size=length;

}	/*PEndCommon*/



int pcommon2(int visibility,char * name) {
/*************************************************************************/
/** Commons are global unless visibility # 0                            **/
/*************************************************************************/
	char namecopy [256] ;
	int symtype;

	if (faulty!=0)  return 0;

	if (mon!=0) printf("  PCommon2 - %s Visibility =%d\n",name,visibility);

	strcpy(namecopy,checkblankcommon(name));
	toparea++;
	if (toparea>maxarea)  expandarea(0);
	symtype=STB_GLOBAL;
	if (visibility!=0)  symtype=STB_LOCAL;
	psymbol(namecopy,toparea,0,STT_OBJECT,symtype,SHN_COMMON)	/*put area table index in _value pro tem*/;
	areas [toparea-lowestarea].sym=nextsym+20;
	areas [toparea-lowestarea].align=commonalign;	/*default */

	return nextsym+20;

}	/*PCommon*/



void pendcommon2(int id,int length,int props,int align) {
/*************************************************************************/
/* End of common area so finalise size & properties                      */
/*************************************************************************/
int ix;

	if (faulty!=0)  return ;

	if (mon!=0) printf("  PEndCommon2 %d  length = %d Align to%d\n",id,length,align);	 
        /* _value field has index to area table      */
	ix=syms [id-20].st_value;
	areas [ix-lowestarea].length=length;
	areas [ix-lowestarea].align=align;
	syms [id-20].st_size=length;

}	/*PEndCommon*/



void paligncommon(int id,int align) {
/*************************************************************************/
/**      for C++ the default arrangemets for Fortran are not good       **/
/**    enough. C++ must be able to define common alignments             **/
/*************************************************************************/
	if (!(((1<<align)|0x10116)!=0))  puterror("Bad alignment");	/* 1,2,4,8 or 16 only*/
	areas [syms [id-20].st_value-lowestarea].align=align;
}



void pfaulty() {
/*************************************************************************/
/* Code generator has encountered a user error. Code requests should no  */
/* longer be checked and minimum work done in PUT                        */
/*************************************************************************/
	if (mon!=0)  printf("Pfaulty\n");
	faulty=1;
}	/*Pfaulty*/



void psetfiles(char * srcname,char * objfilename,int syntaxcheck) {
/*******************************************************************************/
/*  Psetfiles - Pass object file name in to be opened                           */
/*******************************************************************************/
int i,j,tryagain;
char s [256] ;

	if (mon!=0) printf("Psetfiles : %s:%s\n",srcname,objfilename);

	imp_strjam(s,srcname,32);
	if (strcmp(objfilename,"include")==0) 	/*remember the file name for sdb*/{

	} else {

		strcpy(srcfile,s);
		imp_strjam(objname,objfilename,32);
		strcpy(objectname,objfilename);
		if (syntaxcheck==1)  return ;
		objid=creat((int)&objectname [0],mode);
		if (objid==-1) {
			/* maybe a path name with a component missing  */
			i=strlen(objfilename)-1;
			tryagain=0;
			while ((i>=0)) {
				if (objectname [i]=='/') {
					/* the rightmost '/'           */
					/* now test each component from left for existence */
					/* and create if necessary           */
					if (objectname [0]=='/')  j=1; 
					else j=0;
					;
					while ((j<=i)) {
						if (objectname [j]!='/')  j++; 
						else {
							objectname [j]=0;	/* terminator for a moment       */
							if (access((int)&objectname [0],0)!=0) {
								/* this one does not exist */
								if (mkdir((int)&objectname [0],dirmode)!=0) {
/* code folded from here */
	/* create failed  */
	tryagain=0;
	break ;
/* unfolding */
								}
								/* so created it OK. continue                           
								                        */
								tryagain++;
								if (mon!=0) {
/* code folded from here */
	printf("Directory created - %s\n",objectname);
/* unfolding */
								}
							}
							objectname [j]='/';	/* put it back */
							j++;
							continue ;
						}
					}
					break ;
				} else i--;
				;
			}
			if (tryagain!=0)  objid=creat((int)&objectname [0],mode);
		}
		if (objid==-1)  puterror(" Failed to creat/open object ");
	}

}	/*Psetfiles*/
int psetfiles2(char * srcname,char * objfilename,int syntaxcheck) {
/*******************************************************************************/
/*  Psetfiles - Pass object file name in to be opened                           */
/*******************************************************************************/
int i,j,tryagain;
char s [256] ;

        if (mon!=0) printf("Psetfiles2 : %s:%s\n",srcname,objfilename);

        imp_strjam(s,srcname,32);
        if (strcmp(objfilename,"include")==0)   /*remember the file name for sdb*/{
		return 0;

        } else {

                strcpy(srcfile,s);
                imp_strjam(objname,objfilename,32);
                strcpy(objectname,objfilename);
                if (syntaxcheck==1)  return 0;
                objid=creat((int)&objectname [0],mode);
                if (objid==-1) {
                        /* maybe a path name with a component missing  */
                        i=strlen(objfilename)-1;
                        tryagain=0;
                        while ((i>=0)) {
                                if (objectname [i]=='/') {
                                        /* the rightmost '/'           */
                                        /* now test each component from left for existence */
                                        /* and create if necessary           */
                                        if (objectname [0]=='/')  j=1; 
                                        else j=0;
                                        ;
                                        while ((j<=i)) {
                                                if (objectname [j]!='/')  j++; 
                                                else {
                                                        objectname [j]=0;       /* terminator for a moment       */
                                                        if (access((int)&objectname [0],0)!=0) {
                                                                /* this one does not exist */
                                                                if (mkdir((int)&objectname [0],dirmode)!=0) {
/* code folded from here */
        /* create failed  */
        tryagain=0;
        break ;
/* unfolding */
                                                                }
                                                                /* so created it OK. continue                           
                                                                                        */
                                                                tryagain++;
                                                                if (mon!=0) {
/* code folded from here */
        printf("Directory created - %s\n",objectname);
/* unfolding */
                                                                }
                                                        }
                                                        objectname [j]='/';     /* put it back */
                                                        j++;
                                                        continue ;
                                                }
                                        }
                                        break ;
                                } else i--;
                                ;
                        }
                        if (tryagain!=0)  objid=creat((int)&objectname [0],mode);
                }
        }
	return objid;

}       /*Psetfiles2*/






void removeobjectfile() {
/********************************************************************************/
/** RemoveObjectFile put in by tkr for PASCAL                                   */
/********************************************************************************/
	unlink((int)&objectname [0]);
}	/*RemoveObjectFile*/

/*******************************************************************************/
/*  Psetoptions - Perform Options Processing                                 */
/*******************************************************************************/




void psetoptions(int options) {
/***************************************************************************/
/** called by compilation outer control routine                           **/
/** options have bit value significance                                   **/
/**   x'00000001'  enable code memory tracing                             **/
/**   x'00000002'  generate assembly listing for each frag                **/
/**   x'00000004'  enable rescheduler tracing                             **/
/**   x'00010000'  profiling                                              **/
/**   x'00020000'  enable DBX/SDB information generation                  **/
/**   x'00040000'  minimum diags preparation                              **/
/**   x'00080000'  dynamic line number updating                           **/
/**   x'00100000'  prepare static line no table (later)                   **/
/**   x'00200000'  support overflow checking                              **/
/**   x'00400000'  allow compiler allocation of registers (FORTRAN only)  **/
/**   x'00800000'  set FPU traps if compiling a main program              **/
/**   x'01000000'  enable instruction scheduling                          **/
/**   x'02000000'  prepare for FORTRAN parameter checking                 **/
/**   x'04000000'  generate assembly listing without addresses            **/
/**   x'08000000'  Now only used for PPC private options                  **/
/**   x'10000000'  Now only used for PPC private options                  **/
/**   x'20000000'  line profiling                                         **/
/***************************************************************************/
	int i;
	i=options;	/*!comreg(26)*/
	if ((i&0x80)!=0)  malmon=1;
	if ((i&0x10)!=0)  filemon=1;
	if ((options&0x20000)!=0)  sdb=1;
	if ((options&0x20000000)!=0)  casesense=1;

}	/*of Psetoptions    */



void pterminate(int adareasizes) {
/*************************************************************************/
/**    CODE GENERATOR CLOSES WITH THIS CALL TO ESTABLISH AREA LENGTHS   **/
/*************************************************************************/
	int i,ad,l;
	struct debugf dbr;
	if (faulty!=0) {
		removeobjectfile(); 
		return ;
	}
	if (endpending==1)  completeend();

	if (mon!=0) {
		printf("\n       Arealengths from Pterminate are:\n");
		for (i=0; i<=9; i++) {
			printf("%2d",(*(int  *)(adareasizes+(i*4))));
		}
		printf("\n");
	}

	ad=adareasizes;
	for (i=1; i<=10; i++) {
		l=(*(int  *)(ad));

		ad+=4;
		l=(l+7)&(-8);	/* Keep areas tidy on 8 byte boundaries */
		if ((trusted==0)&&(i!=1)&&(l==0)&&(areas [i-lowestarea].max!=0))
			puterror(imp_concat(imp_concat("Pterminate - Area ",itos(i))," has incorrect length "));
		areas [i-lowestarea].length=l;
	}

	/* if sdb is on then complete some debug information here                    */

	if (sdb!=0) {
#if (DwarfProducer==PUT)
		if (debugptr>0) {
			if ((sourcelang==imp)&&(lastdiagsrec>=0)) {/* add imp externals*/
				doimpsdbblock(areas [diags-lowestarea].base+diagsrecs [lastdiagsrec].doffset);
			}
			fillsiblink(curlexlev,debuglevel);
			dbr.len=4+((debugptr+3)&(-4));	 
			writedbr(&dbr);	/*dummy record to terminate */
			dbr.len=((debugptr+3)&(-4))-debugptr;
			writedbr(&dbr); /* align end of debug section */
			l=areas [1-lowestarea].length;	/* code size      */
			fix(debugtabfix,debugtab,14,code,l);	/* Fill high pC for file     */
			fix(debugtabfix,debugtab,20,debugtab,debugptr);	/*sibling file = next file  */
		}
#endif

		/* if an empty file is compiled with -g there is no line no table but there  */
		/* will still be a relocation from the dwarf to it. Must ensure an empty     */
		/* table is output                                                           */

		if (linehdroffset<0)  setlineheader(0);
		while (linehdroffset>=0) {
			i=ppopfile();
		}
	}
}	/*Pterminate*/


static void pattern(int fileid,int ncopies,int l,int bad) {
/***************************************************************/
/* This routine is for the efficient patterning of a data area */
/* eg. If the area is to be filled with the unassigned byte    */
/*     or a data i*n statement is taking effect                */
/***************************************************************/
unsigned char b [511+1];
	int i,left,ad,blen,bufsize;

	ad=(int)&b [0];
	/* if l > 512 ? */	/* First fill the buffer with the pattern */
	if (l==1) 	/* single byte pattern */{
		fill(512,ad,bad)	/* bad contains filler byte if  l=1 */;
		bufsize=512;
		/* multiple byte pattern */
	} else {
		bufsize=0;
		for (i=1; i<=ncopies; i++) {
			bytemove(l,bad,ad+bufsize);
			bufsize+=l;
			if ((bufsize+l)>511)   break ;
		}
	}
	left=ncopies*l;

	/* And then write it out */

	do {
		if (left>bufsize)  blen=bufsize; 
		else blen=left;
		left-=blen;
		writetofile(fileid,ad,blen,"");
	} while (!(left<=0)) ;

}	/*PATTERN*/

static void addshentry(Elf32_Shdr *shdrs,int sect) {
/*************************************************************************/
/** Takes the next available section table entry and sets               **/
/** it up for the nominated section id                                  **/
/*************************************************************************/
	static const int sectiondata [(3*maxsect)+2+1] = {
/* section id             type     addralign<<24!entsize<<16!flags  Related sect */
/* Necessary empty section */	0,		0,			0,
/* Reginfosect = 1*/	SHT_REGINFO,	((4<<24)|(24<<16))|SHF_ALLOC,	0,
/*TEXTsect     = 2*/	SHT_PROGBITS,	((16<<24)|SHF_ALLOC)|SHF_EXECINSTR,0,
/*DATAsect     = 3*/	SHT_PROGBITS,	((16<<24)|SHF_ALLOC)|SHF_WRITE,	0,
/*datagptabsect= 4*/	SHT_GPTAB,		8<<16,			0,
/*BSSsect      = 5*/	SHT_NOBITS,	((16<<24)|SHF_ALLOC)|SHF_WRITE,	0,
/*bssgptabsect = 6*/	SHT_GPTAB,		8<<16,			0,
/*symsect      = 7*/	SHT_SYMTAB,	symboltableentrysize<<16,	0,
/*TEXTrelsect  = 8*/	reltype,	sizeof(relaf)<<16,		textsect,
/*DATArelsect  = 9*/	reltype,		sizeof(relaf)<<16, 	datasect,
/*mdebugsect   =10*/	0x70000005,			0,		0,
/*stringsect   =11*/	SHT_STRTAB,			0,		0,
/*shstringsect =12*/	SHT_STRTAB,			0,		0,
/*RODATAsect   =13*/	SHT_PROGBITS,	(16<<24)|SHF_ALLOC,		0,
/*linenosect   =14*/	SHT_PROGBITS,			0,		0,
/*linerelsect  =15*/	reltype,		sizeof(relaf)<<16,	linenosect,
/*debugsect    =16*/	SHT_PROGBITS,			0,		0,
/*debugrelsect =17*/	reltype,	sizeof(relaf)<<16,		debugsect,
/*INITsect     =18*/	SHT_PROGBITS,	((4<<24)|SHF_ALLOC)|SHF_EXECINSTR,0,
/*initrelsect  =19*/	reltype,		sizeof(relaf)<<16,	initsect,
/*FINIsect     =20*/	SHT_PROGBITS,	((4<<24)|SHF_ALLOC)|SHF_EXECINSTR,0,
/*finirelsect  =21*/	reltype,	sizeof(relaf)<<16,		finisect,
/*TDESCsect    =22*/	tdesctype,		tdescprops,		0,
/*Tdescrelsect =23*/	reltype,		sizeof(relaf)<<16,	tdescsect};

Elf32_Shdr *sh;
char name [256] ;
int i;

	sh=&shdrs [nsects];	/* Next free */
	memset(sh,0,sizeof( Elf32_Shdr));
	sectionentryno [sect]=nsects;	/* remember mapping */
	nsects++;
	strcpy(name,sectnametext [sect]);
	placeinshdict(name,&sh->sh_name);
	sh->sh_offset=sectionposition [sect];
	sh->sh_size=sectionsizes [sect];

	sh->sh_type=sectiondata [3*sect];
	i=sectiondata [(3*sect)+1];
	sh->sh_addralign=(unsigned)i>>24;
	sh->sh_entsize=((unsigned)i>>16)&255;
	sh->sh_flags=i&0xFFFF;
	if (sh->sh_type==SHT_SYMTAB) {
		sh->sh_info=maxloc+1;	/* first global */
		sh->sh_link=nsects;	/* string table must be updated */
	}

	if (sh->sh_type==reltype) {
		sh->sh_link=sectionentryno [symsect];
		sh->sh_info=sectionentryno [sectiondata [(3*sect)+2]];
	}
	/*                                                                           */
	/* Mips gptab sections have additional links Sh_info of gptab has the        */
	/* data section no. The datsection_info field has the gptab section          */
	/* THis can be done provided the sections arrive in order                    */
	/*                                                                           */

#if(target==elfmips) 
	if (sh->sh_type==SHT_GPTAB)  sh->sh_info=nsects-1;	/* preceding section is referenced */
	if ((sh->sh_flags&SHF_WRITE)!=0)  sh->sh_link=nsects;

#endif;
}

void pgenerateobject(char * objfilename) {
/*************************************************************************/
/**     PGenerateObject                                                 **/
/**     FINAL PHASE OF COMPILATION IS CREATE OBJECT FILE                **/
/*************************************************************************/

	static const int fhdrsize=(((sizeof(Elf32_Ehdr)+(sizeof(Elf32_Phdr)*prghdrentries))+15)&(-16));	/* size of file header          */


	int textlen,rodatalen,datalen,ad,ndrels;
	int filler,i,j,l;
	int bsslen,linkdisp,areabase,kad;
	int *areastart;
	struct rdfm *rd;
	/* all these disp's are from start of file */
	int textptr;	/* disp in bytes to code */
	int rodataptr,dataptr	/* disp in bytes to data areas*/;
	int textrelptr;	/* disp in bytes to relocs for code area */
	Elf32_Ehdr hdr;
	Elf32_Shdr shdrs [maxsect+1];
	static const unsigned char order [10-1] = {
		2,8,10,
		7,4,5,6,3,
		9	};

	l=getspace((4*toparea)+4);
	areastart=((int *)(l));
	memset(&shdrs [0],0,sizeof( Elf32_Shdr));
	ndrels=nrels [gla]+nrels [iotab];

	if (!(faulty==0))  return ;

	if (malmon!=0)  printf("\nmax data before object generation = %d\n",maxdata);

	for (i=1; i<=toparea; i++)  areastart [i]=0;



	/*---- WORK OUT SIZE OF MAJOR PARTS OF OBJECT FILE ---*/
	if (areas [code-lowestarea].length==0) {
		pcword(0,0); 
		areas [code-lowestarea].length=4;
	}


	textlen=areas [code-lowestarea].length;

	bsslen=areas [zgst-lowestarea].length;	/* Only the Zero-Gst area goes directly */
	/* into BSS. The linker will look after */
	/* the uninit. commons which also       */
	/* belong in BSS.                       */

	datalen=0;	 
	rodatalen=0;
	for (i=1; i<=toparea; i++) 	/* If it is not in   */{
		if ((i==zgst)||(i==code))   continue ;	/* code or Bss       */
		if ((i>setareas)&&(areas [i-lowestarea].max==0))   continue ;	/* or uninit. common */
		if ((i<setareas)&&(epcareatosectndx [i]==rodatasect)) {
			rodatalen+=areas [i-lowestarea].length;  
			continue ;
		}
		datalen+=areas [i-lowestarea].length;	/* then its in .Data */
	}


	/*----- WORK OUT WHERE MAJOR PARTS OF OBJECT FILE ARE TO START------*/

	/* variables ending in 'ptr' are file pointers  */
	/* ie. bytes from start of file                 */

	textptr=((fhdrsize+regsectsize)+15)&(-16);	/*gm*/
	rodataptr=((textptr+textlen)+15)&(-16);
	dataptr=((rodataptr+rodatalen)+15)&(-16);
	textrelptr=dataptr+datalen;


	/*<--------------------------------------------------------------------->*/
	/*<----------- Start filling in front of Object file now --------------->*/
	/*<--------------------------------------------------------------------->*/



	/*----------- FILL IN THE OBJECT FILE HEADER ---------------------*/

	memset(&hdr,0,sizeof( Elf32_Ehdr));
	hdr.e_ident[EI_MAG0]=ELFMAG0;
	hdr.e_ident[EI_MAG1]=ELFMAG1;
	hdr.e_ident[EI_MAG2]=ELFMAG2;
	hdr.e_ident[EI_MAG3]=ELFMAG3;
	hdr.e_ident[EI_CLASS]=ELFCLASS32;
	hdr.e_ident[EI_VERSION]=elfversion;
	hdr.e_ident[EI_DATA]=targetdata;	/* IBM or VAX type bytes                               */
	hdr.e_type=elftyperel;	/* Relocate object file                                */
	hdr.e_machine=target;
	hdr.e_version=elfversion;
	hdr.e_ehsize=sizeof(Elf32_Ehdr);
	hdr.e_shentsize=sizeof( Elf32_Shdr);
	hdr.e_shnum=maxsect+1;
	hdr.e_shstrndx=shstringsect;

#if(prghdrentries>0) 
	hdr.e_phoff=sizeof(Elf32_Ehdr)
#endif;	/*gm*/
	    hdr.e_phentsize=sizeof(Elf32_Phdr);
	hdr.e_phnum=prghdrentries;
	if ((target==elf88k)&&(targetvariant==4)) {
		hdr.e_flags=4;	/* Uses 110 features */
	}

#if(target==elfmips) 
	hdr.e_flags=1;	/* No reorder */
	if (Pic==largemodel)  hdr.e_flags=hdr.e_flags|2;
	if (Pic==smallmodel)  hedr.e_flags=hedr.e_flags|4;

#endif;
	hdr.e_flags=hdr.e_flags|privatehdrflags;
	if (mainentrypoint!=0) {
		hdr.e_entry=syms [mainentrypoint].st_value;

#if(target==elfmips) 
		hdr.e_entry=0x10000000
#endif;	/*Hdr_entry+*/
	}

	/* Areas are to be assembled in DATA in the following order */

	/*  First areas being relocated:     GLA      */
	/*                                   IOTAB    */
	/*  Next areas initialised, but               */
	/*    not relocated.                 CNST     */
	/*                                   SCALAR   */
	/*                                   SST      */
	/*                                   GST      */
	/*                                   DIAGS    */
	/*                      INITIALISED  COMMONS  */




	/* Work out start position of ERCC sub-areas in 'DATA' and 'RODATA' */

	areastart [sst]=areas [cnst-lowestarea].length;
	areastart [diags]=areastart [sst]+areas [sst-lowestarea].length;

	ad=0;	/*DataStart*/
	for (j=2; j<=toparea; j++) {
		if (j<11)  i=order [j-2]; 
		else i=j;	/*strict order on data areas */
		l=areas [i-lowestarea].length;
		if ((l==0)||((i==zgst)&&(bsslen!=0)))   continue ;
		if ((i<setareas)&&(epcareatosectndx [i]!=datasect))   continue ;

		if (i>setareas) 	/*  common */{
			if (impp!=0)   break ;
			if (areas [i-lowestarea].max==0)   continue ;	/* uninitialised cmn */
			i=areas [i-lowestarea].sym-20;
			syms [i].st_shndx=gla;	/*gm*/
			/* Gla instead of common once initialised        */
		} else {
			areastart [i]=ad;	/*- datastart*/
			/* remember for sdb records */
			i=areas [i-lowestarea].sym;
		}
		syms [i].st_value=ad;	/*- DataStart*/

		ad+=l;
	}



	/*-----------------------------------------------------------*/
	/*------------- SORT OUT RELOCATION  ------------------------*/
	/*-----------------------------------------------------------*/

	/* Relocs.  pass a symbol table index in their rel. field */


	{
		relaf rrec;
		struct rfm *r;
		Elf32_Sym *sym;
		int i,j,k,vad,type,tgtsym,curfileptr;
		int hostdisp,orgcontents;
		int relarea,tgtdisp,firstglob,got16low16sym;
		int *symindex,*midindex;
		Elf32_Sym tempsym;
		int done;
		Elf32_Sym *s;
		int area,l;
		char name [33] ;

		/*                                                                           */
		/* map the shuffle arrays                                                    */
		/*                                                                           */
		l=getspace((4*nextsym)+8);
		symindex=((int *)(l));
		l=getspace((4*nextsym)+8);
		midindex=((int *)(l));
		/*                                                                           */
		/* Shuffle the symbol table so globals areat the back. The early items are   */
		/* all local anyway. Symindex indirects so that old references can find      */
		/*their shuffled entry                                                       */
		/*                                                                           */
		got16low16sym=-1;	/* no got16low16pair seen yet */
		for (i=0; i<=nextsym; i++) {
			symindex [i]=i; 
			midindex [i]=i;
		}
		j=stfixedentries;
		/*                                                                           */
		if (mon!=0) {
			printf("Before ordering\n");
			for (i=j; i<=nextsym; i++) {
				printf("%5d ",i);	 
				outsymbol(i);	 
				printf("\n");
			}
		}
		firstglob=nextsym+1;	/*in case there areno globals                          */
		for (i=j; i<=nextsym; i++) {
			if (ELF32_ST_BIND(syms [i].st_info)==STB_GLOBAL) {
				firstglob=i;  
				break ;
			}
		}
		for (i=firstglob+1; i<=nextsym; i++) {
			if (ELF32_ST_BIND(syms [i].st_info)==STB_LOCAL) {
				/*Local out of posn                                                          */
				tempsym=syms [i];
				syms [i]=syms [firstglob];
				syms [firstglob]=tempsym;
				k=midindex [i];
				midindex [i]=midindex [firstglob];
				midindex [firstglob]=k;
				k=symindex [midindex [i]];
				symindex [midindex [i]]=symindex [midindex [firstglob]];
				symindex [midindex [firstglob]]=k;
				firstglob++;
			}
		}
		maxloc=firstglob-1;
		if (mon!=0) {
			printf("after ordering\n");
			for (i=j; i<=nextsym; i++) {
				printf("%3d %5d ",i,symindex [i]);	 
				outsymbol(symindex [i]);	 
				printf("\n");
			}
		}
		fix(254,2,2,2,2)	/* Put an end marker on the relocations */;
		/*   Rels  == Startrels once compiler generates ordered relocations          */
		/*                until then this statement must inside cycle below          */
		rels=startrels;	/* Relocations have to be in order     */
		i=1;
		do 	/* Through list of Relocation requests */{
			r=&rels [i-1];
			i++;
			type=(unsigned)r->hostdisp>>24;
			hostdisp=r->hostdisp&0xFFFFFF;
			tgtsym=r->tgtarea;
			tgtdisp=r->tgtdisp;
			if (type==254)   break ;	/* end of relocs */
			if (type==255) {
				rels=(struct rfm*)((struct rfm *)(tgtdisp)); 
				i=1;  
				continue ;
			}	/* next block */

			if (tgtsym>20) 	/* Proc, data ref or common may be shuffled */{

				tgtsym=symindex [tgtsym-20];
				sym=&syms [tgtsym];
				if ((sym->st_shndx&0xFFFF)==SHN_COMMON) {
					/* Un-initialised Common */
					/*                 tgtdisp=tgtdisp+sym_value                                 */	/*
					    Reloc will be common length */
					/* in front for unknown reason */
					/* so compensate. */
					/* Defined data probably Initialised Common */
				} else if (((sym->st_info&15)==STT_OBJECT)&&(sym->st_shndx!=SHN_UNDEF)) {
					/*               tgtdisp=tgtdisp+sym_value                                   */
				};

				/*                                                                           */
				/* Look for relative calls to local procedures. These can be resolved here   */
				/* and the relocation deleted. The actual patching of the instruction would  */
				/* seem to need target dependent code in all case. There could also be       */
				/* alignment problems on some architectures.                                 */
				/* NB MIPS calls are absolute not relative so skip this section              */
				/*                                                                           */

#if(target!=elfmips) 
				if ((sym->st_info==(ELF32_ST_INFO(STB_LOCAL,STT_FUNC)))&&(r->hostarea==code)&&(type==fixuprel [3])) {
					done=0;
					k=(sym->st_value+tgtdisp)-hostdisp;
					j=areas [code-lowestarea].base+hostdisp;

#if(target==elf88k) 
					{
						(*(int  *)(j))=((*(int  *)(j))&0xFC000000)|((unsigned)k>>2); 
						done=1;
					}
#endif;

#if(target==elfsparc) 
					{
						(*(int  *)(j))=((*(int  *)(j))&0xC0000000)|((unsigned)k>>2); 
						done=1;
					}
#endif;

#if(target==elf386) 
					{
						(*(int  *)(j))=((*(int  *)(j))&0x80000000)|k; 
						done=1;
					}
#endif;

#if(target==elfppc) 
					{
						(*(int  *)(j))=((*(int  *)(j))&0xFC000003)|(k&0x3FFFFFC); 
						done=1;
					}
#endif;
					if (done==0)  puterror("Code missing for target");
					nrels [code]=nrels [code]-1;	  
					continue ;
				}

#endif;

#if(target==elfmips) 
				if ((sym->st_info==(ELF32_ST_INFO(STB_LOCAL,STT_FUNC)))&&(r->hostarea==code)&&((type==R_MIPS_GOT16)||((type==R_MIPS_LO)16)&&(tgtsym
				    ==got16low16sym)))) {
					if (type==R_MIPS_GOT16)  got16low16sym=tgtsym; 
					else got16low16sym=-1;
					;
					tgtdisp=sym->st_value;	/* Offset from code start */
					tgtsym=epcareatoelfsym [code];
				}
				/*                                                                           */
				/* This is a hairy optimisation for mips internal calls. jals can be changed */
				/* into bgezal which are relative but have limited reach. One can also arrange*/
				/* to enter after $gp set up for local calls but that means checking there is a $gp*/
				/* set up sequence. This section is dependemt on the code generator producing the*/
				/* expected (abi) sequence but is fail safe if the sequence changes          */
				/*                                                                           */
				if (((sym->st_info==(ELF32_ST_INFO(STB_LOCAL,STT_FUNC)))||((sym->st_info==ELF32_ST_BIND(STB_GLOBAL,STT_FUNC))&&(sym->st_value>0)))&&(r->hostarea==code)&&(type
				    ==fixuprel [3])) {
					k=(sym->st_value+tgtdisp)-hostdisp;
					j=areas [code-lowestarea].base+hostdisp;
					if ((abs(k)<0x7FF0)&&(((unsigned)(*(int  *)(j))>>26)==3)) 	/*jal*/{
						(*(int  *)(j))=0x4110000|(((k-4)/4)&0xFFFF);	/* relative bgezal on $r0 */

						if (mon!=0) {
							printf("Internal call optimised %x\n",hostdisp);	 
						}
						nrels [code]=nrels [code]-1;	  
						continue ;
					}
				}

#endif;
				/* Mapped area not shuffled except for GOT sym*/
			} else {

				k=tgtsym;
				tgtsym=symindex [epcareatoelfsym [tgtsym]];	/*gm*/
				if ((tgtsym==epcareatoelfsym [code])||(tgtsym==epcareatoelfsym [gla]))  tgtdisp+=areastart
				    [k];	/* If area has not a sym of its own %then add offset */
				if (tgtsym==0)  tgtsym=3;	/* tie spurious to DATA to be legal*/

			}

			/*-- work out where the relocation entry is and where it points --*/

			/* map onto a reloc table entry */

			if ((r->hostarea==code)||(r->hostarea==init)||(r->hostarea==fini)) {

#if(target==elfsparc) 
				if ((Pic!=0)&&(type==fixuprel [3]))  type=R_SPARC_WPLT30;

#endif;
#if(target==elf386)
				if ((Pic!=0)&&(type==fixuprel [3]))  type=R_386_PLT32;
#endif
				vad=hostdisp;
				relarea=epcareatorelarea [r->hostarea];
			} else if (r->hostarea==debugtab) {
				vad=hostdisp;
				relarea=debugrels;
			} else if (r->hostarea==linetab) {
				vad=hostdisp;
				relarea=linenorels;
			} else if (r->hostarea==tdesc) {
				vad=hostdisp;
				relarea=tdescrels;
				/* Data relocations */
			} else {
				vad=areastart [r->hostarea]+hostdisp;
				relarea=datarels;

			};




			/*-- fill in relocation entry --*/

			rrec.r_offset=vad;
			rrec.r_info=(tgtsym<<8)|type;
			if ((tgtsym<0)||(tgtsym>(nextsym+1)))  puterror("Bad symref");
			/*                                                                           */
			/* If there is no addend field in the relocation the addend must go into the */
			/* relocation. ? What about small fields with big addends? There are alignment*/
			/* and byteswopping problems. Why does 386 not support addend?               */
			/*                                                                           */

#if(reltype==SHT_RELA) 
			rrec.r_addend=tgtdisp;
#else
			j=areas [r->hostarea-lowestarea].base+hostdisp;
			if (((targetdata==elfdatamsb)&&(swapmode==0))||((targetdata==elfdatalsb)&&(swapmode!=0))) {
				/* IBM bytes                                                                 */
				orgcontents=((((*(unsigned char  *)(j))<<24)|((*(unsigned char  *)(j+1))<<16))|((*(unsigned
				    char  *)(j
				    +2))<<8))|(*(unsigned char  *)(j+3));
				/*               tgtdisp=tgtdisp+orgcontents                                 */

#if(target==elfmips) 
				if (type==R_MIPS_26)  tgtdisp/=4;
				if ((type==R_MIPS_HI16)||(type==R_MIPS_GOTt16))  tgtdisp=((unsigned)tgtdisp>>16)+(((unsigned)tgtdisp
				    >>15)&1);
				tgtdisp&=fixupmasks [type];
				tgtdisp|=orgcontents&(~fixupmasks [type]);

#endif;
				(*(unsigned char  *)(j))=(unsigned)tgtdisp>>24;
				(*(unsigned char  *)(j+1))=(unsigned)tgtdisp>>16;
				(*(unsigned char  *)(j+2))=(unsigned)tgtdisp>>8;
				(*(unsigned char  *)(j+3))=tgtdisp;
			} else {
				orgcontents=((((*(unsigned char  *)(j+3))<<24)|((*(unsigned char  *)(j+2))<<16))|((*(unsigned
				    char  *)(j
				    +1))<<8))|(*(unsigned char  *)(j));
				/*               tgtdisp=tgtdisp+orgcontents                                 */
				(*(unsigned char  *)(j))=tgtdisp;
				(*(unsigned char  *)(j+1))=(unsigned)tgtdisp>>8;
				(*(unsigned char  *)(j+2))=(unsigned)tgtdisp>>16;
				(*(unsigned char  *)(j+3))=(unsigned)tgtdisp>>24;
			}
			if ((target!=elfmips)&&(orgcontents!=0))  puterror("garbage in reloc target");

#endif;
			pdbytes(relarea,areas [relarea-lowestarea].highuse,sizeof(relaf),(int)&rrec);

		} while (1) /* FOR EVER */;

		/* Write out the file now apart from put defined symbol table & string       */
		/* tables which are not constructed yet                                      */

		writetofile(objid,(int)&hdr,fhdrsize,"Header");
		curfileptr=fhdrsize;

#if(regsectsize>0) 
		sectionposition [reginfosect]=curfileptr;
		sectionsizes [reginfosect]=regsectsize;
		if (swapmode!=0)  areaswap((int)&regsectdata [0],regsectsize);
		writetofile(objid,(int)&regsectdata [0],regsectsize,"Regsect")	/*gm*/;
		curfileptr+=regsectsize;

#endif;
		curfileptr=(curfileptr+15)&(-16);
		fileposition(objid,curfileptr,0);
		sectionposition [textsect]=curfileptr;
		sectionsizes [textsect]=areas [code-lowestarea].length;
		if (swapmode!=0)  areaswap(areas [code-lowestarea].base,sectionsizes [textsect]);
		writetofile(objid,areas [code-lowestarea].base,sectionsizes [textsect],"Textsect");
		curfileptr+=sectionsizes [textsect];

		j=areas [init-lowestarea].base;
		if (j>0) 	/* There is an INIT section */{
			curfileptr=(curfileptr+15)&(-16);
			sectionposition [initsect]=curfileptr;
			sectionsizes [initsect]=areas [init-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			if (swapmode!=0)  areaswap(areas [init-lowestarea].base,sectionsizes [initsect]);
			writetofile(objid,areas [init-lowestarea].base,sectionsizes [initsect],"Initsect");
			curfileptr+=sectionsizes [initsect];
		}

		j=areas [fini-lowestarea].base;
		if (j>0) 	/* There is an FINI section */{
			curfileptr=(curfileptr+15)&(-16);
			sectionposition [finisect]=curfileptr;
			sectionsizes [finisect]=areas [fini-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			if (swapmode!=0)  areaswap(areas [fini-lowestarea].base,sectionsizes [finisect]);
			writetofile(objid,areas [fini-lowestarea].base,sectionsizes [finisect],"Finisect");
			curfileptr+=sectionsizes [finisect];
		}

		curfileptr=(curfileptr+15)&(-16);

		/*------------------------------------------------------*/
		/*------------- MOVE AREAS INTO POSITION ---------------*/
		/*------------------------------------------------------*/


		/* -----  PLACE INITIALISED DATA AREAS IN 'DATA' %and 'RODATA'  ----- */

		if (rodatalen>0) 	/*gm*/{
			fileposition(objid,curfileptr,0);
			for (j=2; j<=10; j++) {
				i=order [j-2];
				if (epcareatosectndx [i]==rodatasect) {
					l=areas [i-lowestarea].length;
					if (l>0) {
						writetofile(objid,areas [i-lowestarea].base,l,"ROdata");
						freespace(areas [i-lowestarea].base);
						memset(&areas [i-lowestarea],0,sizeof( struct areafm));
					}
				}
			}
		}

		sectionposition [rodatasect]=curfileptr;
		sectionsizes [rodatasect]=rodatalen;
		curfileptr+=rodatalen;
		curfileptr=(curfileptr+15)&(-16);

		fileposition(objid,curfileptr,0);

		for (j=2; j<=toparea; j++) {
			if (j<11)  i=order [j-2]; 
			else i=j;	/*strict order on data areas */
			l=areas [i-lowestarea].length;
			if ((l==0)||((i==zgst)&&(bsslen!=0)))   continue ;
			if ((i<setareas)&&(epcareatosectndx [i]!=datasect))   continue ;
			if ((i==5)||(i>setareas)) 	/* encoded area */{
				areabase=lseek(objid,0,1)	/*where am I?*/;
				filler=(unsigned)areas [i-lowestarea].type>>24;
				if (filler!=0) 	/* to be pre-patterned */{
					pattern(objid,l,1,filler);
					fileposition(objid,areabase,0)	/* put file back to start of area */;
				}
				if (areas [i-lowestarea].base==0) {
					if (i>setareas)   continue ; 
					else goto empty;
					;
				}
				linkdisp=0;
				do 	/* Through area frags.*/{
					rd=(struct rdfm*)(areas [i-lowestarea].base+linkdisp);
					fileposition(objid,rd->disp+areabase,0);
					kad=(areas [i-lowestarea].base+linkdisp)+rdsize;
					if (rd->copies>1) {
						if (rd->len==1)  kad=(*(unsigned char  *)(kad));
						pattern(objid,rd->copies,rd->len,kad);
					} else writetofile(objid,kad,rd->len,"Datasect");
					;
					linkdisp+=((rd->len+rdsize)+3)&(-4);
				} while (!(((int)rd-areas [i-lowestarea].base)==areas [i-lowestarea].linkdisp)) ;
empty:

				fileposition(objid,areabase+l,0);
				/* mapped area */
			} else {
				if (areas [i-lowestarea].base!=0) 	/* has any initialisation been recvd? */{
					/*                                                                           */
					/* if the area size is larger than the buffer area allocated then care is needed */
					/* not to output junk in the unallocated space. Fileposition should do this but*/
					    /* care mak be needed here if the UNIX is non standard                       */
					/*                                                                           */
					if (areas [i-lowestarea].length>areas [i-lowestarea].max) {
						writetofile(objid,areas [i-lowestarea].base,areas [i-lowestarea].max,
						    "Datasectinit");
						fileposition(objid,areas [i-lowestarea].length-areas [i-lowestarea].max,
						    1);
					} else {
						writetofile(objid,areas [i-lowestarea].base,l,"Datasect");
					}
					freespace(areas [i-lowestarea].base);
					memset(&areas [i-lowestarea],0,sizeof( struct areafm));
				} else fileposition(objid,l,1);
				;
			}

		}

		sectionposition [datasect]=curfileptr;
		sectionsizes [datasect]=datalen;
		curfileptr+=datalen;

		/*                                                                           */
		/* Make entry for BSS but it is not in the file                              */
		/*                                                                           */
		if (bsslen>0) {
			sectionposition [bsssect]=curfileptr;
			sectionsizes [bsssect]=bsslen;
		}
		/*<-------- Write out relocation tables ---------->*/

		j=areas [coderels-lowestarea].base;
		if (j!=0) 	/* there are coderels */{
			curfileptr=(curfileptr+3)&(-4);
			sectionposition [textrelsect]=curfileptr;
			sectionsizes [textrelsect]=areas [coderels-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			if (swapmode!=0)  areaswap(j,sectionsizes [textrelsect]);
			writetofile(objid,j,sectionsizes [textrelsect],"Textrels");
			curfileptr+=sectionsizes [textrelsect];
			freespace(j);
			memset(&areas [coderels-lowestarea],0,sizeof( struct areafm));
		}

		j=areas [datarels-lowestarea].base;
		if (j!=0) 	/* there are Datarels */{
			curfileptr=(curfileptr+3)&(-4);
			sectionposition [datarelsect]=curfileptr;
			sectionsizes [datarelsect]=areas [datarels-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			if (swapmode!=0)  areaswap(j,sectionsizes [datarelsect]);
			writetofile(objid,j,sectionsizes [datarelsect],"DATArels");
			curfileptr+=sectionsizes [datarelsect];
			freespace(j);
			memset(&areas [datarels-lowestarea],0,sizeof( struct areafm));
		}

		j=areas [initrels-lowestarea].base;
		if (j!=0) 	/* there are INITrels */{
			curfileptr=(curfileptr+3)&(-4);
			sectionposition [initrelsect]=curfileptr;
			sectionsizes [initrelsect]=areas [initrels-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			if (swapmode!=0)  areaswap(j,sectionsizes [initrelsect]);
			writetofile(objid,j,sectionsizes [initrelsect],"INITrels");
			curfileptr+=sectionsizes [initrelsect];
			freespace(j);
			memset(&areas [initrels-lowestarea],0,sizeof( struct areafm));
		}

		j=areas [finirels-lowestarea].base;
		if (j!=0) 	/* there are FINIrels */{
			curfileptr=(curfileptr+3)&(-4);
			sectionposition [finirelsect]=curfileptr;
			sectionsizes [finirelsect]=areas [finirels-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			if (swapmode!=0)  areaswap(j,sectionsizes [finirelsect]);
			writetofile(objid,j,sectionsizes [finirelsect],"FINIrels");
			curfileptr+=sectionsizes [finirelsect];
			freespace(j);
			memset(&areas [finirels-lowestarea],0,sizeof( struct areafm));
		}



		/*                                                                           */
		/* If sdb mode then add the four relevant sections                           */
		/*                                                                           */

		if (sdb!=0) {
			j=areas [linetab-lowestarea].base;
			if (j!=0) {
				curfileptr=(curfileptr+3)&(-4);
				sectionposition [linenosect]=curfileptr;
				sectionsizes [linenosect]=areas [linetab-lowestarea].highuse;
				fileposition(objid,curfileptr,0);
				if (swapmode!=0) {
					/* Difficult to swap this section leave for now                              */
				}
				writetofile(objid,j,sectionsizes [linenosect],"LINENOsect");
				curfileptr+=sectionsizes [linenosect];
			}

			j=areas [linenorels-lowestarea].base;
			if (j!=0) 	/* there are LINENOrels */{
				curfileptr=(curfileptr+3)&(-4);
				sectionposition [linerelsect]=curfileptr;
				sectionsizes [linerelsect]=areas [linenorels-lowestarea].highuse;
				fileposition(objid,curfileptr,0);
				if (swapmode!=0)  areaswap(j,sectionsizes [linerelsect]);
				writetofile(objid,j,sectionsizes [linerelsect],"LINENORELS");
				curfileptr+=sectionsizes [linerelsect];
				freespace(j);
				memset(&areas [linenorels-lowestarea],0,sizeof( struct areafm));
			}

			curfileptr=(curfileptr+3)&(-4);
			sectionposition [debugsect]=curfileptr;
			sectionsizes [debugsect]=areas [debugtab-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			writetofile(objid,areas [debugtab-lowestarea].base,sectionsizes [debugsect],"DEBUG");
			curfileptr+=sectionsizes [debugsect];
			j=areas [debugrels-lowestarea].base;
			if (j!=0) 	/* there are DBrels */{
				curfileptr=(curfileptr+3)&(-4);
				sectionposition [debugrelsect]=curfileptr;
				sectionsizes [debugrelsect]=areas [debugrels-lowestarea].highuse;
				fileposition(objid,curfileptr,0);
				if (swapmode!=0)  areaswap(areas [debugrels-lowestarea].base,sectionsizes [debugrelsect]);
				writetofile(objid,areas [debugrels-lowestarea].base,sectionsizes [debugrelsect],"DEBUGrels");
				curfileptr+=sectionsizes [debugrelsect];
			}

			/* %if sdb#0*/
		}


#if(target==elfmips) 
		/*************************************************************************/
		/** Mips has 3 extra mandatory sections. The register section           **/
		/** defines the registers used by the chip and up to 4 co-              **/
		/** processors. The next two gptab sections reflect the workings        **/
		/** of the mips compilers. They enable the linker to indicate           **/
		/** the benefits or otherwise of changing the storeage allocation       **/
		/** of small global items between the gp table and other areas          **/
		/** EPC compiler allocate differently and the best we can do is         **/
		/** frig up a hopefully harmless dummy                                  **/
		/*************************************************************************/
		{
			static int dummygptab [5+1] = {
				0,0,	/* Nothing allocated to gp */4,0x10000,	/*If 4 byte items allocated 64k reqd */8,0x20000			};	/*
			    If 8 byte 128k reqd */


			static const int gptabsize=24;
			static int dummydebugtab [7+1] = {
				0x70090300,0			};
			static const int debugtabsize=32;

			curfileptr=(curfileptr+3)&(-4);
			sectionposition [datagptabsect]=curfileptr;
			sectionsizes [datagptabsect]=gptabsize;
			fileposition(objid,curfileptr,0);
			writetofile(objid,(int)&dummygptab [0],gptabsize,"gptab");
			curfileptr+=gptabsize;

			if (bsslen>0) {
				sectionposition [bssgptabsect]=curfileptr;
				sectionsizes [bssgptabsect]=gptabsize;
				writetofile(objid,(int)&dummygptab [0],gptabsize,"gptab");
				curfileptr+=gptabsize;
			}

		}
		/*Mips extra mandatory sections */

#endif;


#if((target==elf88k)||(target==elfppc)) 
		/*******************************************************************         */
		/** M88k has Tdesc sections & their relocations. Not all compilers *         */
		/** will generate these but it present must be dealt with          *         */
		/* PPC tags section are the same apart form detailed contents      *         */
		/*******************************************************************         */
		j=areas [tdesc-lowestarea].base;
		if (j!=0) {
			curfileptr=(curfileptr+3)&(-4);
			sectionposition [tdescsect]=curfileptr;
			sectionsizes [tdescsect]=areas [tdesc-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			writetofile(objid,j,sectionsizes [tdescsect],"TDESCS");
			curfileptr+=sectionsizes [tdescsect];
			freespace(j);
			memset(&areas [tdesc-lowestarea],0,sizeof( struct areafm));
		}
		j=areas [tdescrels-lowestarea].base;
		if (j!=0) {
			curfileptr=(curfileptr+3)&(-4);
			sectionposition [tdescrelsect]=curfileptr;
			sectionsizes [tdescrelsect]=areas [tdescrels-lowestarea].highuse;
			fileposition(objid,curfileptr,0);
			writetofile(objid,j,sectionsizes [tdescrelsect],"TDESCrels");
			curfileptr+=sectionsizes [tdescrelsect];
			freespace(j);
			memset(&areas [tdescrels-lowestarea],0,sizeof( struct areafm));
		}

#endif;
		/*                                                                           */
		/* We are now in a deadly embrace. The next 3 sections are not complete      */
		/* but we cannot complete them without the section table. The section table  */
		/* can not be built till the las 3 sections are complete!                    */
		/* However we Know the seze of the symboltable                               */
		/*                                                                           */
		curfileptr=(curfileptr+3)&(-4);
		sectionposition [symsect]=curfileptr;
		sectionsizes [symsect]=(nextsym+1)*symboltableentrysize;

		/*                                                                           */
		/* now build all bar the last 2 section of section header table              */
		/*                                                                           */
		for (i=0; i<=maxsect; i++) {
			if (sectionsizes [i]!=0)  addshentry(&shdrs[0] ,i);
		}
		/*                                                                           */
		/* now complete the symbol table                                             */
		/*                                                                           */
		/* ------- Fill in fixed entries at start of table ------- */

		s=&syms [0];	/* empty entry */
		memset(s,0,sizeof( Elf32_Sym));
		s=&syms [1];	/* .file  entry */
		memset(s,0,sizeof( Elf32_Sym));
		placeindict(srcfile,&s->st_name);
		s->st_info=STT_FILE;
		s->st_shndx=SHN_ABS;


		s=&syms [2];	/* epctext entry                                               */
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epctext");
		placeindict(name,&s->st_name);
		s->st_size=textlen;
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_SECTION);
		s->st_shndx=sectionentryno [textsect];

		s=&syms [3];	/* epcdata entry                                               */
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcdata");
		placeindict(name,&s->st_name);
		s->st_size=datalen;

#if(target==elf88k) 
		s->st_info=STB_LOCAL<<4;	/*!Section*/
		/* BREAKS PIC on DG 5.4 and 5.4.1               */
		/* if you comment out section you get NOTYP                                  */
		/* for section desc which is bad elf,but PIC                                 */
		/* works                                                                     */

#else
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_SECTION);

#endif;
		s->st_shndx=sectionentryno [datasect];

		s=&syms [4];	/* epcbss entry                                                */
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcbss");
		placeindict(name,&s->st_name);
		s->st_size=bsslen;
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_SECTION);
		s->st_shndx=sectionentryno [bsssect];

		s=&syms [5];	/*epcdebug entry                                               */
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcdebug");
		placeindict(name,&s->st_name);
		s->st_size=debugptr;
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_SECTION);
		s->st_shndx=sectionentryno [debugsect];
		/* epcline entry                                                             */
		s=&syms [6];
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epclines");
		placeindict(name,&s->st_name);
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_SECTION);
		s->st_shndx=sectionentryno [linenosect];
		/* epcrodata entry                                                           */
		s=&syms [7];
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcrodata");
		placeindict(name,&s->st_name);
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_SECTION);
		s->st_shndx=sectionentryno [rodatasect];
		s->st_size=rodatalen;
		s=&syms [8];
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcconst");
		placeindict(name,&s->st_name);
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_OBJECT);
		s->st_shndx=sectionentryno [epcareatosectndx [cnst]];
		s->st_value=areastart [cnst];
		s->st_size=areas [cnst-lowestarea].length;

		s=&syms [9];
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcsst");
		placeindict(name,&s->st_name);
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_OBJECT);
		s->st_shndx=sectionentryno [epcareatosectndx [sst]];
		s->st_value=areastart [sst];
		s->st_size=areas [sst-lowestarea].length;

		s=&syms [10];
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcgst");
		placeindict(name,&s->st_name);
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_OBJECT);
		s->st_shndx=sectionentryno [epcareatosectndx [gst]];
		s->st_value=areastart [gst];
		s->st_size=areas [gst-lowestarea].length;

		s=&syms [11];
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epcscalar");
		placeindict(name,&s->st_name);
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_OBJECT);
		s->st_shndx=sectionentryno [epcareatosectndx [scalar]];
		s->st_value=areastart [scalar];
		s->st_size=areas [scalar-lowestarea].length;

		s=&syms [12];
		memset(s,0,sizeof( Elf32_Sym));
		strcpy(name,"epciotab");
		placeindict(name,&s->st_name);
		s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_OBJECT);
		s->st_shndx=sectionentryno [epcareatosectndx [iotab]];
		s->st_value=areastart [iotab];
		s->st_size=areas [iotab-lowestarea].length;
		/*                                                                           */
		/* IN extreme cases sections may not exist                                   */
		/*                                                                           */
		for (i=2; i<=stfixedentries-1; i++) {
			s=&syms [i];
			if (s->st_shndx==0) {
				s->st_shndx=SHN_ABS; 
				s->st_info=ELF32_ST_INFO(STB_LOCAL,STT_NOTYPE);
			}
		}

		/*----- write out the symbol table -----*/
		for (i=stfixedentries; i<=nextsym; i++) {
			if ((i>maxloc)&&(ELF32_ST_BIND(syms [i].st_info)==STB_LOCAL))  puterror("sym table badly shuffled");
			area=syms [i].st_shndx&0xFFFF;	/*sign bit propagates on commons!               */
			if (area==SHN_COMMON) {
				syms [i].st_value=areas [syms [i].st_value-lowestarea].align;  
				continue ;
			}
			if ((0<area)&&(area<setareas)) {
				syms [i].st_value=syms [i].st_value+areastart [area];
				syms [i].st_shndx=sectionentryno [epcareatosectndx [area]];
			}
		}
		/*                                                                           */

		curfileptr+=sectionsizes [symsect];
		sectionposition [stringsect]=curfileptr;
		l=dictad-dictstart;
		l=(l+3)&(-4);	/*round up to next word boundary                              */
		sectionsizes [stringsect]=l;
		curfileptr+=l;
		addshentry(&shdrs[0] ,stringsect)	/* string section header*/;
		shdrs [sectionentryno [symsect]].sh_link=nsects-1;	/* Sym link is rel string table */
		fileposition(objid,sectionposition [symsect],0);
		if (swapmode!=0) {
			for (i=0; i<=nextsym; i++) {
				stentryswap(&syms [i]);
			}
		}
		writetofile(objid,(int)&syms [0],((nextsym+1)*symboltableentrysize),"Symtab");

		/*      %IF swapmode#0 %THEN integer(dictstart)=wordswap(integer(dictstart)) */
		writetofile(objid,dictstart,l,"symnames");
		freespace(dictstart);
		memset(&areas [dicttab-lowestarea],0,sizeof( struct areafm));
		/*                                                                           */
		/* now the section for section header names                                  */
		/*                                                                           */
		curfileptr=(curfileptr+3)&(-4);
		sectionposition [shstringsect]=curfileptr;
		sectionsizes [shstringsect]=shptr+10;	/* For shsection name itself */
		addshentry(&shdrs[0] ,shstringsect);
		fileposition(objid,curfileptr,0);
		/*     %IF swapmode#0 %THEN integer(addr(shnames(0)))=wordswap(integer(addr(shnames(0))))*/
		writetofile(objid,(int)&shnames [0],shptr	/* now updated*/,"SHnames");
		/*                                                                           */
		/* write out section header table                                            */

		curfileptr+=sectionsizes [shstringsect];
		curfileptr=(curfileptr+3)&(-4);
		fileposition(objid,curfileptr,0);
		if (swapmode!=0)  areaswap((int)&shdrs [0],(nsects*sizeof( Elf32_Shdr)));
		writetofile(objid,(int)&shdrs [0],(nsects*sizeof( Elf32_Shdr)),"Section table");
		/*                                                                           */
		/* now complete the file header                                              */
		/*                                                                           */
		hdr.e_shoff=curfileptr;
		hdr.e_shnum=nsects;
		hdr.e_shstrndx=sectionentryno [shstringsect];

#if(prghdrentries>0) 
		{
			Elf32_Phdr *ph;
			ph=&hdr.prghdr [0];
			sh=&shdrs [reginfosect];	/* reginfosect described thus */
			ph->p_type=0x70000000;
			ph->p_offset=sh->sh_offset;
			ph->p_vaddr=sh->sh_offset+0x10000000;
			ph->p_paddr=ph->p_vaddr;
			ph->p_filesz=sh->sh_size;
			ph->p_memsz=ph->p_filesz;
			ph->p_flags=PF_R;		/* reg data read only */
			ph->p_align=4;		/* word align         */
			ph=&hdr.prghdr [1];
			sh=&shdrs [textsect];
			ph->p_type=PT_LOAD;
			ph->p_offset=sh->sh_offset;
			ph->p_vaddr=0x10000000;
			ph->p_paddr=ph->p_vaddr;
			ph->p_filesz=sh->sh_size;
			ph->p_memsz=ph->p_filesz;
			ph->p_flags=PF_R!PF_X;		/* text read exec */
			ph->p_align=4096;
			ph=&hdr.prghdr [2];
			sh=&shdrs [datasect];
			ph->p_type=PT_LOAD;
			ph->p_offset=sh->sh_offset;
			ph->p_vaddr=shdrs [textsect].size+0x10000000;
			ph->p_paddr=ph->p_vaddr;
			ph->p_filesz=sh->sh_size;
			ph->p_memsz=ph->p_filesz;
			ph->p_flags=PF_R!PF_X!PF_W;	/* data read writeexec */
			ph->p_align=16*4096;
		}

#endif;
		fileposition(objid,0,0);
		if (swapmode!=0)  elfhdrswap(&hdr);
		writetofile(objid,(int)&hdr,fhdrsize,"Revised HDR");

	}
	i=close(objid);
	if (mon!=0) printf("Close object file %s - %x\n",objname,i);

	if (malmon!=0)  printf("\nmax data after object generation = %d\n",maxdata);

	for (i=lowestarea; i<=toparea; i++) {
		if (i==0)   continue ;
		if (areas [i-lowestarea].base!=0) {
			if (mon!=0) {
				printf("Area table entry freed at Pgenerate exit:- %d %x %x\n",
					i,areas [i-lowestarea].base,areas [i-lowestarea].max);	 
			}
			freespace(areas [i-lowestarea].base);
			memset(&areas [i-lowestarea],0,sizeof( struct areafm));
		}
	}
	if (mon!=0) {
		i=0;
		printf("Area base table freed at Pgenerate exit:- %x %x\n",
			areas [i-lowestarea].base,areas [i-lowestarea].max);
	}
	freespace(areas [0-lowestarea].base);
	memset(&areas [0-lowestarea],0,sizeof( struct areafm));
	freespace(relsmalloc);
}	/*PGenerateObject*/


void pmonon() {
	/*      comreg(59)=comreg(59)!4                                              */
	mon=1;	 
	malmon=1;
}	/*PMonOn*/

void pmonoff() {
	/*      comreg(59)=comreg(59)&X'FFFFFFFB'                                    */
	mon=0;
}	/*PMonOff*/
 
 
 
 

/* end of automatic translation */

