/* ***************************************************************************** * * * Copyright (c) 1978-1992 * * 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 C language output from the SDL tree. author: C.T. Pacy date: revised 22-DEC-1980 ctp revised 30-JUN-1982 ls version 1.5 changes revised 15-SUG-1982 ls version 1.6 changes revised 04-OCT-1982 ls version 1.7 changes revised 30-NOV-1982 ls add comments flag revised 18-Jan-1984 kd make changes necessary for V2. Make backens into shareable images. revised 2-Aug-1984 kd Add ident field (1.0) revised 13-Feb-1990 William R. Vales Make changes to record Robert Thomson dependency data for VMS VDE system builder. (see CHANGE LOG) revised 5-Feb-1992 sdd Generate mask constants differently (and fix bit 31 bug) revised 12-Mar-1993 rs Made changes for VMS C project C H A N G E L O G Date | Name | Description ________________|_______|______________________________________________________ 28-Jan-1985 | kd | 2-1 Add new ident, fix problem with FILL not | | being generated in output. ________________|_______|______________________________________________________ 13-Feb-1985 | kd | 2-2 Fix problem with BASED pointer. ________________|_______|______________________________________________________ 6-Jun-1985 | kd | 2-3 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. ________________|_______|______________________________________________________ 6-Jan-1986 | pc | V3.0 Change OUTPUTNODE to use a DO WHILE loop rather | | than have it be recursive. ________________|_______|______________________________________________________ 19-Mar-1987 | jgw | T3.1-0 Initialize the output buffer (buf) to '' in | | the outer-level declaration. ________________|_______|______________________________________________________ 01-May-1987 | jgw | X3.1-1 Add handling of COMPLEX data types. | | Also, change version to "X" and bump level. ________________|_______|______________________________________________________ 17-May-1987 | jgw | X3.1-2 Put out comma after "arraystuff" in return | | struct for entries which have return values | | which are structs (i.e., scalar types normally | | output as arrays in C but returned as structs | | since we can't return arrays); this fix | | prevents a warning generated by the C compiler ________________|_______|______________________________________________________ 19-Jun-1987 | jgw | X3.1-3 Initialize an auxiliary output buffer (buf2) | | to '' in the outer-level declaration. ________________|_______|______________________________________________________ 11-Dec-1987 | jgw | V3.1-4 Fixed bug involving aggregate members declared | | to be of the type of a previously-defined | | union. ________________|_______|______________________________________________________ 11-Jan-1988 | PG | X3.2-0 Add CONSTANT strings ________________|_______|______________________________________________________ 11-Jan-1988 | jg | X3.2-1 Implement user-defined types. | | Add void type. ________________|_______|______________________________________________________ 18-Feb-1988 | jg | X3.2-2 Add support for conditional compilation and | | LITERAL. ________________|_______|______________________________________________________ 24-Feb-1988 | jg | X3.2-3 Fix bug which can cause ACCVIO in puttype | | when data type is zero as a result of a | | syntax error. ACCVIO is caused by attempt | | to access types(0). This is actually only | | seen when compiling for certain combinations | | of languages, due to prevailing random | | contents of memory. ________________|_______|______________________________________________________ 28-Apr-1988 | jg | X3.2-4 Internal references to structures (_foo) | | must be prefixed struct. ________________|_______|______________________________________________________ 27-Oct-1988 | jgw | V3.2-0 Generate name[] for DIMENSION *, not name[1]. ________________|_______|______________________________________________________ 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. ________________|_______|______________________________________________________ 29-May-1991 | AWF | X3.2-6 Have LONGWORD generate "int" instead of | | "long int". "long int" generates a 64 bit | | variable. ________________|_______|______________________________________________________ 5-Dec-1991 | AWF | X3.2-7 Fix handling of POINTER* and INTEGER* | | declarations. Modified the types table so | | it makes sense. ________________|_______|______________________________________________________ 5-Feb-1992 | SDD | X3.2-8 Mask constants now generate the hex values | | created by the front end. ________________|_______|______________________________________________________ 1-Apr-1992 | jak | EV1-3 Added #pragma nomember_alignment/#pragma member_alignment. ________________|_______|______________________________________________________ 02-Apr-1992 | JEZ | X3.2-0 Make minor changes needed by DEC C for | | building STARLET files. ________________|_______|______________________________________________________ 2-May-1992 | jak | EV1-8 Changed alignment pragmas to save/restore. | | Merged the above changes into this version. ________________|_______|______________________________________________________ 8-May-1992 | jak | EV1-9 Changed the way alignment pragmas are put out. ________________|_______|______________________________________________________ 8-May-1992 | jak | EV1-10 More changes for C_DEVELOPMENT. ________________|_______|______________________________________________________ 20-May-1992 | jak | EV1-10 Changed "double float" to just "double". | | Changed PUT to split long lines with a backslash. | | Set hardware dependent types to 64-bits if | | /ALPHA, else just 32-bit. | | Backed out partial implementation of POINTER* as | | a C pointer type --- they are just different sized | | integers. | | Removed struct_level arg to outputnode: redundant with level. | | Put out "variant_" if /ALPHA and ... | | Added revision checks. ________________|_______|______________________________________________________ 27-May-1992 | jak | EV1-11 Lowercase name for CHAR[0] special case ________________|_______|______________________________________________________ 3-Jun-92 | jak | EV1-11 Bug fix at "COMMON:". Was losing comment lines. ________________|_______|______________________________________________________ 11-Jun-92 | jak | EV1-14 Remove "v_generated" as a condition of "variant". | | Fill unions were not getting "variant". ________________|_______|______________________________________________________ 15-Jun-92 | jak | EV1-14 Confined use of variant_struct/union to just | | "c_development & level > 1". Too many problems. ________________|_______|______________________________________________________ 20-JUl-92 | jak | EV1-17 Moved test for unsigned. | | Was emitting "unsigned" with typedef references. | | SDLACTION probably shouldn't be setting NOD$V_UNSIGNED | | when data type is TYP$K_USER, but for now this fixes the | | problem for C without endangering other backends. ________________|_______|______________________________________________________ 21-Jan-93 | jak | EV1-20 Added support for POINTER objects. ________________|_______|______________________________________________________ 2-Feb-93 | jak | EV1-21 In case OBJNODE of outputnode, use name from | | type node rather than object node. ________________|_______|______________________________________________________ 12-Mar-1993 | rs | EV1-22 Made changes for the VMS C project described | | in the LIB.H proposal written by Lenny S. | | All these changes are only enabled if | | the VMS_DEVELOPMENT qualifier is on and | | the C_DEVELOPMENT qualifier is not on. ----------------|-------|------------------------------------------------------ 29-Mar-93 | rs | EV1-22 Changed the way field definitions are | | created if the field is more than 32 bits and | | this is a user fill. It now splits the fields | | into multiple definitions that add up to | | the larger bit field length. ----------------|-------|------------------------------------------------------ 6-Apr-1993 | rs | EV1-22 word_integer was using word as a type. This | | doesn't exist for C. Changed it to short int ----------------|-------|------------------------------------------------------ 8-Apr-1993 | rs | EV1-23 Added a #ifndef VAXC check around the member | | defines for VMS_DEVELOPMENT. Also added new | | member defines for intermediate structures | | and unions for non fills to match bliss and | | VAX/Macro output - again for VMS_DEVELOPMENT | | only. ----------------|-------|------------------------------------------------------ 6-May-1993 | rs | EV1-25 Don't do member_define's for members that | | were put out as #defines themselves because | | they were aliases to another field | | (0 length character strings). Also don't | | assume typ$k_user types are externals. | | If we have typeinfo2 information saying | | it is an item node define it with that | | item name instead of "struct _xxx" where | | xxx is the user type. ----------------|-------|------------------------------------------------------ 27-May-1993 | rs | EV1-26 Define the __unknown_params symbol since | | it is needed when vms_development is set ----------------|-------|------------------------------------------------------ 3-Jun-1993 | rs | EV1-27 Increase the space used to put out the | | member defines since some were getting | | truncated. ----------------|-------|------------------------------------------------------ 16-Jun-1993 | rs | EV1-28 Fixed the bug for regular SDL where it was | | generating char[] for empty alignment | | fields. Also took care of the case where | | the alignment fill at the end of a struct | | to print a warning in the output comments | | and not define the illegal char[]. ----------------|-------|------------------------------------------------------ 23-Jun-1993 | rs | EV1-28 Fix bug in the above checkin. Instead of | | removing the empty char field outright, put | | it in for the #ifdef __VAXC case and remove | | it for all other cases. Also changed other | | #ifndef VAXC to @ifndef __VAXC. ----------------|-------|------------------------------------------------------ 8-Jul-1993 | rs | EV1-28 Fix bug in above checkin. The VAXC compiler | | defines the symbol VAXC but not __VAXC so | | the #ifdefs and #ifndefs needed to be changed | | to handle both. ----------------|-------|------------------------------------------------------ 14-Jul-1993 | rs | EV1-29 Fix a bug in generating quadwords when the | | /VAX qualifier is set. It should always use | | the int x[2] form instead of __int64 since | | VAXC doesn't handle the latter. ----------------|-------|------------------------------------------------------ 19-Jul-1993 | rs | EV1-29 Fix bug in last checkin. Need to use [2] | | only when the VAX qualifier is specified. | | Since /ALPHA is the default, if none | | is specified, it must not be VAX. ----------------|-------|------------------------------------------------------ 20-Jul-1993 | rs | EV1-29 Subtle problem with the above fix. The | | quadword and cc_opt case should be treated | | as int x[2]. ----------------|-------|------------------------------------------------------ 23-Jul-1993 | rs | EV1-29 Fix this int64 thing again. It's driving me | | crazy but I think I got it this time!! | | Famous last words.... ----------------|-------|------------------------------------------------------ 22-Sep-1993 | am | EV1-30 Added BASEALIGN support to make use of | | the new alignment parameter in the | | member_align pragme. ----------------|-------|------------------------------------------------------ 07-Oct-1993 | am | EV1-31 Fixed BASEALIGN support. ----------------|-------|------------------------------------------------------ 11-Oct-1993 | am | EV1-31 Fixed BASEALIGN support.......again ----------------|-------|------------------------------------------------------ 11-Oct-1993 | am | EV1-31 Fixed BASEALIGN support.......last time! ----------------|-------|------------------------------------------------------ 8-Nov-1993 | am | EV1-32 Added logic to account for typedefs read in | | from an sdi file. These are itme nodes and have the | | nod$v_declared and nod$v_typedef bits set. ----------------|-------|------------------------------------------------------ 9-Nov-1993 | am | EV1-33 Added logic to fix QAR 2638. With the /VAXC | | option to the compiler we will now use | | variant_struct and variant union when /VMS | | option is supplied to SDL. ----------------|-------|------------------------------------------------------ 4-May-1994 | am | EV1-35 Added enhancements for ZETA release: | | - remove any $ from _LOADED symbols | | - change pragmas and symbol names to | | __names | | - generate C++ structure prototypes for | | references to tag names | | - fix problem with #defines generated for | | arrays of structures | | - create #defines for functions to convert | | the names to uppercase 7-Jun-1994 | am | EV1-36 Fixed EVMS-ZETA QAR 1250 | | - 32 bit pointers were being generated for | | pointer_quad and pointer_hw if object type | | was specified. Modified code to output | | __int64 in these cases. 30-Aug-1994 | am | EV1-37 Added Theta support | | - create LIB-like structures with typedefs | | for STARLET header files (/C_DEV qualifier) | | while still maintaining a backward compatible | | version of the structure | | - added support for function prototypes 31-Aug-1994 | am | EV1-38 Fix problem with pointers to entries not | | being generated properly. 1-Sep-1994 | am | EV1-39 Fixed a couple more problems. ----------------|-------|------------------------------------------------------ */ %replace MODULE_IDENT by 'EV1-39'; sdl$output: proc (out_file, def_filename, 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 lang_ext by '.h'; /* C extension for include files */ %replace lang_name by 'CC'; /* Language name for conditional - jg */ %replace true by '1'b; %replace false by '0'b; %replace new_entry by 1; %replace old_entry by 2; /* LOCALS */ dcl types(37) char (32) var; types(typ$k_address) = ''; types(typ$k_byte) = 'char '; types(typ$k_char) = 'char '; types(typ$k_boolean) = 'char '; types(typ$k_decimal) = 'char '; types(typ$k_double) = 'double '; types(typ$k_float) = 'float '; types(typ$k_grand) = 'double '; types(typ$k_huge) = 'int '; types(typ$k_longword) = 'int '; types(typ$k_octaword) = 'int '; if sdl$v_vms_opt & ^sdl$v_cc_opt & sdl$v_alpha_opt then types(typ$k_quadword) = '__int64 '; else types(typ$k_quadword) = 'int '; types(typ$k_vield) = 'unsigned '; types(typ$k_word) = 'short int '; types(typ$k_structure) = 'struct '; types(typ$k_union) = 'union '; types(typ$k_any) = 'unsigned int '; types(typ$k_entry) = ''; types(typ$k_double_complex) = 'double '; types(typ$k_float_complex) = 'float '; types(typ$k_grand_complex) = 'double '; types(typ$k_huge_complex) = 'int '; types(typ$k_user) = ''; types(typ$k_void) = 'void '; types(typ$k_integer) = 'int '; if sdl$v_alpha_opt then do; types(typ$k_hardware_address) = '__int64 '; types(typ$k_hardware_integer) = '__int64 '; types(typ$k_pointer_hw) = '__int64 '; types(typ$k_integer_hw) = '__int64 '; end; else do; types(typ$k_hardware_address) = 'int '; types(typ$k_hardware_integer) = 'int '; types(typ$k_pointer_hw) = 'int '; types(typ$k_integer_hw) = 'int '; end; if sdl$v_vms_opt & ^sdl$v_cc_opt then do; types(typ$k_pointer_long) = ''; types(typ$k_pointer) = ''; end; else do; types(typ$k_pointer_long) = 'int '; types(typ$k_pointer) = 'int '; end; if sdl$v_alpha_opt then do; types(typ$k_pointer_quad) = '__int64 '; types(typ$k_integer_quad) = '__int64 '; end; else do; types(typ$k_pointer_quad) = 'int '; types(typ$k_integer_quad) = 'int '; end; types(typ$k_integer_byte) = 'char '; types(typ$k_integer_word) = 'short int '; types(typ$k_integer_long) = 'int '; dcl out_file char(128) var ; dcl def_filename char(132) var; dcl output_file file output record sequential; dcl buf char(1024) var init(''); dcl based_string char(1024) var based; dcl (i,j) fixed bin(31); dcl buf2 char(128) var init (''); dcl retcnt fixed bin static init (0); dcl tab char initial (byte(9)); dcl process_conditional bit init (false); /* jg */ /* 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. */ %if 0 %then %do; 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) ; %end; dcl in_module bit(1) aligned init (false); dcl module_name char(128) var init (''); dcl c_development bit(1) aligned init(false); dcl vms_development bit(1) aligned init(false); dcl upper_alpha char(26) static readonly init('ABCDEFGHIJKLMNOPQRSTUVWXYZ'); dcl lower_alpha char(26) static readonly init('abcdefghijklmnopqrstuvwxyz'); /* jak EV1-9 */ %replace MEMBER_ALIGNMENT_OFF by -1; %replace MEMBER_ALIGNMENT_UNKNOWN by 0; %replace MEMBER_ALIGNMENT_ON by 1; %replace BASEALIGN_BYTE by 0; %replace BASEALIGN_WORD by 1; %replace BASEALIGN_LONGWORD by 2; %replace BASEALIGN_QUADWORD by 3; %replace BASEALIGN_OCTAWORD by 4; dcl do_alignment_pragmas bit(1) aligned static; dcl align_state fixed bin(15) static init(MEMBER_ALIGNMENT_UNKNOWN); dcl member_seen bit(1) aligned; dcl define_member_protos bit(1) aligned; dcl basealign fixed bin(31); dcl basealign_boundary fixed bin(31) static init(BASEALIGN_BYTE); dcl processing_new_starlet bit(1) aligned; dcl processing_old_starlet bit(1) aligned; dcl changed_typedef bit(1) aligned; dcl changed_ptrtype bit(1) aligned; dcl changed_datatype bit(1) aligned; dcl saved_ptr pointer; dcl saved_typeinfo2 pointer; dcl savep pointer; dcl checkp pointer; /*** 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; c_development = sdl$v_cc_opt; /* /C_DEVELOPMENT qualifier */ vms_development = sdl$v_vms_opt & ^sdl$v_cc_opt; /* /VMS_DEVELOPMENT qualifier */ do_alignment_pragmas = sdl$v_alpha_opt; /* only do if /ALPHA and ^/VAX */ /* jak EV1-9 */ /* Initialize for Starlet header file procesing */ if c_development then do; processing_new_starlet = true; processing_old_starlet = false; changed_datatype = false; changed_ptrtype = false; end; outfile = output_file; /* equate the file with the file variable in the shared structure */ 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). */ %if 0 %then %do; vde_input_file = output_file; /* set up name block */ 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; %end; if ^c_development & ^vms_development then do; /* open up the output file */ /* concatenate the extension for the language */ open file(output_file) title(out_file) environment( default_file_name(def_filename||lang_ext) ); call sdl$header(sdl$_shr_data, '/*', '*/', line_length ); end; call outputnode(tree_root->nod$a_flink,tree_root,0); call finish_module; %if 0 %then %do; 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); %end; close file(output_file); exit: return; /** print node routine **/ outputnode: proc (initp,startp,level) recursive; dcl (initp,p,p1,startp,q) ptr; dcl level fixed bin(31); dcl offset fixed bin(31); dcl (temp,temp2) char (128) var; dcl msg char (132) var; dcl vield_size fixed bin(31); dcl vield_component fixed bin(31); dcl ind fixed bin(31); dcl restore_extern_model bit(1); dcl first_time_through bit(1); declare definedProtoNames(50) char(256) var; declare realStarletTypedefs(50) ptr; declare starletTypedefIndex fixed bin(31); declare realType bit(1); declare processing_optional_parms bit(1); restore_extern_model = false; processing_optional_parms=false; starletTypedefIndex = 0; p = initp; do while (p^=startp); goto case(p->nod$b_type); case(nod$k_rootnode): buf=''; goto common_3; case(nod$k_commnode): buf=''; goto common; case(nod$k_constnode): buf='#define '||to_upper(p->nod$t_name)||' '; if p->nod$w_datatype = typ$k_char then do; temp=p->nod$a_typeinfo2->based_string; call sdl$cvtstr(temp, temp2, '"\"\\\'); buf=buf||'"'||temp2||'"'; end; else if p->nod$v_mask then buf=buf||'0x'||p->nod$t_maskstr; else buf=buf||trim(p->nod$l_typeinfo); goto common; case(nod$k_entrynode): if vms_development | c_development then call put('#define ' || to_lower(p->nod$t_name) || ' ' || to_upper(p->nod$t_name)); /* Create both forms of function prototypes for Starlet header files */ /* One with parameter information and one without, for backward */ /* compatibility. */ if c_development then do; call put ('#ifdef __NEW_STARLET'); call process_entrynode(new_entry); call put ('#else /* __OLD_STARLET */'); call process_entrynode(old_entry); call put ('#endif /* #ifdef __NEW_STARLET */'); end; else call process_entrynode(old_entry); goto common_3; case(nod$k_objnode): if p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union then do; call puttype(p); /* Prepend underscore if this is a reference to the top-level parent structure or union, and it has the TYPEDEF attribute. As the struct or union will have been suppressed by the TYPEDEF attribute (in puttype), put it out now. */ p1 = p->nod$a_typeinfo2; /* typed node */ if p1->nod$v_typedef then do; i = level; q = p->nod$a_parent; /* address of item */ do while (i>1); q = q->nod$a_parent; i = i-1; end; if q = p1 | vms_development then do; if p->nod$w_datatype=typ$k_structure then /* X3.2-4 */ buf = buf||'struct '; else buf = buf||'union '; if p->nod$v_base_align & align_state ^= MEMBER_ALIGNMENT_ON then do; call do_basealign_pragmas(); end; else if (basealign_boundary ^= BASEALIGN_BYTE) & (align_state ^= MEMBER_ALIGNMENT_ON) then do; call put('#pragma __nomember_alignment'); basealign_boundary = BASEALIGN_BYTE; end; buf = buf || '_' || to_lower(p1->nod$t_name) || ' '; end; else if vms_development then buf = buf || to_upper(p1->nod$t_name) || ' '; else buf = buf || to_lower(p1->nod$t_name) || ' '; end; else buf = buf || to_lower(p1->nod$t_name) || ' '; goto common_3; end; /* not a STRUCTURE or UNION */ q=p; if p->nod$w_datatype=typ$k_entry & processing_new_starlet & c_development then do; p = p->nod$a_typeinfo2->nod$a_flink; /* get entrynode that this object points to */ buf2='(' || buf2 || ')'; call put_entry_type(); /* put entry return type in buf */ if p->nod$a_child = null() then buf2 = buf2 || '(void)'; else do; /* process parameters */ call put (buf || buf2 || '('); buf2 = ''; buf = tab; call outputnode (p->nod$a_child->nod$a_flink, p->nod$a_child, level+1); buf = buf || ')'; end; end; else if p->nod$w_datatype=typ$k_entry then do; p = p->nod$a_typeinfo2->nod$a_flink; buf2='('||buf2||')'||'()'; call put_entry_type(); /* put entry return type in buf */ end; temp = arraystuff(); if p->nod$w_datatype=typ$k_address | (p->nod$v_has_object & (p->nod$w_datatype ^= typ$k_pointer_quad & p->nod$w_datatype ^= typ$k_pointer_hw)) | (vms_development & (p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long)) & q->nod$w_datatype ^= typ$k_entry then buf2='(*('||buf2||')'||temp||')'; else if temp ^= '' then buf2='('||buf2||')'||temp; p=q; if p->nod$w_datatype ^= typ$k_entry then call puttype(p); goto common_3; case(nod$k_itemnode): if p->nod$v_declared then goto common; /* ignore declaed item */ /* *** */ /* Provide backward compatible starlet structures */ /* - convert pointers to user defined types */ /* to regular pointer type. C_DEV logic */ /* will cause it to output an unsigned int */ /* *** */ if (processing_old_starlet & c_development) then if ((p->nod$w_datatype = typ$k_pointer | p->nod$w_datatype = typ$k_address) & p->nod$a_typeinfo2 ^= null() & p->nod$v_has_object) then if (p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype = typ$k_user | p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype = typ$k_structure) then do; changed_ptrtype = true; saved_ptr = p; saved_typeinfo2 = p->nod$a_typeinfo2; p->nod$v_has_object = false; p->nod$v_unsigned = true; p->nod$a_typeinfo2 = null(); end; /* Aggregates defined as unions in Starlet SDL files will be converted to structures */ /* for new_starlet processing. They will still be output as unions in old_starlet. */ /* This assumes that a union has been inserted within the aggregate to make the */ /* structure equivalent to the union. */ if (processing_new_starlet & (level = 1) & (p->nod$w_datatype = typ$k_union)) then do; changed_datatype = true; saved_ptr=p; p->nod$w_datatype = typ$k_structure; end; if (processing_new_starlet & c_development & (level = 1)) then do; if p->nod$v_typedef then do; realStarletTypedefs(starletTypedefIndex) = p; starletTypedefIndex = starletTypedefIndex + 1; end; else do; p->nod$v_typedef = true; p->nod$v_based = false; end; end; /* check if empty user fill for VMS_DEVELOPMENT */ if vms_development & p->nod$v_userfill & p->nod$l_typeinfo = 0 & p->nod$l_fldsiz = 0 & level > 1 then goto common_3; /* empty user fill, don't print it */ /* Define structure prototypes for C++, but not for backward */ /* compatible Starlet structures */ if (c_development | vms_development) & ^processing_old_starlet & level = 1 & p->nod$a_child ^= null() then do; call put(buf); buf = ''; call put(buf); define_member_protos = false; do ind = 0 to 49 by 1; definedProtoNames(ind) = ''; end; call DefineMemberProtos(p->nod$a_child->nod$a_flink,p->nod$a_child,1); end; /* Structures SDL'd with the /c_dev switch will now be created twice. */ /* (1) They will first be created in the new way - */ /* which is equivalent to using the /vms_development */ /* switch. */ /* (2) They will be created a second time doing some magic */ /* along the way to make them look identical to */ /* the old /c_development output. */ /* The definitions will be surrounded by the following conditional logic*/ /* To take advantage of the new definitions the C compiler user just */ /* has to supply /DEFINE=__NEW_STARLET to the command line. */ if (p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union) & c_development & (level=1)then if processing_new_starlet then do; call put ('#ifdef __NEW_STARLET'); processing_new_starlet = true; processing_old_starlet = false; vms_development = true; savep = p; checkp = p->nod$a_child; end; else if processing_old_starlet then do; call put('#else /* __OLD_STARLET */'); end; if do_alignment_pragmas then /* jak EV1-9 */ do; if p->nod$v_align & align_state ^= MEMBER_ALIGNMENT_ON then do; call put('#pragma __member_alignment'); align_state = MEMBER_ALIGNMENT_ON; end; else if ^p->nod$v_align then do; if p->nod$v_base_align then do; call do_basealign_pragmas(); align_state = MEMBER_ALIGNMENT_OFF; end; else if (align_state ^= MEMBER_ALIGNMENT_ON) & (basealign_boundary ^= BASEALIGN_BYTE) then do; call put('#pragma __nomember_alignment'); align_state = MEMBER_ALIGNMENT_OFF; basealign_boundary = BASEALIGN_BYTE; end; end; end; if p->nod$w_datatype = typ$k_char & p->nod$l_typeinfo = 0 & level > 1 then do; /* special case: char[] member */ /* Print the character array normally for VAXC case */ buf = '#if defined(__VAXC)'; call put(buf); buf=copy(' ',level-1); buf=buf||'char '||to_lower(p->nod$t_name)||'[];'; call put(buf); buf='#else'; call put(buf); /* print a #define or nothing for the non VAXC case */ if p->nod$a_flink ^= startp & p->nod$a_flink->nod$b_type = nod$k_itemnode then do; buf = '#define '||to_lower(p->nod$t_name)||' '||to_lower(p->nod$a_flink->nod$t_name); /* EV1-11 */ end; else do; /* no next member, just print warning in comments */ buf = '/* Warning: empty char[] member for '; buf = buf||to_lower(p->nod$t_name); buf = buf||' at end of structure not created */'; end; /* print the fix #define or warning message for the VAXC case */ /* and then the #endif. Since we are done with this, go to */ /* to the end and get the next element to print */ call put(buf); buf='#endif /* #if defined(__VAXC) */'; call put(buf); buf=''; goto common_3; end; buf=copy(' ',level-1); /* Don't let pointer_quad and pointer_hw */ /* go through. They should default to __int64 */ if p->nod$w_datatype=typ$k_address | (p->nod$v_has_object & (p->nod$w_datatype ^= typ$k_pointer_quad & p->nod$w_datatype ^= typ$k_pointer_hw)) | (vms_development & (p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long)) then buf2 = '*' || to_lower(p->nod$t_name) || arraystuff(); else if vms_development & (p->nod$b_type = nod$k_itemnode & (p->nod$w_datatype^=typ$k_structure & p->nod$w_datatype^=typ$k_union & p->nod$w_datatype^=typ$k_any) & p->nod$v_typedef)then buf2 = to_upper(p->nod$t_name); else buf2 = to_lower(p->nod$t_name); call puttype(p); if (p->nod$w_datatype=typ$k_structure | p->nod$w_datatype=typ$k_union) /* eliminate any structures with named types but not bound pointers */ & (p->nod$a_typeinfo2 = null() | p->nod$v_bound) then do; if level=1 then do; if p->nod$v_typedef then buf = buf || '_' || to_lower(p->nod$t_name); if p->nod$v_based then buf = buf || to_lower(p->nod$t_name); end; buf=buf||' {'; if p->nod$l_typeinfo^=0 then buf=buf||' /* WARNING: aggregate has origin of '||trim(p->nod$l_typeinfo)||' */'; if p->nod$a_comment^=null() & sdl$v_comment_opt then do; buf=fill(buf,40)||'/*'||p->nod$a_comment->based_string; buf=fill(buf,76)||'*/'; end; call put(buf); buf=''; /* if this is a negative origin, ignore */ /* fields with negative offsets */ if p->nod$l_typeinfo<0 & p->nod$a_child^=null() & vms_development then do; /* print a warning message */ msg=to_lower(p->nod$t_name); call errmsg (sdl$_shr_data, sdl$_negorigin, p->nod$l_srcline, msg); /* find the first valid element */ p1 = p->nod$a_child->nod$a_flink; offset = - p->nod$l_typeinfo; do while (p1 ^= null() & offset > 0); /* print info to file about missing entry */ buf = ' /* WARNING: aggregate element "'; buf = buf || to_lower(p1->nod$t_name); buf = buf || '" ignored */'; call put (buf); buf=''; /* remove this field from the length */ offset = offset - p1->nod$l_fldsiz; p1 = p1->nod$a_flink; end; if (p1 ^= null()) then call outputnode (p1,p->nod$a_child,level+1); end; else if p->nod$a_child ^= null() then call outputnode(p->nod$a_child->nod$a_flink,p->nod$a_child,level+1); buf=copy(' ',level)||'} '; /* Put out Based pointers for top level aggregates */ if level = 1 & p->nod$v_bound then buf = buf || '*' || to_lower(p->nod$a_typeinfo2->nod$t_name); else if level>1 | p->nod$v_common | p->nod$v_global | p->nod$v_typedef then do; if p->nod$v_typedef & vms_development then buf = buf || to_upper(p->nod$t_name); else buf = buf || to_lower(p->nod$t_name); end; buf=buf||arraystuff(); buf=buf||';'; if (c_development | vms_development) & level = 1 & p->nod$a_child ^= null() then do; call put(buf); buf = ''; call put(buf); member_seen = false; call define_members(p->nod$a_child->nod$a_flink,p->nod$a_child,'',1); end; end; else do; buf=buf||buf2; if p->nod$w_datatype=typ$k_vield & level>1 then do; if p->nod$v_dimen then i=p->nod$l_hidim - p->nod$l_lodim + 1; else i=1; vield_size = i*p->nod$l_typeinfo; vield_component = 1; if p->nod$v_userfill & vms_development then do while (vield_size > 32); buf2=buf||'_'||trim(vield_component)||' : 32;'; call put(buf2); vield_size = vield_size - 32; vield_component = vield_component + 1; end; if vield_component > 1 then buf=buf||'_'||trim(vield_component); buf=buf||' : '||trim(vield_size); end; /* Don't let pointer_quad and pointer_hw */ /* go through. They should default to __int64 */ if ^(p->nod$w_datatype=typ$k_address | (p->nod$v_has_object & (p->nod$w_datatype ^= typ$k_pointer_quad & p->nod$w_datatype ^= typ$k_pointer_hw)) | (vms_development & (p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long))) then buf=buf||arraystuff(); buf=buf||';'; if p->nod$a_comment^=null() & sdl$v_comment_opt then do; buf=fill(buf,40)||'/*'||p->nod$a_comment->based_string; buf = fill(buf,76)||'*/'; end; end; call put(buf); buf=''; if restore_extern_model then do; call put ('#pragma __extern_model __restore'); call put (' '); restore_extern_model = false; end; goto common_3; case(nod$k_modulnode): if in_module then call finish_module; if c_development | vms_development then do; close file(output_file); module_name = p->nod$t_name; if index(module_name,'$') = 1 then module_name = substr(module_name, 2); open file(output_file) title(out_file) environment( default_file_name(module_name || lang_ext) ); call sdl$header(sdl$_shr_data, '/*', '*/', line_length ); ind = 0; do until (ind = 0); if (ind ^= 0) then module_name = substr(module_name,1,ind-1) || '_' || substr (module_name,ind+1); ind = index (module_name,'$',ind+1); end; end; call start_module; goto common; case(nod$k_parmnode): do; if processing_optional_parms then goto common_4; if p->nod$v_optional then do; buf = buf || '__optional_params'; processing_optional_parms = true; goto common_3; end; if p->nod$w_datatype=typ$k_address | p->nod$v_has_object | (vms_development & (p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long)) then do; buf2 = to_lower(p->nod$t_name) || arraystuff(); /* If we are processing an entry pointer, put the * before it */ if p->nod$a_typeinfo2 ^= NULL then if p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype = typ$k_entry then buf2 = '*' || buf2; call puttype(p); buf = buf || buf2; /*p->nod$t_name;*/ if p->nod$a_flink ^= startp then buf=buf||','; goto common_2; end; else buf2 = to_lower(p->nod$t_name); if (p->nod$v_desc | p->nod$v_rtl_str_desc) then buf = 'void ' || '*' || buf2; else do; call puttype(p); buf = buf || buf2; /*p->nod$t_name;*/ end; /* If not passed by desc, then do arraystuff. This is for things like ** CHARACTER LENGTH n DESCRIPTOR */ if (^p->nod$v_desc & ^p->nod$v_rtl_str_desc) then buf = buf || arraystuff(); if p->nod$a_flink ^= startp then buf=buf||','; 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; buf=fill(buf,76)||'*/'; end; goto common_2; end; case(nod$k_headnode): buf=''; goto common_3; 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; 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; /* EV1-11 */ if buf ^= '' then buf = fill(buf,40); buf=buf||'/*'||p->nod$a_comment->based_string; buf=fill(buf,76)||'*/'; end; call put(buf); buf=''; common_2: if process_conditional then /* jg */ do; 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: /* If we are processing Starlet files, we need to catch the structures */ /* we have converted or need to convert to something for backward */ /* compatibility. */ if c_development & (p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union ) & (level = 1) then if processing_new_starlet then do; processing_new_starlet = false; processing_old_starlet = true; if p->nod$v_typedef then do; realType = false; do ind = 0 to 49 by 1; if realStarletTypedefs(ind) = p then realType = true; end; if ^realType then do; changed_typedef = true; p->nod$v_typedef = false; p->nod$v_based = true; end; end; if changed_datatype then do; p->nod$w_datatype = typ$k_union; changed_datatype = false; end; vms_development = false; goto end_while; end; else if processing_old_starlet then do; call put('#endif /* #ifdef __NEW_STARLET */'); if changed_typedef then do; p->nod$v_typedef = true; p->nod$v_based = false; changed_typedef = false; end; processing_new_starlet = true; processing_old_starlet = false; end; if processing_old_starlet & c_development & (saved_ptr = p) & changed_ptrtype then do; p->nod$a_typeinfo2 = saved_typeinfo2; p->nod$v_has_object = true; saved_ptr = null(); saved_typeinfo2 = null(); changed_ptrtype = false; end; /* * Travel across the circular list to the sibling node */ if p->nod$a_flink ^= startp then do; call put (buf); buf = tab; end; common_4: p = p->nod$a_flink; end_while: end; /* end of the DO WHILE loop */ return; /*-----------------------------------------*/ puttype: proc(p) recursive; dcl p ptr; dcl data_type_string char(18) var init (''); if p->nod$v_common then buf=buf||'extern '; if p->nod$v_global then do; call put (' '); call put ('#pragma __extern_model __save'); call put ('#pragma __extern_model __strict_refdef'); restore_extern_model = TRUE; if ^sdl$v_global_opt then buf=buf||'extern '; end; if p->nod$v_typedef then buf=buf||'typedef '; if p->nod$w_datatype=typ$k_entry then if p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype=0 then buf=buf||'int '; else call puttype(p->nod$a_typeinfo2->nod$a_flink); else if p->nod$w_datatype=typ$k_address | (p->nod$v_has_object & (p->nod$w_datatype ^= typ$k_pointer_quad & p->nod$w_datatype ^= typ$k_pointer_hw)) | (vms_development & (p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long)) then if p->nod$a_typeinfo2=null() then if c_development | vms_development then /* JEZ */ buf = buf || 'void '; else buf = buf || 'int '; else call outputnode(p->nod$a_typeinfo2->nod$a_flink,p->nod$a_typeinfo2,level ); else if p->nod$w_datatype=typ$k_char & p->nod$v_varying then buf=buf||'struct {short string_length; char string_text['|| trim(p->nod$l_typeinfo)||'];} '; else if (p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union) & p->nod$a_typeinfo2 ^= null() then do; if c_development then do; realType = false; do ind = 0 to 49 by 1; if realStarletTypedefs(ind) = p->nod$a_typeinfo2 then realType = true; end; end; if ^p->nod$a_typeinfo2->nod$v_typedef | (c_development & ^realType & processing_old_starlet ) then do; if p->nod$w_datatype = typ$k_structure then buf=buf||'struct '; else buf=buf||'union '; if p->nod$v_base_align & align_state ^= MEMBER_ALIGNMENT_ON then call do_basealign_pragmas(); else if (basealign_boundary ^= BASEALIGN_BYTE) & (align_state ^= MEMBER_ALIGNMENT_ON) then do; call put('#pragma __nomember_alignment'); basealign_boundary = BASEALIGN_BYTE; end; end; if p->nod$b_type ^= nod$k_objnode & ^p->nod$v_bound then if vms_development then buf = buf || to_upper(p->nod$a_typeinfo2->nod$t_name) || ' '; else buf = buf || to_lower(p->nod$a_typeinfo2->nod$t_name) || ' '; end; else if p->nod$w_datatype = typ$k_user then do; if vms_development & p->nod$a_typeinfo2->nod$a_flink->nod$b_type ^= nod$k_itemnode then do; buf = buf || 'struct _' || to_lower(p->nod$a_typeinfo2->nod$a_flink->nod$t_name) || ' '; if p->nod$v_base_align & align_state ^= MEMBER_ALIGNMENT_ON then call do_basealign_pragmas(); else if (basealign_boundary ^= BASEALIGN_BYTE) & (align_state ^= MEMBER_ALIGNMENT_ON) then do; call put('#pragma __nomember_alignment'); basealign_boundary = BASEALIGN_BYTE; end; end; else if vms_development & (p->nod$a_typeinfo2->nod$b_type = nod$k_itemnode & p->nod$a_typeinfo2->nod$v_declared & p->nod$a_typeinfo2->nod$v_typedef)then do; if p->nod$a_typeinfo2->nod$w_datatype = 0 then buf = buf || 'struct _' || to_lower(p->nod$a_typeinfo2->nod$t_name) || ' '; else buf = buf || to_upper(p->nod$a_typeinfo2->nod$t_name) || ' '; if p->nod$v_base_align & align_state ^= MEMBER_ALIGNMENT_ON then call do_basealign_pragmas(); else if (basealign_boundary ^= BASEALIGN_BYTE) & (align_state ^= MEMBER_ALIGNMENT_ON) then do; call put('#pragma __nomember_alignment'); basealign_boundary = BASEALIGN_BYTE; end; end; else if vms_development & (p->nod$a_typeinfo2->nod$a_flink->nod$b_type = nod$k_itemnode & p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype ^= typ$k_structure & p->nod$a_typeinfo2->nod$a_flink->nod$v_typedef) then buf = buf || to_upper(p->nod$a_typeinfo2->nod$a_flink->nod$t_name) || ' '; else buf = buf || to_lower(p->nod$a_typeinfo2->nod$a_flink->nod$t_name) || ' '; end; else if p->nod$w_datatype >= lbound(types,1) & p->nod$w_datatype <= hbound(types,1) then do; if p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union then do; if (c_development | vms_development) & level > 1 then buf = buf || '__'; end; if p->nod$v_unsigned then /* EV1-17 */ buf=buf||'unsigned '; buf=buf||types(p->nod$w_datatype); end; /* * Put out warning if this is a COMPLEX data type */ %if 0 %then %do; if p->nod$v_complex then do; select (p->nod$w_datatype); when (typ$k_float_complex) data_type_string = 'F_FLOATING COMPLEX'; when (typ$k_double_complex) data_type_string = 'D_FLOATING COMPLEX'; when (typ$k_grand_complex) data_type_string = 'G_FLOATING COMPLEX'; when (typ$k_huge_complex) data_type_string = 'H_FLOATING COMPLEX'; otherwise do; call errmsg (sdl$_shr_data, sdl$_bugcheck, p->nod$l_srcline, ); goto exit; end; end; /* select */ call errmsg (sdl$_shr_data, sdl$_typnotsup, p->nod$l_srcline, (data_type_string)); end; %end; if p->nod$v_ref & ^p->nod$v_dimen then if p->nod$a_typeinfo2 ^= NULL then do; if p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype ^= typ$k_entry then buf = buf || '*'; end; else buf = buf || '*'; end puttype; /*-----------------------------------------*/ process_entrynode: procedure(style); declare style fixed bin(31); buf = ''; call put_entry_type(); buf=buf||to_lower(p->nod$t_name); if ^c_development & ^vms_development then /* JEZ */ buf = buf || '() ;'; else if p->nod$a_child = null() then buf = buf || '(void);'; else if style = old_entry then buf = buf || '(__unknown_params);'; else do; buf = buf || '('; call put (buf); buf = tab; if c_development then vms_development = true; call outputnode (p->nod$a_child->nod$a_flink, p->nod$a_child, level+1); if c_development then vms_development = false; buf = buf || ');'; end; if p->nod$a_comment^=null() & sdl$v_comment_opt then do; /* EV1-11 */ if buf ^= '' then buf = fill(buf,40); buf=buf||'/*'||p->nod$a_comment->based_string; buf=fill(buf,76)||'*/'; end; call put (buf); buf=''; end process_entrynode; /*-----------------------------------------*/ do_basealign_pragmas: procedure; basealign = 2**p->nod$b_boundary; basealign = divide(basealign,8,31); basealign = log2(basealign); if basealign_boundary ^= basealign then do; basealign_boundary = basealign; buf = '#if ' || '!defined(__NOBASEALIGN_SUPPORT) && !defined(__cplusplus) '||'/* If using pre DECC V4.0 or C++ */'; call put (buf); buf = ''; SELECT (basealign); WHEN (BASEALIGN_WORD) call put ('#pragma __nomember_alignment __word'); WHEN (BASEALIGN_LONGWORD) call put ('#pragma __nomember_alignment __longword'); WHEN (BASEALIGN_QUADWORD) call put ('#pragma __nomember_alignment __quadword'); WHEN (BASEALIGN_OCTAWORD) call put ('#pragma __nomember_alignment __octaword'); OTHERWISE; END; call put ('#else'); call put ('#pragma __nomember_alignment'); call put('#endif'); end; end do_basealign_pragmas; /*-----------------------------------------*/ arraystuff: proc returns (char(128) var); dcl buf char(128) var; buf=''; if p->nod$w_datatype=typ$k_char & p->nod$l_typeinfo ^= 1 & p->nod$l_typeinfo ^= -999 & ^p->nod$v_varying then do; buf=buf||' ['; if p->nod$l_typeinfo ^= 0 then buf=buf||trim(p->nod$l_typeinfo); buf=buf||']'; end; else if p->nod$w_datatype=typ$k_decimal then buf=buf||' ['||trim(divide(p->nod$l_typeinfo,2,31)+1)||']'; else if /* Alpha only cases */ ((p->nod$w_datatype = typ$k_pointer_quad | p->nod$w_datatype = typ$k_integer_quad) & ^sdl$v_alpha_opt) | /* all cases since we do larger floats as arrays */ p->nod$w_datatype = typ$k_float_complex | p->nod$w_datatype = typ$k_double_complex | p->nod$w_datatype = typ$k_grand_complex | /* for quadword, if /c_dev or if /VAX or if not /VMS */ ((p->nod$w_datatype = typ$k_quadword) & (sdl$v_cc_opt | sdl$v_vax_opt | ^sdl$v_vms_opt)) then buf=buf||' [2]'; if p->nod$w_datatype = typ$k_huge | p->nod$w_datatype = typ$k_octaword then buf=buf||' [4]'; else if p->nod$w_datatype = typ$k_huge_complex then buf = buf || ' [8]'; if p->nod$v_dimen then if p->nod$w_datatype = typ$k_vield then buf=buf||' /** WARNING: bitfield array has been reduced to a string **/ '; else if p->nod$v_vardim then buf = buf || ' []'; else buf = buf || ' [' || trim(p->nod$l_hidim - p->nod$l_lodim + 1) || ']'; return (buf); end arraystuff; /*-----------------------------------------*/ define_members: procedure(initp,startp,pname,slevel) recursive; declare (initp,startp,p) ptr; declare pname char(*) var; declare slevel fixed bin(15); declare name char(256) var; do p = initp repeat p->nod$a_flink while(p ^= startp); if p->nod$b_type = nod$k_itemnode & p->nod$t_name ^= '' then do; if length(pname) > 0 then name = pname || '.' || p->nod$t_name; else name = p->nod$t_name; if (p->nod$w_datatype=typ$k_structure | p->nod$w_datatype=typ$k_union) & p->nod$a_child ^= null() then do; if ^member_seen then do; call put(' '); member_seen = true; if vms_development | c_development then call put ('#if !defined(__VAXC)'); else call put('#ifdef __cplusplus'); end; if ^p->nod$v_userfill & vms_development & slevel > 1 then do; call put ('#define '||to_lower(p->nod$t_name)||' '||to_lower(name)); name=p->nod$t_name; end; if p->nod$v_dimen then call define_members(p->nod$a_child->nod$a_flink,p->nod$a_child,'',slevel+1); else call define_members(p->nod$a_child->nod$a_flink,p->nod$a_child,name,slevel+1); end; else if slevel > 1 & ^p->nod$v_userfill then do; if p->nod$w_datatype = typ$k_char & p->nod$l_typeinfo = 0 & slevel > 1 & p->nod$a_flink ^= startp & p->nod$a_flink->nod$b_type = nod$k_itemnode then do; /* this was already defined as an alias to */ /* another field so don't define it again */ /* see speciall case: char[] above for more */ /* details. */ end; else do; if ^member_seen then do; call put(' '); member_seen = true; if vms_development | c_development then call put ('#if !defined(__VAXC)'); else call put('#ifdef __cplusplus'); end; call put('#define '||to_lower(p->nod$t_name)||' '||to_lower(name)); end; end; end; end; /* while p */ /* print end statement if this is the last call */ if slevel = 1 & member_seen then do; if vms_development | c_development then call put('#endif /* #if !defined(__VAXC) */'); else call put('#endif /* #ifdef __cplusplus */'); call put (' '); end; end define_members; /*-----------------------------------------*/ DefineMemberProtos: procedure(initp,startp,slevel) recursive; declare (initp,startp,p) ptr; declare slevel fixed bin(15); declare index fixed bin(31); declare protoName char(256) var; declare foundName bit(1); do p = initp repeat p->nod$a_flink while(p ^= startp); if (p->nod$b_type = nod$k_itemnode & p->nod$v_has_object & p->nod$w_datatype=typ$k_pointer & p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype = typ$k_user) then do; if p->nod$a_typeinfo2->nod$a_flink->nod$a_typeinfo2->nod$t_name ^= '' then do; if ^define_member_protos then do; call put(' '); define_member_protos = true; if vms_development | c_development then call put ('#ifdef __cplusplus /* Define structure prototypes */'); end; foundName = false; do index = 0 to 49 by 1; if (definedProtoNames(index) = p->nod$a_typeinfo2->nod$a_flink->nod$a_typeinfo2->nod$t_name) then do; foundName = true; leave; end; else if definedProtoNames(index) = '' then leave; end; if ^foundName then do; protoName = 'struct ' || '_' || to_lower(p->nod$a_typeinfo2->nod$a_flink->nod$a_typeinfo2->nod$t_name) || ';'; call put (protoName); definedProtoNames(index) = p->nod$a_typeinfo2->nod$a_flink->nod$a_typeinfo2->nod$t_name; end; end; end; if (p->nod$w_datatype=typ$k_structure | p->nod$w_datatype=typ$k_union) & p->nod$a_child ^= null() then call DefineMemberProtos(p->nod$a_child->nod$a_flink,p->nod$a_child,slevel+1); end; /* while p */ /* print end statement if this is the last call */ if slevel = 1 & define_member_protos then do; call put('#endif /* #ifdef __cplusplus */'); call put (' '); end; end DefineMemberProtos; /* **++ ** FUNCTIONAL DESCRIPTION: ** ** This procedures appends to BUF the return type of the entry node ** pointed to by P. ** ** FORMAL PARAMETERS: ** ** [subtags] ** ** RETURN VALUE: ** ** [description_or_none] ** ** SIDE EFFECTS: ** ** BUF is modified. ** **-- **/ put_entry_type: procedure; if p->nod$w_datatype ^= 0 then do; /* * arrays aren't allowed as return types in SDL, but some scalar types * are output as arrays in C so we must be return these as a structure * (The exception is quadword, which is returned in r0/r1 so we * must output it as a double floating) */ if p->nod$w_datatype = typ$k_quadword & ^vms_development then buf=buf||types(typ$k_double); else do; temp=arraystuff(); if temp ^= '' then do; buf=buf||'struct {'; call puttype(p); if length(p->nod$t_name) > 8 then buf=buf||substr(p->nod$t_name,1,8); else buf=buf||p->nod$t_name; buf=buf||'$$ret_'||trim(retcnt)||'_'||temp||';} '; retcnt=retcnt+1; end; else do; call puttype(p); /* Don't let pointer_quad and pointer_hw */ /* go through. They should default to __int64 */ if p->nod$w_datatype=typ$k_address | (p->nod$v_has_object & (p->nod$w_datatype ^= typ$k_pointer_quad & p->nod$w_datatype ^= typ$k_pointer_hw)) | (vms_development & (p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long)) then buf=buf||'*'; end; end; end; else if c_development | vms_development then buf = buf || 'int '; else buf = buf || 'void '; /* use void function result type JEZ */ end put_entry_type; /*-----------------------------------------*/ start_module: procedure; do ind = 0 to 49 by 1; realStarletTypedefs(ind) = NULL; end; buf='/*** MODULE '||p->nod$t_name; if p->nod$t_naked ^= '' then buf = buf || ' IDENT ' || p->nod$t_naked; buf = buf || ' ***/'; call put(buf); if c_development | vms_development then do; buf = '#ifndef __' || to_upper(module_name) || '_LOADED'; call put(buf); buf = '#define __' || to_upper(module_name) || '_LOADED 1'; call put(buf); call put(' '); call put('#pragma __nostandard /* This file uses non-ANSI-Standard features */'); end; if do_alignment_pragmas then /* jak EV1-9 */ do; call put('#pragma __member_alignment __save'); /* jak EV1-8 */ if sdl$v_member_align then /* jak EV1-9 */ do; call put('#pragma __member_alignment'); align_state = MEMBER_ALIGNMENT_ON; end; else do; call put('#pragma __nomember_alignment'); align_state = MEMBER_ALIGNMENT_OFF; end; end; if c_development | vms_development then do; call put(' '); call put('#ifdef __cplusplus'); call put(' extern "C" {'); call put('#define __unknown_params ...'); call put('#else'); call put('#define __unknown_params'); call put('#define __optional_params ...'); call put('#endif'); call put(' '); call put ('#if !defined(__VAXC)'); call put('#define __struct struct'); call put('#define __union union'); call put('#else'); call put('#define __struct variant_struct'); call put('#define __union variant_union'); call put('#endif'); call put(' '); end; buf=''; in_module = true; end start_module; end outputnode; /*-----------------------------------------*/ finish_module: procedure; call put(' '); if do_alignment_pragmas then /* jak EV1-9 */ do; call put('#pragma __member_alignment __restore'); /* jak EV1-8 */ align_state = MEMBER_ALIGNMENT_UNKNOWN; end; if c_development | vms_development then do; call put('#ifdef __cplusplus'); call put(' }'); call put('#endif'); call put('#pragma __standard'); end; if c_development | vms_development then do; call put(' '); call put('#endif /* __' || to_upper(module_name) || '_LOADED */'); call put(' '); end; in_module = false; end finish_module; /*-----------------------------------------*/ to_lower: procedure (string) returns(char(*) var); declare string char(*) var; if c_development | vms_development then return (translate(string, lower_alpha, upper_alpha)); return (string); end to_lower; /*-----------------------------------------*/ to_upper: procedure (string) returns(char(*) var); declare string char(*) var; if c_development | vms_development then return (translate(string, upper_alpha, lower_alpha)); return (string); end to_upper; /*-----------------------------------------*/ put: procedure( line ); declare line char(*) var; declare (i,n) fixed bin(15); i = 1; n = length(line); do while( n > line_length ); /* split long lines */ call sdl$putline(outfile,substr(line,i,line_length-1)||'\',line_length); n = n - (line_length-1); i = i + (line_length-1); end; call sdl$putline(outfile,substr(line,i,n),line_length); end put; end sdl$output;