/***************************************************************************** * * * Copyright (c) 1983-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 * * ABSTRACT: Routine to write out the sdl intermediate file. This is a * binary representation of the parse tree. * * ENVIRONMENT: VAX/VMS * * AUTHOR: * Kathleen Duthie * * CREATION DATE: * November 22, 1983 * * MODIFIED BY: * /* C H A N G E L O G Date ! Name ! Description ________________!_______!______________________________________________________ 15-Feb-1984 | kd | New module for SDL V2.0 ________________!_______!______________________________________________________ 19-Nov-1984 | kd | 3-0. Add ident field. Make changes to process the | | new typename field in the nodes. ________________!_______!______________________________________________________ 6-Aug-1985 | kd | 3-1. Make PARSEOUT argument char(*) type to match | | declaration from sdlmain. ________________!_______!______________________________________________________ 20-May-1987 | jw | X3.1-0 Added nod$t_return_name processing ________________!_______!______________________________________________________ 14-Jul-1987 | jw | X3.1-1 Added check to put the "linear order number" | | (node_count, which is stored in nod$l_srcline) | | out to the intermediate file for ENTRY RETURNS | | ADDRESS, since this is another case of | | nod$a_typeinfo2 holding the address of | | something (which has already been | | pre-"counted" -- i.e., has had a linear order | | number assigned to it). | | | | Note: In these cases, typeinfo2 itself is | | *not* the address of the first item in a | | parameter or aggregate member list. Those | | situations are handled in the get_node_count | | and put_nodes routines. Get_node_count is | | the routine that actually stores the "linear | | order number" (i.e., reflecting the order in | | which the tree was traversed) in | | nod$l_srcline for each node; this is actually | | a change in the tree (a corruption of data) | | which causes source line information to be | | lost. This would explain the fact that | | source line numbers are incorrect in SDL | | messages (see SDL_BUGS Note 61). ________________!_______!______________________________________________________ 16-Jul-1987 | jw | X3.1-2 Completed the most recent fix (X3.1-1) by | | ensuring that the ENTRY node of the object | | of RETURNS ADDRESS(ENTRY) is pre-traversed | | (i.e., assigned a linear order number). This | | is accomplished by adding a check to the | | get_node_count and put_nodes routines which | | counts ENTRY RETURNS ADDRESS(ENTRY) as one | | of the cases where TYPEINFO2 contains an | | address. [SDL_BUGS Note 63] ________________!_______!______________________________________________________ 19-Jul-1987 | jw | X3.1-3 The check for ENTRY RETURNS ADDRESS(ENTRY) | | described in the previous entry was changed | | to a check for simply ENTRY RETURNS ADDRESS, | | since ENTRY RETURNS ADDRESS always generates | | a head and object couple which need to be | | traversed, counted, and put out to the | | intermediate file. This should complete the | | fix of the bug described in SDL_BUGS Note 63. | | | | Note: I have discovered that the linear order | | numbers being put out to the intermediate file | | are: (1) not consistent with the linear order | | numbers generated by SDLINTREE.PLI, and (2) | | inaccurate with respect to the actual number | | of nodes traversed. The problem is that | | node_count was initalized to 1 and then | | always incremented before being assigned to | | a particular node. As a consequence, the | | root node is assigned a linear order number | | of 2 (which, of course, is wrong. It should | | be 1, since it is the first node traversed.) | | All nodes subsequently traversed are likewise | | assigned a linear order number which is one | | increment greater than the number which would | | reflect the node's actual position (with | | respect to tree traversal) in the tree. | | Since, however, the purpose of this number | | is not to reflect this exact position -- but | | instead to provide each node with a unique | | identification number in order to facilitate | | linkage of declarations and pre-defined | | structures, the fix will be made in the module | | which reads the intermediate file (INTREE). | | In SDLINTREE.PLI, the linear order numbers | | will begin at 2, instead of 1, to match the | | output of this routine. The change is being | | made in this manner so that SDL will remain | | compatible with ALL the old intermediate files | | it has created in the past. ________________!_______!______________________________________________________ 19-Jul-1987 | jw | X3.1-4 Removed the additional check described in | | X3.1-1, since the module INTREE does not need | | the linear order number in order to link the | | entry node with its head/object couple (since | | the head node will always occur immediately | | after the entry node in the intermediate | | file). ________________!_______!______________________________________________________ 21-Jul-1987 | jw | X3.1-5 Fixed bug reported in SDL_BUGS Note 65: | | UNIONs were not being included in the | | definition of "aggregate." Added a check | | in both get_node_count and put_nodes to make | | sure that the head/object couple for the | | pointer of a based UNION is pre-traversed, | | pre-counted, and put out into the | | intermediate file. Also, made sure that the | | linear order number of a UNION's item node is | | put out for ADDRESS(union-name) and PARAMETER | | of type union-name (change made in | | compress_node routine). ________________!_______!______________________________________________________ 22-Jul-1987 | jw | X3.1-6 Fixed bug reported in SDL_BUGS Note 66: | | (A correponding fix was made in module | | INTREE.) Prevented "end-of-list node" (or, | | end-of-list flag data) from being written | | to the intermediate file when the node we | | are currently processing is a type node. | | This change was made in routine put_nodes. | | The problem was that a type node "looks" | | like a node that would end a circular list | | (i.e., the flink has the same value as the | | last parameter in the call to put_nodes -- | | which, in this case, is the address of the | | type node itself). However, the type node | | is not a member of any list; and only by | | coincidence are its flink and blink the same | | as its own address. ________________!_______!______________________________________________________ 26-Oct-1987 | jw | X3.1-7 Fixed RETURNS NAMED bug - bad intermediate | | code produced. In SDLNODMSK.IN, removed the | | msk$v_return_name field at the end of the | | union. This field would have made the NODE | | MASK info larger than 2 bytes -- thus causing | | incompatibility with older SDL intermediate | | files. In this file, implemented the | | following kludge: When processing an entry | | entry node, used msk$v_offset to flag a | | return name. Made sure that under no | | circumstances does ENTRY use the real offset | | field/flag. Shortened the mask$w_fields | | initialization value by one bit. | | In SDLINTREE.PLI, implemented the same kludge | | by interpreting a set OFFSET flag as a | | return_name flag when the node type is ENTRY. ________________|_______|______________________________________________________ 4-Jan-1988 | PG | X3.2-0 Add CONSTANT string ________________|_______|______________________________________________________ 29-Jan-1988 | PG | X3.2-1 Fix output CONSTANT STRING to match | | INTREE. All that is needed for a | | string is the size and the string | | itself ________________|_______|______________________________________________________ 16-Feb-1988 | jg | X3.2-2 Add processing for user data type and literal | | node. | | Replace magic number 12 for end node type | | with nod$k_endnode ________________|_______|______________________________________________________ 25-Feb-1988 | jg | X3.2-3 Fix bug which lost user type head/object | | attached to address object. ________________|_______|______________________________________________________ 13-Feb-1990 | WRV | X3.2-VMS1 Modifiers are developers from VMS tools group. | RHT | William Vales and Robert Thomson. Modify | | to record file dependency data for the VMS | | VDE system builder. ________________|_______|______________________________________________________ 26-Sep-1990 | dlm | EVMS - Fix bug causing crash on comment line of 129 | | chars. ________________|_______|______________________________________________________ 07-Apr-1992 | jak | EV1-1 ________________|_______|______________________________________________________ 17-Apr-1992 | jak | EV1-5 ________________|_______|______________________________________________________ 23-Apr-1992 | jak | EV1-6 Added code to put out nod$t_maskstr. ________________|_______|______________________________________________________ 5-May-1992 | jak | EV1-8 Change to put "node type" byte before "mask". | | Change to save node number in new field, nod$l_nodeid. ________________|_______|______________________________________________________ 21-Dec-1992 | jak | EV1-20 Changes to walk_tree and put_node. ________________|_______|______________________________________________________ 12-Jan-1993 | jak | EV1-20 Change to use HAS_OBJECT flag. ________________|_______|______________________________________________________ 12-Mar-1996 | aem | EV1-52 Copy BOUNDARY and FLAGS2 fields to the | | intermediate tree file to fix problems with | | output generated from SDI files. ________________|_______|______________________________________________________ **/ %replace MODULE_IDENT by 'EV1-52'; /** * FUNCTIONAL DESCRIPTION: OUTTREE * * The function of the OUTTREE module is to print out the * intermediate tree that is generated by the parser. Each node is * compressed before writing it to the tree file. Only non-blank * fields of the node are written. The pointer fields and the source * line field are removed. These fields will not be necessary upon * restructuring the tree. * * FORMAL PARAMETERS: * * sdifile - The output intermediate tree file, already opened by caller. * * IMPLICIT INPUTS: * * EXTERNAL_TREE_ROOT - The root of the tree is an external * variable supplied to this routine. * * IMPLICIT OUTPUTS: * * none * * ROUTINE VALUE: * COMPLETION CODES: * * none * * SIDE EFFECTS: * * Upon completion of this routine, the intermediate tree file has * been written to disk. * **/ outtree: procedure( sdifile ) options( ident(MODULE_IDENT) ); /* INCLUDED FILES */ %include 'SDL$LIBRARY:sdlnodef.in'; %include 'SDL$LIBRARY:sdltypdef.in'; %include 'sdl$library:sdlnodmsk.in'; %include 'sdl$library:sdlshr.in'; %replace true by '1'b; %replace false by '0'b; /* PARAMETER */ dcl sdifile file; /* output file (already opened by caller) */ /* GLOBALS */ dcl external_tree_root pointer external static; /* LOCALS */ dcl node_count fixed bin(31) static init(0); /* total nodes in tree */ dcl buffer char(510) static; dcl buffer_index fixed bin(15) static init(0); /* Count the nodes and number them */ call walk_list(external_tree_root, count_node); /* First thing in file is total node count */ call put_int(node_count); /* Followed by the nodes themselves (compressed format) */ external_tree_root->nod$l_typeinfo = sdl$k_file_format_version; call walk_list(external_tree_root, put_node); /* Flush last buffer */ call write_buffer; return; /*------------------------------------------------------*/ walk_list: procedure(head, routine) recursive; /* Traverse the tree, calling ROUTINE for each node. */ dcl /* parameters */ head pointer, /* head of a circular list */ routine entry(pointer); /* call this for each node */ dcl /* locals */ p pointer; /* to a node */ do p = head repeat p->nod$a_flink while( p ^= null() ); /* Perform desired action on node */ call routine(p); /* Any objects or based pointer nodes */ if p->nod$a_typeinfo2 ^= null() then if p->nod$v_has_object /* ADDRESS object */ | p->nod$w_datatype=typ$k_address /* ADDRESS object (obsolete) */ | p->nod$w_datatype = typ$k_user & /* user-type typenode */ p->nod$a_typeinfo2->nod$a_parent = p | p->nod$w_datatype = typ$k_entry & /* ADDRESS ( ENTRY entnode ) */ p->nod$b_type = nod$k_objnode | p->nod$b_type = nod$k_condnode /* conditional node */ | p->nod$v_bound /* BASED ( ptr ) */ then call walk_list(p->nod$a_typeinfo2, routine); /* Any children nodes */ if p->nod$a_child ^= null() then call walk_list(p->nod$a_child, routine); /* End of circular list? */ if p->nod$a_flink = head then do; /* typenodes look like a circular list but are not */ if p->nod$b_type ^= nod$k_typnode then call routine(null()); /* null arg denotes end of a list */ return; end; end; /* WHILE loop */ end walk_list; /*------------------------------------------------------*/ count_node: procedure(p); /* Count node and save linear order number in nodeid field */ dcl p pointer; /* to node or null() for end of a list */ if p = null() then /* end of a list */ return; node_count = node_count + 1; p->nod$l_nodeid = node_count; end count_node; /*------------------------------------------------------*/ put_node: procedure(p); /* Write this node (compressed) to output file */ dcl p pointer; /* to node or null() for end of a list */ dcl var_string char(1024) var based; /* dummy string for comments, literals */ if p = null() then do; /* end of a list circular */ call put_int1(nod$k_endnode); return; end; /* Write the node */ /*------------------------------------------------------------------*/ /* Set up mask flags */ mask$w_fields = 0; mask2$w_fields = 0; if p->nod$l_hidim ^= 0 then /* HIDIM field */ msk$v_hidim = true; if p->nod$l_lodim ^= 0 then /* LODIM field */ msk$v_lodim = true; if p->nod$l_initial ^= 0 then /* INITIAL field */ msk$v_initial = true; if p->nod$t_name ^= '' then /* NAME field */ msk$v_name = true; if p->nod$t_prefix ^= '' then /* PREFIX field */ msk$v_prefix = true; if p->nod$t_marker ^= '' then /* MARKER field */ msk$v_marker = true; if p->nod$t_tag ^= '' then /* TAG field */ msk$v_tag = true; if p->nod$t_naked ^= '' then /* NAKED field */ msk$v_naked = true; if p->nod$l_offset ^= 0 then /* OFFSET field */ msk$v_offset = true; if p->nod$l_fldsiz ^= 0 then /* FLDSIZ field */ msk$v_fldsiz = true; if p->nod$w_datatype ^= 0 then /* DATATYPE field */ msk$v_datatype = true; if p->nod$l_flags ^= '0'b then /* FLAGS field */ msk$v_flags = true; if p->nod$l_typeinfo ^= 0 then /* TYPEINFO field */ msk$v_typeinfo = true; if ( p->nod$w_datatype = typ$k_user /* pointer to user type */ | p->nod$w_datatype = typ$k_structure /* pointer back to aggregate node */ | p->nod$w_datatype = typ$k_union ) & p->nod$a_typeinfo2 ^= null() then msk$v_tinfo2_ptr = true; /* Field is a pointer to some "pre-traversed" node */ /* Put out the linear order number corresponding to node at that address. */ else if ( p->nod$b_type = nod$k_litnode /* literal string */ | p->nod$b_type = nod$k_constnode & /* string constant */ p->nod$w_datatype = typ$k_char ) & p->nod$a_typeinfo2 ^= null() then msk$v_tinfo2_str = true; /* Field is a pointer to a string. Put out the string. */ else if ( p->nod$w_datatype = typ$k_vield | p->nod$w_datatype = typ$k_decimal ) & p->nod$l_typeinfo2 ^= 0 then msk$v_typeinfo2 = true; /* Field is an integer value. Put out the integer. */ if p->nod$a_comment ^= null() then /* any COMMENTS */ msk$v_comment = true; if p->nod$t_typename ^= '' then /* TYPEname specified */ msk$v_typename = true; if p->nod$b_type = nod$k_entrynode & p->nod$t_return_name ^= '' then /* RETURN_NAME field */ msk$v_rtn_name = true; if p->nod$v_mask & p->nod$t_maskstr ^= '' then /* MASKSTR field */ msk$v_maskstr = true; if p->nod$b_boundary ^= 0 then msk$v_boundary = true; /* BOUNDARY field */ if p->nod$l_flags2 ^= '0'b then /* FLAGS2 field */ msk$v_flags2 = true; if mask2$w_fields ^= 0 then /* MASK2 */ msk$v_mask2 = true; /*------------------------------------------------------------------*/ /* Now write out the node type, mask(s), and the fields marked */ /* INTREE assumes this write order. */ call put_int1(p->nod$b_type); /* NOD$B_TYPE */ call put_int2(mask$w_fields); /* MASK1 */ if msk$v_mask2 then /* MASK2 */ call put_int2(mask2$w_fields); if msk$v_hidim then /* NOD$L_HIDIM */ call put_int(p->nod$l_hidim); if msk$v_lodim then /* NOD$L_LODIM */ call put_int(p->nod$l_lodim); if msk$v_initial then /* NOD$L_INITIAL */ call put_int(p->nod$l_initial); if msk$v_offset then /* NOD$L_OFFSET */ call put_int(p->nod$l_offset); if msk$v_fldsiz then /* NOD$L_FLDSIZ */ call put_int(p->nod$l_fldsiz); if msk$v_datatype then /* NOD$W_DATATYPE */ call put_int2(p->nod$w_datatype); if msk$v_flags then /* NOD$L_FIXFLAGS */ call put_int(p->nod$l_fixflags); if msk$v_typeinfo then /* NOD$L_TYPEINFO */ call put_int(p->nod$l_typeinfo); if msk$v_tinfo2_ptr then /* NOD$A_TYPEINFO2 pointer */ call put_int(p->nod$a_typeinfo2->nod$l_nodeid); if msk$v_tinfo2_str then /* NOD$A_TYPEINFO2 string */ call put_string(p->nod$a_typeinfo2->var_string); if msk$v_typeinfo2 then /* NOD$L_TYPEINFO2 integer */ call put_int(p->nod$l_typeinfo2); if msk$v_name then /* NOD$T_NAME */ call put_string(p->nod$t_name); if msk$v_prefix then /* NOD$T_PREFIX */ call put_string(p->nod$t_prefix); if msk$v_marker then /* NOD$T_MARKER */ call put_string(p->nod$t_marker); if msk$v_tag then /* NOD$T_TAG */ call put_string(p->nod$t_tag); if msk$v_naked then /* NOD$T_NAKED */ call put_string(p->nod$t_naked); if msk$v_comment then /* NOD$T_COMMENT */ call put_string(p->nod$a_comment->var_string); if msk$v_typename then /* NOD$T_TYPENAME */ call put_string(p->nod$t_typename); if msk$v_rtn_name then /* NOD$T_RETURN_NAME */ call put_string(p->nod$t_return_name); if msk$v_maskstr then /* NOD$T_MASKSTR */ call put_string(p->nod$t_maskstr); if msk$v_boundary then /* NOD$B_BOUNDARY */ call put_int1(p->nod$b_boundary); if msk$v_flags2 then /* NOD$L_FIXFLAGS2 */ call put_int(p->nod$l_fixflags2); end put_node; /*------------------------------------------------------*/ put_int: procedure( int ); /* Write a 4-byte integer */ dcl int fixed bin(31); dcl int_byte(4) char(1) based(addr(int)); dcl i fixed bin(15); do i = 1 to 4; call put_byte( int_byte(i) ); end; end put_int; /*------------------------------------------------------*/ put_int2: procedure( int ); /* Write a 2-byte integer */ dcl int fixed bin(15); dcl int_byte(2) char(1) based(addr(int)); call put_byte( int_byte(1) ); call put_byte( int_byte(2) ); end put_int2; /*------------------------------------------------------*/ put_int1: procedure( int ); /* Write a 1-byte integer */ dcl int fixed bin(7); dcl int_byte char(1) based(addr(int)); call put_byte( int_byte ); end put_int1; /*------------------------------------------------------*/ put_string: procedure( str ); /* Write a 2-byte length followed by that many characters (bytes) */ dcl str char(*) var; dcl i fixed bin(15); call put_int2( length(str) ); do i = 1 to length(str); call put_byte( substr(str,i,1) ); end; end put_string; /*------------------------------------------------------*/ put_byte: procedure( c ); /* Put a byte into the output buffer. If that fills the buffer, then write the buffer. */ dcl c char(1); buffer_index = buffer_index + 1; substr(buffer,buffer_index,1) = c; if buffer_index = length(buffer) then call write_buffer; end put_byte; /*------------------------------------------------------*/ write_buffer: procedure; /* Write contents of buffer as a fixed length record to file */ if buffer_index = 0 then return; /* nothing in buffer */ /* Clear rest of partial buffer with null bytes for neatness */ do while( buffer_index < length(buffer) ); buffer_index = buffer_index + 1; substr(buffer,buffer_index,1) = byte(0); end; write file(sdifile) from(buffer); buffer_index = 0; end write_buffer; /*------------------------------------------------------*/ end outtree;