/*
*****************************************************************************
*									    *
*  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.
________________|_______|______________________________________________________
*/
%replace MODULE_IDENT by 'EV1-21';


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:filedef.in';      /* rms file definitions */

/* 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;

/* Declare variables needed for getting a fully resolved file specification.
   The resolved file specification will be recorded as a dependency for
   the VDE system builder through the LIB$REC_DEPENDENCY interface.
 */
        dcl vde_filename char(128) var
                        init ('');      /* input source file name */
        dcl vde_input_file file variable static;
        dcl vde_in_file pointer initial(addr(vde_input_file));
        dcl vde_in_file_ptr pointer based (vde_in_file);
        dcl vde_esa_area char(120) static;
        dcl vde_addr_esa_area pointer initial(addr(vde_esa_area));
        dcl vde_rsa_area char(120) static;
        dcl vde_addr_rsa_area pointer initial(addr(vde_rsa_area));

        dcl vde_full_name pointer;
        dcl vde_result_name char(132) based (vde_full_name) ;

/*** 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;

    sdl$v_b64_opt = true;
    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,,(out_file||lang_ext));
	    goto exit;
	end;

/* Set up file structures for receiving the fully resolved language specific
   output file from the open call. The fully resolved output file, file
   specification is passed back to the front end through the variable
   vde_lang_file which is declared in the shared data area (SDLSHR.SDL).
*/
        vde_input_file = output_file;
        vde_in_file_ptr->nam$l_esa = vde_addr_esa_area;
        vde_in_file_ptr->nam$b_ess = 120;
        vde_in_file_ptr->nam$l_rsa = vde_addr_rsa_area;
        vde_in_file_ptr->nam$b_rss = 120;
  
	/* 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) );
	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_full_name = vde_in_file_ptr->nam$l_rsa;  
        vde_filename = vde_result_name;
	vde_lang_file =	substr( vde_result_name, 1, vde_in_file_ptr->nam$b_rsl);

	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;