/*
*****************************************************************************
*									    *
*  Copyright (c) 1978, 1979, 1980, 1982, 1988                               *
*  by DIGITAL Equipment Corporation, Maynard, Mass.			    *
* 									    *
*  This software is furnished under a license and may be used and  copied   *
*  only  in  accordance  with  the  terms  of  such  license and with the   *
*  inclusion of the above copyright notice.  This software or  any  other   *
*  copies  thereof may not be provided or otherwise made available to any   *
*  other person.  No title to and ownership of  the  software  is  hereby   *
*  transferred.							 	    *
* 									    *
*  The information in this software is subject to change  without  notice   *
*  and  should  not  be  construed  as  a commitment by DIGITAL Equipment   *
*  Corporation.							   	    *
* 									    *
*  DIGITAL assumes no responsibility for the use or  reliability  of  its   *
*  software on equipment which is not supplied by DIGITAL.		    *
*									    *
*****************************************************************************

facility:

	SDL (Structure Definition Language)

abstract:

	Creates the BLISS language output from the SDL tree.
	Generates MDL-compatible macros for accessing the data structures.

author:
	Marty Jack	(VMS)
date:
	revised 22-DEC-1980	ctp
	revised 30-JUN-1982	lhs		version 1.5 changes
	revised 20-AUG-1982	lhs		add vms macros and fieldsets
	revised 04-OCT-1982	lhs		version 1.7 changes
	revised 30-NOV-1982	lhs		level 1.7-3 changes
	revised 09-May-1982	kd		level 1.8 changes including fixes
						to handle the optional parameter
						problem.
	revised 07-Nov-1983	kd		Fix keyword macro to include the
						module name.
	revised 16-Jan-1984	kd		Make changes for V2.  Make backends
						into seperate shareable images.	
	revised 13-Feb-1990  William R. Vales	Make changes to record
			     Robert Thomson	dependency data for VMS VDE
						system builder. (see CHANGE LOG)
*/

