/*
 *****************************************************************************
 *                                                                           *
 * Copyright 1978 Compaq Computer Corporation                                *
 *                                                                           *
 * Compaq and the Compaq logo Registered in U.S. Patent and Trademark Office.*
 *                                                                           *
 * Confidential computer software. Valid license from Compaq required for    *
 * possession, use or copying. Consistent with FAR 12.211 and 12.212,        *
 * Commercial Computer Software, Computer Software Documentation, and        *
 * Technical Data for Commercial Items are licensed to the U.S. Government   *
 * under vendors standard commercial license.                                *
 *                                                                           *
 *****************************************************************************

facility:

	SDL (Structure Definition Language)


author:
	Paul A. Calato

*/

/*			C H A N G E    L O G

      Date	! Name	! Description
________________!_______!______________________________________________________
   		!  	! 					
    23-Nov-1985	|  pc	| Adding copyright header and change log.
________________!_______!______________________________________________________
    15-Apr-1986	|  pc	| adding support specification of lower bounds on dimensions
________________!_______!______________________________________________________
    13-May-1987	|  jw	| X3.1-0 Added check for CHARACTER LENGTH * in
		|	|	 anticipation of future support for LENGTH * in
		|	|	 a context other than that of a parameter.
________________!_______!______________________________________________________
    18-Oct-1994	|  RC	| EV1-40 Fix setting of struc_ref flag.
________________!_______!______________________________________________________
     8-Dec-2000	|  LJK	| EV1-65  Change copyright notice to Compaq format.
________________|_______|______________________________________________________
*/


/****************************************************************/
/*								*/
/* SPECIAL_CHECKS checks for special cases in simple items.	*/
/* for example dimensions, string lenght etc.			*/
/*								*/
/****************************************************************/

special_checks: proc (cur_node,level,dim,dec,strn_len,struc_ref);

					    /********************/
					    /*			*/
					    /* SPECIAL_CHECKS	*/
					    /*			*/
					    /********************/
%include 'sdl$library:sdlshr.in';
%include 'sdl$library:sdlnodef.in';
%include 'sdl$library:sdltypdef.in';

/* declare variables */
declare
    cur_node pointer,			    /* pointer to the current node  */
    level fixed binary(31),		    /* level in the aggregate	    */
    dim char(*) var,			    /* dimension, if any	    */
    dec char(*) var,			    /* declaritive		    */
    strn_len char(*) var,		    /* string length		    */
    global_opt bit(1) ext,		    /* global option flag on comand line */
    struc_ref bit(1);			    /* structure reference flag	    */


	if( level = 1 )
	then do;
	    if( cur_node->nod$v_global )
	    then
		dec = 'EXTERNAL ';
	    else
	    if( cur_node->nod$v_common )
	    then
		dec = 'COMMON ';
	    else
		dec = 'DECLARE ';
	end;

	if( cur_node->nod$v_global & global_opt )
	then
	   /*********** change to system call *************/
	    put skip list ('*** ERROR - Basic does not support global definitions');


	if( cur_node->nod$w_datatype = typ$k_char )
	then do;
	    if cur_node->nod$l_typeinfo = sdl$k_unknown_length then
		strn_len = '';
	    else
		strn_len = ' = ' || trim(cur_node->nod$l_typeinfo) ;
	    if( level = 1 )
	    then
		dec = 'COMMON ';
	end;

	if( cur_node->nod$v_dimen )
	then do;
	    dim = '(';

	    if( cur_node->nod$l_lodim ^= 0 )
	    then
		dim = dim || trim(cur_node->nod$l_lodim) || ' to ';

	    dim = dim || trim(cur_node->nod$l_hidim) || ')' ;
	end;




/*
 * if this item's data type is a structure reference set the
 * structure reference flag. ( a structure reference is similar to 
 * the "LIKE" attribute in pli )
*/
    if( (cur_node->nod$w_datatype = typ$k_union | 
	 cur_node->nod$w_datatype = typ$k_structure) &
         cur_node->nod$a_typeinfo2 ^= null() 
      )
    then
/*
 * EV1-40 RC
 *  Original code was:
 *	if( cur_node->nod$a_typeinfo2->nod$b_type = nod$k_typnode )
 *  but nod$k_typnode seems to have been replaced by nod$k_itemnode, somewhere
 *  between EV1-0 and EV1-39.  Unfortunately, the other SDL backends don't seem
 *  to agree as to what the correct test should be.  Let's try this:
 */
	if ( ^cur_node->nod$v_bound )
	then
	    struc_ref = '1'b;



end special_checks;