/* ***************************************************************************** * * * Copyright (c) 1978-1997 * * 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. ----------------|-------|------------------------------------------------------ 6-Dec-1994 | RC | EV1-40 Native Alpha port. See SDLGETFNM.PLI. | sdd | Sneaking in 64-bit pointer support. _______________________________________________________________________________ 2-Feb-1995 | aem | EV1-41 Fix problem with pointers to routines outside | | an aggregate definition. _______________________________________________________________________________ 23-Feb-1995 | aem | EV1-42 Fix problem with __nomember_alignment | | generation. _______________________________________________________________________________ 23-Mar-1995 | aem | EV1-43 Add remaining 64-bit support for function | | prototypes. Fix problem with __NEW_STARLET | | producing int[2] instead of __int64. Change | | comments for required_pointer_size __long | | pragma. ________________|_______|______________________________________________________ 30-Mar-1995 | aem | EV1-45 Change some problems with prior checkin. | | - variables defaulting to ref are now * | | - fixed problem with last parameter being | | a 64-bit var ________________|_______|______________________________________________________ 5-Apr-1995 | aem | EV1-46 Generate __NEW_STARLET, __OLD_STARLET | | definitions for typedefs that aren't aggregates. ________________|_______|______________________________________________________ 2-Aug-1995 | aem | EV1-47 Make typedefs that are defined as items with | | /vms uppercase. This fixes QAR 634 in EVMS- | | THETA database/ ________________|_______|______________________________________________________ 11-Aug-1995 | aem | EV1-48 Remove logic for /C_DEV which converts unions | | to structs. This logic was in place to allow | | pointers to these types (struct _tag *) to | | in STARLET. Things got too messy and back- | | ward compatibility couldn't be guaranteed, | | so here I am ....... ________________|_______|______________________________________________________ 29-Aug-1995 | aem | EV1-49 Fix spelling mistake in __unknown_params. | | Also add definition of __optional_params in | | #ifdef_cplusplus logic.....it was apparently | | overlooked. ________________|_______|______________________________________________________ 30-Aug-1995 | aem | EV1-50 Change code to initialize variables used to | | build __new_starlet. These variables weren't | | being initialized to false and were causing | | problems. ________________|_______|______________________________________________________ 12-Mar-1996 | aem | EV1-52 Fix problems for GRYPHON | | * Problems with TYPEDEFs defined as ITEMs | | * remove generation of #endifs when an | | SDI file is read in | | * problem with return type for address(entry) | | construct ________________|_______|______________________________________________________ 12-Jun-1996 | aem | EV1-53 Fix problems for GRYPHON | | * No longer translate quadword to double in | | function return type on Alpha | | * Fix case in item typedef definition of | | quadword | | * Don't generate '*' for parameters such | | as octaword which get converted to an | | array. | | * Change array definition for 2-dimensional | | array with one set of unknown bounds ________________|_______|______________________________________________________ 24-Jun-1996 | aem | EV1-54 Fix problems for GRYPHON | | * Tools QAR 120 | | Fix some problems with ITEM,TYPEDEF | | definitions ________________|_______|______________________________________________________ 19-Nov-1996 | aem | EV1-55 Fix QARs from RAVEN database | | * add ifndef __struct and __union | | before defining them in header files | | * fix problem with array that keeps track | | of TYPEDEFS in a given module. The | | array was being re-initialized at each | | call to OUTPUTNODE. ________________|_______|______________________________________________________ 27-Aug-1997 | rab | EV1-57 Stop outputting blank lines for each | | interesting name picked up from a .SDI | | file. Also fix bug in previous that made | | __NEW_STARLET output just the same as | | __OLD_STARLET wrt TYPEDEFs. Also fix wrong | | casing of entry parameters that is fallout | | from allowing user-defined ITEMs that | | reference AGGREGATEs be treated as user | | symbols. ________________|_______|______________________________________________________ 03-Nov-1997 | rab | EV1-59 Use correct array subscripts. Don't search | | realStarletTypedefs if OLD_STARLET ________________|_______|______________________________________________________ 23-Jan-1998 | aem | EV1-60 If an item is defined as some typedef | | which is defined in an SDI file, for OLD_STARLET, | | generate the type information using the typename. | | Otherwise, check to see if we have identified | | this type as a realtypedef. This is a refinement | | of the fix introduced in EV1-59. ________________|_______|______________________________________________________ */ %replace MODULE_IDENT by 'EV1-60'; 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:sdlgetfnm.in'; /* 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_integer) = '__int64 '; types(typ$k_integer_hw) = '__int64 '; if sdl$v_vms_opt | sdl$v_cc_opt then do; types(typ$k_hardware_address) = ''; types(typ$k_pointer_hw) = ''; end; else do; types(typ$k_hardware_address) = '__int64 '; types(typ$k_pointer_hw) = '__int64 '; end; 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; if sdl$v_vms_opt | sdl$v_cc_opt then do; types(typ$k_pointer_quad) = ''; end; else do; types(typ$k_pointer_quad) = '__int64 '; end; 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 */ 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; %replace PTR_32_BITS by 0; %replace PTR_64_BITS by 1; 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 ptr_size fixed bin(1) static init(PTR_32_BITS); 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 parm_done bit(1) aligned; dcl saved_ptr pointer; dcl saved_typeinfo2 pointer; dcl savep pointer; dcl checkp pointer; dcl realStarletTypedefs(100) pointer; dcl starletTypedefIndex fixed bin(31); /*** 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 */ starletTypedefIndex = 0; if c_development then do; processing_new_starlet = true; processing_old_starlet = false; parm_done = false; changed_ptrtype = false; end; else do; processing_new_starlet = false; processing_old_starlet = false; parm_done = 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,,(sdl$gt_filename)); goto exit; 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), user_open (sdl$getfnm) ); 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_lang_file = sdl$gt_filename; %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 restore_pointer_size bit(1); dcl first_time_through bit(1); declare definedProtoNames(50) char(256) var; declare realType bit(1); declare processing_optional_parms bit(1); declare processing_variable_entry bit(1); restore_extern_model = false; restore_pointer_size = false; processing_optional_parms=false; processing_variable_entry=false; 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)); /* 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 = 1 to 50 by 1; definedProtoNames(ind) = ''; end; call DefineMemberProtos(p->nod$a_child->nod$a_flink,p->nod$a_child,1); end; /* 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'); types(typ$k_quadword) = '__int64 '; call process_entrynode(new_entry); call put ('#else /* __OLD_STARLET */'); types(typ$k_quadword) = 'int '; 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; if p->nod$a_parent->nod$v_typedef then /* If this object is a typedef for a pointer to entry */ buf2 = to_upper(buf2); 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$v_variable & ^processing_old_starlet then do; buf2 = buf2 || '(__unknown_params)'; processing_variable_entry = true; end; else 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 | ((vms_development | (c_development & sdl$v_alpha_opt)) & (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 /* ignore declared item */ do; if p->nod$a_comment^=null() & sdl$v_comment_opt then goto common; /* output the comment on its own */ else goto common_1; /* don't output just a blank line */ end; /* *** */ /* 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$w_datatype = typ$k_pointer_quad | p->nod$w_datatype = typ$k_pointer_hw) & 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; if (processing_new_starlet & c_development & (level = 1)) then do; if p->nod$v_typedef then do; starletTypedefIndex = starletTypedefIndex + 1; realStarletTypedefs(starletTypedefIndex) = p; 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 = 1 to 50 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. */ /* Typedefs which are not aggregates will also be created twice with the*/ /* /c_dev switch */ if ((p->nod$w_datatype = typ$k_address | p->nod$w_datatype = typ$k_pointer | p->nod$w_datatype = typ$k_pointer_long | p->nod$w_datatype = typ$k_pointer_hw | p->nod$w_datatype = typ$k_pointer_quad | p->nod$w_datatype = typ$k_hardware_address) & p->nod$v_typedef & c_development & level = 1) | (p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union | (p->nod$v_has_object & p->nod$a_typeinfo2 ^= null() ) | (p->nod$a_typeinfo2 = null() & p->nod$v_typedef)) & 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; if p->nod$b_type = nod$k_itemnode then checkp = p; else checkp = p->nod$a_child; types(typ$k_quadword) = '__int64 '; end; else if processing_old_starlet then do; call put('#else /* __OLD_STARLET */'); types(typ$k_quadword) = 'int '; 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); call start_pointer_size_pragmas(); if processing_old_starlet & (p->nod$w_datatype=typ$k_pointer_quad | p->nod$w_datatype=typ$k_pointer_hw) then buf2 = to_lower(p->nod$t_name); 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 do; if p->nod$v_has_object then if p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype=typ$k_entry then buf2 = '*' || to_lower(p->nod$t_name); else buf2 = '*' || to_upper(p->nod$t_name); else if p->nod$w_datatype = typ$k_address | p->nod$w_datatype = typ$k_pointer | p->nod$w_datatype = typ$k_pointer_long | p->nod$w_datatype = typ$k_pointer_hw | p->nod$w_datatype = typ$k_pointer_quad | p->nod$w_datatype = typ$k_hardware_address then buf2 = '*' || to_upper(p->nod$t_name); else buf2 = to_upper(p->nod$t_name); end; else if vms_development & p->nod$b_type = nod$k_itemnode & p->nod$w_datatype=typ$k_structure & p->nod$v_typedef then buf2 = to_upper(p->nod$t_name); else if p->nod$w_datatype=typ$k_address | p->nod$v_has_object | ((vms_development | (c_development & sdl$v_alpha_opt)) & (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 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; if ^(p->nod$w_datatype=typ$k_address | p->nod$v_has_object | ((vms_development | (c_development & sdl$v_alpha_opt)) & (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=''; call finish_pointer_size_pragmas(); 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), user_open (sdl$getfnm) ); 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 | processing_variable_entry then /* ignore any params on entry w/ VARIABLE attribute */ 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 check_pointer_size; end; else buf2 = to_lower(p->nod$t_name); if (p->nod$v_desc | p->nod$v_rtl_str_desc) then do; buf = buf || 'void ' || '*' || buf2; end; 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; check_pointer_size: call start_pointer_size_pragmas(); 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); common_1: buf=''; common_2: buf2 = ''; 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$b_type ^= nod$k_objnode) & (p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union | (p->nod$v_has_object & p->nod$a_typeinfo2 ^= null() ) | (p->nod$a_typeinfo2 = null() & p->nod$v_typedef)) & (^p->nod$v_declared) & (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 = 1 to starletTypedefIndex 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; 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 & (p->nod$b_type ^= nod$k_objnode) 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; call finish_pointer_size_pragmas(); 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 | ((vms_development | (c_development & sdl$v_alpha_opt)) & (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 processing_old_starlet & (p->nod$w_datatype=typ$k_pointer_quad | p->nod$w_datatype=typ$k_pointer_hw) then buf = buf || 'unsigned __int64 '; else do; if c_development | vms_development then /* JEZ */ buf = buf || 'void '; else buf = buf || 'int '; end; else if processing_old_starlet & (p->nod$w_datatype=typ$k_pointer_quad | p->nod$w_datatype=typ$k_pointer_hw) & (p->nod$a_typeinfo2->nod$a_flink->nod$w_datatype ^= typ$k_entry) then buf = buf || 'unsigned __int64 '; else do; if do_alignment_pragmas then align_state = MEMBER_ALIGNMENT_ON; call outputnode(p->nod$a_typeinfo2->nod$a_flink,p->nod$a_typeinfo2,level ); if do_alignment_pragmas then align_state = MEMBER_ALIGNMENT_OFF; end; 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; if processing_old_starlet & p->nod$a_typeinfo2->nod$v_declared then realType = true; else do; realType = false; do ind = 1 to starletTypedefIndex by 1; if realStarletTypedefs(ind) = p->nod$a_typeinfo2 then realType = true; end; 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$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 & /* we generate arrays for the following types so don't */ /* genrate "*" */ ((p->nod$w_datatype ^= typ$k_octaword) & (p->nod$w_datatype ^= typ$k_float_complex) & (p->nod$w_datatype ^= typ$k_double_complex) & (p->nod$w_datatype ^= typ$k_grand_complex) & (p->nod$w_datatype ^= typ$k_huge) & (p->nod$w_datatype ^= typ$k_huge_complex)) 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 || '*'; if p->nod$v_value & (p->nod$w_datatype = typ$k_address | p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long | p->nod$w_datatype=typ$k_pointer_quad | p->nod$w_datatype=typ$k_pointer_hw) 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); if c_development & style = new_entry then vms_development = true; call start_pointer_size_pragmas(); buf = ''; call put_entry_type(); if (style = new_entry) & p->nod$v_typedef then buf=buf||to_upper(p->nod$t_name); else buf=buf||to_lower(p->nod$t_name); if ^c_development & ^vms_development then /* JEZ */ buf = buf || '() ;'; else if p->nod$v_variable & (style = new_entry) then do; buf = buf || '(__unknown_params);'; processing_variable_entry = true; end; 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; call outputnode (p->nod$a_child->nod$a_flink, p->nod$a_child, level+1); 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=''; if c_development then vms_development = false; 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; /*-----------------------------------------*/ start_pointer_size_pragmas: procedure; /* What the heck. I'll break tradition and actually comment some of the code I'm adding here. What I'm attempting to do, sane or not, is toggle the state of ptr_size, which keeps track of, you guessed it, the current pointer size, of which there are two possibilities, 32-bit and 64-bit. Besides toggling the state, if we're building /ALPHA and either /C_DEVELOPMENT or /VMS, then we'll output appropriate #pragmas into the header file to regulate the pointer size used by the compiler. Note that such pragmas are bracketed with an #ifdef for that added bit of comfort and so as not to upset compilers which don't support multi-size pointers or recognize these pragmas. */ if (p->nod$w_datatype=typ$k_address | p->nod$w_datatype=typ$k_pointer | p->nod$w_datatype=typ$k_pointer_long | (p->nod$b_type = nod$k_parmnode & p->nod$w_datatype = typ$k_any) | (p->nod$b_type = nod$k_parmnode & p->nod$v_ref) | (p->nod$b_type = nod$k_parmnode & p->nod$v_desc)) & ^processing_old_starlet & p->nod$w_datatype^=typ$k_pointer_hw & p->nod$w_datatype^=typ$k_pointer_quad then if ptr_size=PTR_64_BITS then do; ptr_size = PTR_32_BITS; if vms_development | (c_development & sdl$v_alpha_opt) then do; call put('#ifdef __INITIAL_POINTER_SIZE /* Defined whenever ptr size pragmas supported */'); call put('#pragma __required_pointer_size __short /* And set ptr size default to 32-bit pointers */'); call put('#endif'); end; end; if ((p->nod$w_datatype=typ$k_pointer_hw & sdl$v_alpha_opt) | p->nod$w_datatype=typ$k_pointer_quad) & ^processing_old_starlet then /* if ptr_size=PTR_32_BITS then */ do; /* if ^(p->nod$b_type = nod$k_parmnode & p->nod$v_ref) then*/ do; ptr_size = PTR_64_BITS; if vms_development | (c_development & sdl$v_alpha_opt) then do; call put('#ifdef __INITIAL_POINTER_SIZE /* Defined whenever ptr size pragmas supported */'); call put('#pragma __required_pointer_size __long /* And set ptr size default to 64-bit pointers */'); restore_pointer_size = true; end; end; end; end start_pointer_size_pragmas; /*-----------------------------------------*/ finish_pointer_size_pragmas: procedure; if restore_pointer_size then do; /* If this is the last parameter of an entry, we need to do some */ /* fooling around to make the code come out in the correct order */ /* */ if (p->nod$a_flink = startp) & (p->nod$b_type = nod$k_parmnode) then do; call put (buf); call put ('#else'); call put (tab ||'unsigned __int64 ' || to_lower(p->nod$t_name)); call put (''); buf = ''; end; else if (p->nod$b_type = nod$k_parmnode) then do; call put ('#else'); call put (tab ||'unsigned __int64 ' || to_lower(p->nod$t_name) || ','); end; else do; call put ('#else'); if p->nod$v_typedef then call put (tab ||'typedef unsigned __int64 ' || to_upper(p->nod$t_name) || ';'); else call put (tab ||'unsigned __int64 ' || to_lower(p->nod$t_name) || ';'); end; call put ('#endif'); restore_pointer_size = false; end; end finish_pointer_size_pragmas; /*-----------------------------------------*/ arraystuff: proc returns (char(128) var); dcl buf char(128) var; buf=''; 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) || ']'; 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) & ^processing_new_starlet)) 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]'; 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,objnode) 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$b_type = nod$k_parmnode) & p->nod$v_has_object ) then do; objnode = GetPtrObject(p); if objnode->nod$w_datatype = typ$k_user then /* Object is a user defined datatype */ do; if objnode->nod$a_typeinfo2->nod$a_flink->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 = 1 to 50 by 1; if (definedProtoNames(index) = objnode->nod$a_typeinfo2->nod$a_flink->nod$t_name) then do; foundName = true; leave; end; else if definedProtoNames(index) = '' then leave; end; if ^foundName then do; protoName = 'struct ' || '_' || to_lower(objnode->nod$a_typeinfo2->nod$a_flink->nod$t_name) || ';'; call put (protoName); definedProtoNames(index) = objnode->nod$a_typeinfo2->nod$a_flink->nod$t_name; end; end; end; end; /* Object is a user defined datatype */ 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; /*-----------------------------------------*/ GetPtrObject: procedure(p) returns(ptr); declare (p,objptr) ptr; objptr = p; do while (objptr->nod$v_has_object); do; objptr = objptr->nod$a_typeinfo2->nod$a_flink; end; end; return(objptr); end GetPtrObject; /* **++ ** 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) ...... on VAX */ if p->nod$w_datatype = typ$k_quadword & ^vms_development & sdl$v_vax_opt 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); if p->nod$w_datatype=typ$k_address | p->nod$v_has_object | ((vms_development | (c_development & sdl$v_alpha_opt)) & (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 buf = buf || 'int '; end put_entry_type; /*-----------------------------------------*/ start_module: procedure; do ind = 1 to 100 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 vms_development | (c_development & sdl$v_alpha_opt) then do; call put('#ifdef __INITIAL_POINTER_SIZE /* Defined whenever ptr size pragmas supported */'); call put('#pragma __required_pointer_size __save /* Save the previously-defined required ptr size */'); call put('#pragma __required_pointer_size __short /* And set ptr size default to 32-bit pointers */'); call put('#endif'); 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('#define __optional_params ...'); call put('#else'); call put('#define __unknown_params'); call put('#define __optional_params ...'); call put('#endif'); call put(' '); call put ('#ifndef __struct'); call put ('#if !defined(__VAXC)'); call put('#define __struct struct'); call put('#else'); call put('#define __struct variant_struct'); call put('#endif'); call put('#endif'); call put(' '); call put ('#ifndef __union'); call put ('#if !defined(__VAXC)'); call put('#define __union union'); call put('#else'); call put('#define __union variant_union'); call put('#endif'); 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 vms_development | c_development & sdl$v_alpha_opt then do; call put('#ifdef __INITIAL_POINTER_SIZE /* Defined whenever ptr size pragmas supported */'); call put('#pragma __required_pointer_size __restore /* Restore the previously-defined required ptr size */'); call put('#endif'); 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;