/*			C H A N G E    L O G

      Date	! Name	! Description
________________!_______!______________________________________________________
  11-Jan-1983	!  PHH	! Change log added.  Taught Case(NOD$K_Itemnode) to write a size declaration
		!	! for level-1 aggregates.  Added SDL$LIBRARY to %INCLUDEs.
  14-Jan-1983	!  PHH	! Fixed code under NOD$K_Itemnode to not put out duplicate definitions.
  24-Jan-1982	!  PHH	! Previous fix caused failure to put out size definition for certain constructs
  25-Jan-1982	!  PHH	! Default sign-extension bit for LONGWORD was 0 instead of 1
   9-May-1983	|  kd	| 1.8 changes
   7-Nov-1983	|  kd	| Fix the keyword macro to include the Module name...
		|	| this fixes the problem with multiply defined macros in
		|	| library files that contain more than one SDL generated
		|	| module.
  16-Jan-1984	|  kd	| Make changes for V2.  Make backends into separate 
		|	| shareable images.
________________|_______|______________________________________________________
  02-Aug-1984	|  kd	| Add IDENT field 1.0.
________________|_______|______________________________________________________
  22-Mar-1985	|  kd	| 2-1  Add type name support.
________________|_______|______________________________________________________
     6-Jun-1985	|  kd	| 2-2  Add a close for output file.  Add condition 
		|	|	handler for undefinedfile condition.
________________|_______|______________________________________________________
    11-Jun-1985	|  kd	| T2.9-0 Make the backend ident be the sdl version
________________|_______|______________________________________________________
    21-Aug-1985	|  kd	| T2.9-1 Change comments flag to sdl$v_comment_opt.
________________|_______|______________________________________________________
    25-Mar-1986	|  pc	| V3.0-1 Add stuff for LIST parameters.
________________|_______|______________________________________________________
     6-Mar-1987	|  jgw	| T3.1-0 Corrected KEYWORDMACRO name derived for
		|	|	 an entry point with no ALIAS specified;
		|	|	 provided support here for LIB$, SCR$, MTH$,
		|	|	 OTS$, SMG$, DTK$ and STR$ prefixes.  Also, made
		|	|	 appropriate modifications to pc's 25-Mar-1986
		|	|	 changes to allow for OPTIONAL LIST.
		|	|	 Also:  initialized output buffer (buf) and
		|	|	 tmpbuf to '' at outer-level declaration.
________________|_______|______________________________________________________
     2-Apr-1987	|  jgw	| X3.1-1 Bumped the version number and switched from T
		|	|	 to X in the version number, since X is used
		|	|	 for development releases.
________________|_______|______________________________________________________
    14-Apr-1987	|  jgw	| X3.1-2 Added handling of COMPLEX data types.
________________|_______|______________________________________________________
    18-Jan-1988	|  PG	| X3.2-0 Add CONSTANT STRING
________________|_______|______________________________________________________
    26-Jan-1988	|  PG	| X3.2-1 Fix CONSTANT STRING to use MACRO
________________|_______|______________________________________________________
    01-Feb-1988	|  jg	| X3.2-2 Implement user defined types.
		|	|	 VOID returns :novalue.
________________|_______|______________________________________________________
    18-Feb-1988	|  jg	| X3.2-3 Add support for conditional compilation and
		|	|	  LITERAL.
________________|_______|______________________________________________________
    29-Jun-1988	|  jgw	| X3.2-4 Corrected macro name derived for an ENTRY with
   		|	|	 no ALIAS specified.
________________|_______|______________________________________________________
    13-FEB-1990	|  WRV	| X3.2-VMS1 Modifiers are members of VMS tools group.
   		|  RHT	|	    Added code for file dependency recording for
		|	|	    VMS VDE system builder.
________________|_______|______________________________________________________
    26-Nov-1990 |  dlm  | EV1-0 - EVMS update; separate BLISS64 backend
________________|_______|______________________________________________________
    20-Mar-1992	|  JAK	| EV1-10 Added revision checks.
________________|_______|______________________________________________________
     1-Jun-1992	|  JAK	| EV1-11 Added uppercase 'FILL' check, too.
________________|_______|______________________________________________________
    11-Jun-1992	|  JAK	| EV1-14 Made signed the default for QUADWORD and OCTAWORD.
		|	|	Ignore typdef items.
________________|_______|______________________________________________________
    29-Jun-1992	|  JAK	| EV1-15 Back out the change to ignore typdef items.
________________|_______|______________________________________________________
    29-Jan-1993	|  JAK	| EV1-21 Changed to emit size literal only if larger 
		|	|	than blissword, rather than 4 bytes.
		|	|	Implemented BLISS64 functionality here triggered by 
		|	|	sdl$v_b64_opt (/B64).
    18-Feb-1993	|	|	Set blissword_size based only on /B64.
		|	|	Emit size literals if > 4 independent of /ALPHA or /B64.
		|	|	Change test to suppress aggregate size literal if 
		|	|	defined with a named type to not require node 
		|	|	pointed toby TYPEINFO2 to be a TYPE node.
    24-Feb-1993	|	|	Removed TYPEINFO2 ^= null() as a reason for using zero for a size field.
________________|_______|______________________________________________________
    20-Oct-1994	|  RC	| EV1-40    Native Alpha port.  See SDLGETFNM.PLI.
________________|_______|______________________________________________________
*/
%replace MODULE_IDENT by 'EV1-40';


sdl$output: proc( out_file, default_name, sdl$_shr_data)
		options(ident(MODULE_IDENT));

	%include 'SDL$LIBRARY:sdlnodef.in';
	%include 'SDL$LIBRARY:sdltypdef.in';
	%include 'SDL$LIBRARY:sdlmsgdef.in';
	%include 'SDL$LIBRARY:sdlshr.in';
	%include 'SDL$LIBRARY:sdlgetfnm.in';

/* CONSTANTS */
	%replace true by '1'b;
	%replace false by '0'b;

/* LOCALS */
	dcl default_name char(132) var;
	dcl out_file char(128) var ;
	dcl output_file file output record sequential;
	dcl (buf,tmpbuf) char(1024) var init('');
	dcl based_string char(1024) var based;
	dcl module_name char(128) var;
	dcl (i,j) fixed;
	dcl origin fixed bin;
	dcl tab char initial (byte(9));
	dcl tag char (2);
	dcl b64 bit(64) aligned;
	dcl put_optmacro bit 
		init ('0'b);	/* flag to indicate that the optional parameter
				   macro has been put out */
	dcl optional_flag bit
		init ('0'b);	/* a flag to be kept after an entry node has
				   been read to be set to = nod$v_optional */
	dcl (f_complex_flag,
	     d_complex_flag,
	     g_complex_flag,
	     h_complex_flag) bit
		init ('0'b);	/* flags which indicate whether or not each of
				   the COMPLEX data types have been previously
				   encountered -- to control output of related
				   component macros and size constants */
 
	dcl process_conditional bit init (false);		/* jg */
	dcl blissword_size  fixed bin(31);
	dcl lang_ext char(4) var;
	dcl lang_name char(32) var;

/*** main ***/
 
/* Check version mismatch */
    if shrdata_version ^= sdl$k_shrdata_rev |
       node_version ^= sdl$k_node_rev then 
	do;
	call errmsg(sdl$_shr_data,sdl$_revcheck,,);
	goto exit;
	end;

    if sdl$v_b64_opt then 
	do;
        blissword_size = 8;	/* For BLISS64 */
	lang_ext = '.R64';	/* language extension for BLISS64 */
	lang_name = 'BLISS64';	/* Language name for conditional - jg */
	end;
    else 
	do;
        blissword_size = 4;	/* For BLISS32 */
	lang_ext = '.R32';	/* language extension for BLISS32 */
	lang_name = 'BLISS';	/* Language name for conditional - jg */
	end;

/* first open up the output file */

    on undefinedfile (output_file) 
	begin;
	    call errmsg (sdl$_shr_data, sdl$_outfilopn,,(sdl$gt_filename));
	    goto exit;
	end;
  
	/* concatenate the extension for the language */
	out_file = out_file ;  
	open file (output_file) title (out_file) 
			environment (default_file_name( default_name || lang_ext),
				     user_open (sdl$getfnm) );
	outfile = output_file;	/* equate the file with the file variable 
					in the shared structure */	

	call sdl$header(sdl$_shr_data, '! ','',line_length);

	call outputnode(tree_root->nod$a_flink,tree_root,0);

/* Get the fully resolved language specific output file and
   and move it the shared data area for the front-end. The reultant
   name will be recorded as a file dependency for the VDE system builder.
*/
	vde_lang_file =	sdl$gt_filename;

	close file (output_file);
exit: 

	return;



/** print node routine **/
outputnode:	proc (initp,startp,level);
  dcl (initp,p,startp,q) ptr;
  dcl level fixed bin;
  dcl (internal_name, external_name, indent) char (34) var ;
  dcl pcnt fixed bin;
  dcl dollar_pos fixed bin init (0);
  dcl tab2 char (2) init(byte(9)||byte(9));
  dcl (temp1,temp2) char(128) var;				/* PG */
  dcl dtype fixed bin(15); /* data type */
  dcl dsign bit(1) aligned; /* signed/unsigned */

 
    p = initp;
    do while (p^=startp);
	goto case(p->nod$b_type);
 
case(nod$k_rootnode):
	buf='';
	goto common_2;
case(nod$k_commnode):
	goto common;
case(nod$k_constnode):						/* PG */

	if p->nod$w_datatype = typ$k_char then do;
		temp1=p->nod$a_typeinfo2->based_string;
		call sdl$cvtstr(temp1,temp2, '''''''');
		buf='macro '||p->nod$t_name||' = '''||temp2||
			'''%;';
		end;
	else
        if p->nod$v_mask then
        	buf='literal '||p->nod$t_name||' = %X'''||
			p->nod$t_maskstr||''';';
        else
		buf='literal '||p->nod$t_name||' = '||
			trim(p->nod$l_typeinfo)||';';

	goto common;

case(nod$k_entrynode):

	if ^sdl$v_vms_opt then 	/* non-VMS case */
	    do;
	    buf='external routine '||p->nod$t_name;
	    if p->nod$w_datatype=0 | p->nod$w_datatype=typ$k_void then
	        buf=buf||': novalue';		/* jg */
	    buf=buf||';';
	    goto common;
	    end;

	/* special case of VMS entry info, and do keyword macro */

	/* if the optional parameter has not yet been put out then put it out */
 	if ^put_optmacro then 
	    do;
	    call optmacro;
	    put_optmacro = true;
	    end;

	/* make $name label spelling */
	external_name = p->nod$t_name;
	if p->nod$v_alias then
	    internal_name = p->nod$t_naked;
	else 
	    /*
	    * No ALIAS clause was specified, so construct a
	    * macro name of the form:
	    *	    $fac_routine
	    */
	    do;
	    internal_name = p->nod$t_name;
	    dollar_pos = index(internal_name, '$');
	    if dollar_pos = 0 then 
		/*
		* No dollar sign is present, so we don't have a
		* facility prefix in the specified name.  Therefore,
		* just stick an underscore in front of the routine
		* name to form the macro name.  VMS Development agrees
		* that this is the appropriate convention.
		*/
   		internal_name = '_' || internal_name;
	    else 
	    if translate(substr(internal_name, 1, dollar_pos - 1),
		    'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz') = 'SYS' then
		internal_name = substr(internal_name,4);
	    else
		internal_name = '$' || substr(internal_name, 1, dollar_pos - 1) ||
				    '_' || substr(internal_name, dollar_pos + 1);
	    end;

	/* put out KEYWORD $name macro */

	if p->nod$v_variable then 
	    do;
	    buf = 'MACRO ' || internal_name ||'[]=';
	    call sdl$putline (outfile, buf, line_length);
	    call sdl$putline (outfile, tab||'(', line_length); /* put out macro body*/
	    call sdl$putline (outfile, tab|| 'EXTERNAL ROUTINE ' || external_name
			|| ' : BLISS ADDRESSING_MODE (GENERAL);',line_length);
						/* line to declare external*/
	    buf = tab|| external_name || ' (';
	    buf = buf || '%REMAINING';
	    buf = buf || ')';
	    call sdl$putline (outfile, buf, line_length);
	    call sdl$putline (outfile, tab || ') %;', line_length);
	    buf = '';
	    goto common;
	    end;

	/* for a variable number of parameters */
	buf = 'KEYWORDMACRO ' || internal_name;
	if p->nod$a_child = null() then 
	    buf = buf || ' =';
	else 
	    do;
	    /* if it has parameters, then go down the parameter list putting out macro arg list */
	    buf = buf || ' (';
	    pcnt = outputspell ( p->nod$a_child->nod$a_flink, p->nod$a_child, comma_proc, true);
	    buf = buf || ') =';
	    end;	

	call sdl$putline (outfile, buf,line_length); /* put out macro header */
	call sdl$putline (outfile, '   '||'BEGIN', line_length);
	call sdl$putline (outfile, '   '||'EXTERNAL ROUTINE ' || external_name
			|| ' : BLISS ADDRESSING_MODE (GENERAL);',line_length); /* line to declare external*/

	/* put out KEYWORDMACRO which handles optional parameters */
	if p->nod$a_child = null() then 
	    do;	/* if there are no parameters */
	    call sdl$putline (outfile, tab||external_name||'()', line_length);
	    call sdl$putline (outfile, '   END %;', line_length);
	    buf = '';
	    end;
	else 
	    do;
	    buf = external_name || ' (';
	    call put_opt_kwmacro (p->nod$a_child->nod$a_flink, p->nod$a_child);
	    call sdl$putline (outfile, ' ', line_length);
	    end;
	 	 
	goto common;

case(nod$k_itemnode):
	buf = '';

	if p->nod$v_declared then 
	    goto common; /* ignore declared item - jg */

	/* Follow typedef chain for user types */
	do q=p repeat q->nod$a_typeinfo2->nod$a_flink 
	    while( q->nod$w_datatype = typ$k_user );
	end;
	dtype = q->nod$w_datatype;

	if q->nod$v_unsigned 
	then 
	    dsign = false;
	else 
	if q->nod$v_signed | 
	    dtype = typ$k_byte |
	    dtype = typ$k_word |
	    dtype = typ$k_longword | 
	    dtype = typ$k_quadword |	/* EV1-14 */
	    dtype = typ$k_octaword 	/* EV1-14 */
	then 
	    dsign = true;
	else 
	    dsign = false;

       /*
	* If the data type is one of the COMPLEX types, put
	* out the real/imaginary component macros and size
	* constants if the same COMPLEX data type has not
	* been previously encountered; then, put out the
	* appropriate macro and size constant for the item.
	*/
	if p->nod$v_complex then
	    if ((dtype = typ$k_float_complex) & (^f_complex_flag)) |
	       ((dtype = typ$k_double_complex) & (^d_complex_flag)) |
	       ((dtype = typ$k_grand_complex) & (^g_complex_flag)) |
	       ((dtype = typ$k_huge_complex) & (^h_complex_flag)) then
		call put_complex_definitions (p);

	if (dtype = typ$k_structure | dtype = typ$k_union)
	then do;	/* STRUCTURE or UNION */
	    if level = 1
	    then do;	/* Top level */
		origin = p->nod$l_typeinfo;
		if sdl$v_vms_opt
		then do;	/* /VMS qualifier */
		    buf ='literal '||p->nod$t_prefix||'S_'||
			p->nod$t_naked||' = '||trim(p->nod$l_fldsiz)||';';
		    goto common;
		end;
	    end;
	end;
	else 
	    if level = 1
	    then 
		origin=0;
	if p->nod$v_userfill & 
	    (^p->nod$v_fixed_fldsiz
		| substr(p->nod$t_naked,1,4)='fill'
		| substr(p->nod$t_naked,1,4)='FILL') /* EV1-11 */
	then	/* skip any user fill fields */
	    goto common_2;

	if ^p->nod$v_userfill
	then do;
/* Check for GLOBAL/EXTERNAL declarations */
	    if (p->nod$v_common | p->nod$v_global)
	    then do;
		if sdl$v_global_opt
		then 
		    buf = 'global ';
		else 
		    buf = 'external ';
		buf = buf || p->nod$t_name;
		if dtype = typ$k_word
		then 
		    buf = buf || ' : word';
		else 
		    if dtype=typ$k_byte
		    then 
			buf = buf || ' : byte';
		buf = buf || ';' ;
		goto common;
	    end;

	    buf = 'macro ' || p->nod$t_name ||' = ';
	    if dtype = typ$k_vield 
	    then do;	    /* BITFIELD */
		i = mod(p->nod$l_typeinfo2,32);
		j = divide (p->nod$l_typeinfo2-i,8,31) + p->nod$l_offset +
			    origin;
		buf=buf||trim(j)||','||trim(i)||','||trim(p->nod$l_typeinfo)||',';
	    end;
	    else do;	    /* NOT BITFIELD */
		buf=buf||trim(p->nod$l_offset+origin)||',';
		buf=buf||'0,';
		/* If size is too large for relevant Bliss */
		if p->nod$l_fldsiz > blissword_size 
		then 
		    buf=buf||'0,';
		else 
		    buf=buf||trim(p->nod$l_fldsiz*8)||',';
	    end;
	    if dsign 
	    then 
		buf=buf||'1';  	/* signed */
	    else 
		buf=buf||'0';  	/* unsigned */
	    buf = buf || ' %;';
	 end;

	 if substr(p->nod$t_naked,1,1) < 'a' then
		tag = 'S_';
	 else
		tag = 's_';
	if ^(sdl$v_vms_opt &
		index(p->nod$t_naked,'_FIELDS')	^= 0 |
		index(p->nod$t_naked,'_BITS') ^= 0 |
		index(p->nod$t_naked,'_OVERLAY') ^= 0)
	then do;    /* output size const is not vms dummy name */
	    if dtype=typ$k_vield & p->nod$l_typeinfo > 1 
	    then do;	/* Bitfield with size > 1 */
		call sdl$putline (outfile, buf, line_length);
		buf ='literal '||p->nod$t_prefix||tag||
		p->nod$t_naked||' = '||trim(p->nod$l_typeinfo)||';';
	    end;
		/* If this item is a structure, union, character string, 
		    the size is > "word" size, or it is dimensioned, then put out 
		    a size literal. */
	    else 
		if dtype=typ$k_structure | dtype=typ$k_union |
		    p->nod$w_datatype=typ$k_char & p->nod$l_fldsiz > 1 |
		    p->nod$l_fldsiz > 4 |
		    p->nod$v_dimen 
		then do;	
		    call sdl$putline (outfile, buf, line_length);
		    buf ='literal '||p->nod$t_prefix||tag||
			    p->nod$t_naked||' = '||trim(p->nod$l_fldsiz)||';';
		end;
	end;
	goto common;
case(nod$k_modulnode):
	call sdl$putline (outfile, ' ',line_length);
	buf='!*** MODULE '||p->nod$t_name;
	if p->nod$t_naked ^= '' then
		buf=buf ||' IDENT '||p->nod$t_naked;
	buf=buf||' ***';
	module_name = p->nod$t_name;	/* save the module name for the
					   keyword macro which deals with optional
					   parameters 		*/
	call sdl$putline (outfile, buf,line_length);
	buf='';
	goto common;
case(nod$k_parmnode):
	goto common_2;
case(nod$k_objnode):
	buf='';
	goto common_2;
case(nod$k_headnode):
	buf='';
	goto common_2;

case(nod$k_condnode):						/* jg */

	/* Search for this language in the list */

	q = p->nod$a_typeinfo2->nod$a_flink;
	do while (^process_conditional & q->nod$b_type = nod$k_objnode);
	    if q->nod$t_name = lang_name then process_conditional = true;
	    q = q->nod$a_flink;
	end;

	/*
	 * If this language has been found, then children will be processed
	 * at common_2 at the same level.
	 *
	 * Process a comment attached to IFLANGUAGE only if for this language.
	 */
	if process_conditional then goto common;
	else goto common_2;

case(nod$k_litnode):						/* jg */

	/* Process literal node */

	buf = p->nod$a_typeinfo2->based_string;
	goto common;

common:
	if p->nod$a_comment^=null() & sdl$v_comment_opt 
	then  do;
		if buf ^= '' then
			buf = fill(buf,40);
		buf=buf||'! '||p->nod$a_comment->based_string;
		if length(buf)>line_length then
			buf=substr(buf,1,line_length);
		end;
	call sdl$putline (outfile, buf,line_length);
	buf='';
common_2:
	if process_conditional then do;				/* jg */
	    process_conditional = false;
	    call outputnode(p->nod$a_child->nod$a_flink,p->nod$a_child,
				level);
	    end;

	else if p->nod$a_child^=null() & p->nod$b_type ^= nod$k_condnode then
	    call outputnode(p->nod$a_child->nod$a_flink,p->nod$a_child,
		level+1);
common_3:
	p = p->nod$a_flink;
	end;
    return;

outputspell : procedure (initp, startp, separator_proc, default_flag)
		returns (fixed bin);

/*
 * Procedure to output parameter spelling within list
 *
 *    parameters:
 *		initp	= address of node to output
 *
 *		startp	= address of where to stop on outputting list
 *
 *		separator_proc	= procedure to supply separator
 *
 *		default_flag = boolean for default parm values or not
 */

dcl (initp,p,startp) pointer;
dcl separator_proc entry (pointer, fixed bin) returns (char (32) var);
dcl default_flag bit;
dcl list_length fixed bin;
dcl separator char (32) var;
dcl opt_count fixed bin;  /* count of optional parameters */

/* Loop on input name list */
	p = initp;
	list_length = 0;
 
	optional_flag = false;	/* initialize the optional flag */
	opt_count = 0;		/* and the count for this entry */

	do while (p^=startp);
	  /* get separator and append name */
	  separator = separator_proc (p, list_length);
 
/*	  If the parameter is an optional parameter then increment the count*/
	  if p->nod$v_optional then opt_count=opt_count +1; 

	  if ^default_flag & p->nod$v_optional
	  then do;
		call sdl$putline (outfile, buf,line_length);
		buf = tab2 || '%IF NOT %NULL ('	|| p->nod$t_name || ') %THEN ';
		end;
	  buf = buf || separator || p->nod$t_name;
	  if ^ default_flag & p->nod$v_optional
	  then do;
		buf = buf || ' %FI';
		call sdl$putline (outfile, buf,line_length);
		buf = tab2;
		end;		
	  /* add default value, individually if given */
	  if default_flag & ^p->nod$v_optional
	  then if p->nod$v_default then
		buf = buf || '=' || trim(p->nod$l_initial);
	    else if p->nod$v_optional then buf = buf || '=0';    /* default default */
	  list_length = list_length + 1;  /* keep list count */
	  p = p->nod$a_flink;
	  end;
	
/*	Check the optional count and set the optional flag */
	if opt_count ^= 0 then optional_flag = true;
	else optional_flag = false;

	return (list_length);

end outputspell;

comma_proc : procedure (p,i) returns (char (32)var);
dcl p pointer;
dcl i fixed bin;

/* just return comma within list */
	if length (buf) > 60
	  then do;
		call sdl$putline (outfile, buf, line_length);
		buf = tab2;
		end;
	if i ^= 0 then return(',');
	else return ('');

end comma_proc;

put_complex_definitions:  proc (p);
/*
 * This routine puts out the appropriate macros and constants
 * to define the real and imaginary components of the COMPLEX
 * data type specified in p->nod$w_datatype.
 */

dcl (p,q) pointer;
dcl module_name_trunc char (128) var;
dcl size_tag char (2);

    q = p;
    size_tag = '';
    module_name_trunc = module_name;

   /*
    * To ensure that names generated by this routine are
    * less than or equal to 31 characters in length:
    */
    if length(module_name_trunc) > 13 then
	module_name_trunc = substr(module_name_trunc, 1, 13);

    if substr(module_name_trunc, 1, 1) < 'a' then
	size_tag = 'S_';
    else
	size_tag = 's_';
    select (q->nod$w_datatype);
	when (typ$k_float_complex) do;
	    f_complex_flag = true;
	    call sdl$putline (outfile, ' ', line_length);
	    call sdl$putline (outfile, '%if not %declared(%quote SDL$' || module_name_trunc || '_F_REAL_PART) %then',
			      line_length);
	    call sdl$putline (outfile, '! Definition of components of F_FLOATING COMPLEX data type',
			      line_length);
	    call sdl$putline (outfile, '!', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_F_REAL_PART = 0,0,32,0 %;', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_F_IMAG_PART = 4,0,32,0 %;', line_length);
	    call sdl$putline (outfile, '%fi', line_length);
	    call sdl$putline (outfile, ' ', line_length);
	    end;
	when (typ$k_double_complex) do;
	    d_complex_flag = true;
	    call sdl$putline (outfile, ' ', line_length);
	    call sdl$putline (outfile, '%if not %declared(%quote SDL$' || module_name_trunc || '_D_REAL_PART) %then',
			      line_length);
	    call sdl$putline (outfile, '! Definition of components of D_FLOATING COMPLEX data type',
			      line_length);
	    call sdl$putline (outfile, '!', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_D_REAL_PART = 0,0,0,0 %;', line_length);
	    call sdl$putline (outfile, 'literal SDL$' || size_tag || module_name_trunc || '_D_REAL_PART = 8;', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_D_IMAG_PART = 8,0,0,0 %;', line_length);
	    call sdl$putline (outfile, 'literal SDL$' || size_tag || module_name_trunc || '_D_IMAG_PART = 8;', line_length);
	    call sdl$putline (outfile, '%fi', line_length);
	    call sdl$putline (outfile, ' ', line_length);
	    end;
	when (typ$k_grand_complex) do;
	    g_complex_flag = true;
	    call sdl$putline (outfile, ' ', line_length);
	    call sdl$putline (outfile, '%if not %declared(%quote SDL$' || module_name_trunc || '_G_REAL_PART) %then',
			      line_length);
	    call sdl$putline (outfile, '! Definition of components of G_FLOATING COMPLEX data type',
			      line_length);
	    call sdl$putline (outfile, '!', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_G_REAL_PART = 0,0,0,0 %;', line_length);
	    call sdl$putline (outfile, 'literal SDL$' || size_tag || module_name_trunc || '_G_REAL_PART = 8;', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_G_IMAG_PART = 8,0,0,0 %;', line_length);
	    call sdl$putline (outfile, 'literal SDL$' || size_tag || module_name_trunc || '_G_IMAG_PART = 8;', line_length);
	    call sdl$putline (outfile, '%fi', line_length);
	    call sdl$putline (outfile, ' ', line_length);
	    end;
	when (typ$k_huge_complex) do;
	    h_complex_flag = true;
	    call sdl$putline (outfile, ' ', line_length);
	    call sdl$putline (outfile, '%if not %declared(%quote SDL$' || module_name_trunc || '_H_REAL_PART) %then',
			      line_length);
	    call sdl$putline (outfile, '! Definition of components of H_FLOATING COMPLEX data type',
			      line_length);
	    call sdl$putline (outfile, '!', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_H_REAL_PART = 0,0,0,0 %;', line_length);
	    call sdl$putline (outfile, 'literal SDL$' || size_tag || module_name_trunc || '_H_REAL_PART = 16;', line_length);
	    call sdl$putline (outfile, 'macro SDL$' || module_name_trunc || '_H_IMAG_PART = 16,0,0,0 %;', line_length);
	    call sdl$putline (outfile, 'literal SDL$' || size_tag || module_name_trunc || '_H_IMAG_PART = 16;', line_length);
	    call sdl$putline (outfile, '%fi', line_length);
	    call sdl$putline (outfile, ' ', line_length);
	    end;
	otherwise do;
	    call errmsg (sdl$_shr_data, sdl$_bugcheck, q->nod$l_srcline, );
	    goto exit;
	    end;
    end; /* select */

end put_complex_definitions;

put_opt_kwmacro:   proc (initp, startp);
/*
 * This routine puts out the KEYWORDMACRO which handles the optional
 * parameters.
 *
 *
 *	initp		address of node to output
 *	startp 	 	address of where to stop on outputting list
*/
 
dcl (p, initp, startp) pointer;
dcl line_limit fixed bin(31) ;     /* line length limits for parameter lists */
dcl doing_req bit(1) init('0'b);   /* used to make the output pretty	     */

/* Initialize the buffers */

/* Loop on input name list */ 
    p = initp;
    line_limit = 60 ;  /* number of characters per line */
    buf = tab || '   ' || buf||'SDL$'||module_name||'_CONCAT( ' ;
 
    do while (p^=startp);

	if( p->nod$v_default )	    /* if its a default parameter  */
	then
	    buf = buf || p->nod$t_name ;
	else
	if( p->nod$v_list )	    /* if its a LIST parameter     */
	then
	    if p->nod$v_optional then
	        buf = buf || 'SDL$'||module_name||'_LIST_0_REQ(' || p->nod$t_name || ')';
	    else
		buf = buf || 'SDL$'||module_name||'_LIST_1_REQ(' || p->nod$t_name || ', %QUOTE ' || p->nod$t_name || ')';
	else
	if (^p->nod$v_optional &    /* if its a required parameter */
	    ^p->nod$v_default  & 
	    ^p->nod$v_list )
	then do;
	   doing_req = '1'b;	    /* this is used to line up parameters */
				    /* nice and pretty			  */
	   buf = buf || 'SDL$'||module_name||'_REQ(' || p->nod$t_name||
		 ', %QUOTE '|| P->nod$t_name|| ') ';  
	end;
	else
	if( p->nod$v_optional )	    /* if its a OPTIONAL parameter           */
	then do;
	    buf = buf || 'SDL$'||module_name||'_OPT( ' || p->nod$t_name;
	    p = p->nod$a_flink;
	    /*
	     * all consecutive OPTIONAL parameters go in the same macro.
	     */
	    do while( p->nod$v_optional ) ;
		buf = buf || ', ' || p->nod$t_name ;
		p = p->nod$a_flink;
	    end;
	    p = p->nod$a_blink;	    /* set to current parameter */
	    buf = buf || ')';
	end;


	/*
	 * if no more parameters then put out the last line and close everything
	 * off with the double parens. otherwise append a coma so we are ready
	 * for the next parameter. And if the line limit has been reached 
	 * then output the buffer. Or if the there is a required parameter 
	 * followed by an OPTIONAL parameter then output the buffer ( this is
	 * done so the the declaration looks NICE. 
	 */
	if( p->nod$a_flink = startp )	
	then
	    call sdl$putline (outfile, buf||'))', line_length);
	else do;
	    buf = buf || ', ';
	    if( length(buf) > line_limit  |  (doing_req & p->nod$a_flink->nod$v_optional) )
	    then do;
		call sdl$putline (outfile, buf, line_length);
		buf = tab || '   ';
		doing_req = '0'b;
	    end;
	end;

	p = p->nod$a_flink;   /* next parameter (if any)*/

   end; 

call sdl$putline (outfile,  '   '||'END %;', line_length);
buf= '';

return;
end put_opt_kwmacro ;

 
optmacro:	proc ;

%replace opt_macro_len by 57;	/* # of lines in the macro to be output */

declare j fixed;
dcl optional_macro (opt_macro_len) char(128) var init(
'%if not %declared(%quote SDL$'||module_name||'_REQ) %then',
'! MACRO to emit warning and default to 0 if required argument is missing',
'!',
'macro',
'SDL$'||module_name||'_REQ(ARG1, arg2) =',
'    %IF not %NULL(ARG1) %THEN ARG1',
'    %else',
'	%warn(%string(''REQUIRED ARGUMENT '', %NAME(ARG2), '' MISSING'')) 0',
'    %FI %;',
'%fi',
' ',
'%if not %declared(%quote SDL$'||module_name||'_OPT) %then',
'! Defaults omitted arguments to 0 if followed by additional arguments',
'!',
'macro',
'SDL$'||module_name||'_OPT[ARG] =',
'    %IF %NULL(ARG)',
'    %THEN',
'	%IF NOT %NULL(%REMAINING)',
'	%THEN',
'	    0',
'	%FI',
'    %ELSE',
'	ARG',
'    %FI %;',
'%fi',
' ',
'%if not %declared(%quote SDL$'||module_name||'_LIST_0_REQ) %then',
'! Handles LIST parameters that are also OPTIONAL',
'!',
'macro',
'SDL$'||module_name||'_LIST_0_REQ(ARG) =',
'    %IF NOT %NULL(ARG) %THEN %REMOVE(ARG) %FI %;',
'%fi',
' ',
'%if not %declared(%quote SDL$'||module_name||'_LIST_1_REQ) %then',
'! Handles LIST parameters that are not OPTIONAL',
'! Emits warning and defaults to 0 if required argument is missing',
'!',
'macro',
'SDL$'||module_name||'_LIST_1_REQ(ARG, ARG2) =',
'    %IF %NULL(ARG) %THEN',
'	 %warn(%string(''REQUIRED ARGUMENT '', %NAME(ARG2), '' MISSING'')) 0',
'    %ELSE',
'        SDL$'||module_name||'_LIST_0_REQ(ARG) %FI %;',
'%fi',
' ',
'%if not %declared(%quote SDL$'||module_name||'_CONCAT) %then',
'! Eliminates trailing null arguments',
'!',
'macro',
'SDL$'||module_name||'_CONCAT[ARG] =',
'    %IF NOT %NULL(ARG) %THEN ARG %FI %;',
'%fi',
' ',
'!             ***********************************	',
' ');
dcl i fixed;
do i =1 to opt_macro_len;
   buf = optional_macro (i);
   call sdl$putline (outfile, buf, line_length);	/* put out a line of the macro*/
end;

return;
end optmacro;
 
 
end outputnode;
 
end sdl$output;