/***************************************************************************** * * * 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 read an sdl intermediate file written by the * sdl outtree routine. * * 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 ________________!_______!______________________________________________________ 18-Nov-1984 | kd | 3-0. Add ident field. Make changes to process new | | typename field in the nodes. ________________!_______!______________________________________________________ 20-May-1987 | jw | X3.1-0 Added nod$t_return_name processing ________________!_______!______________________________________________________ 14-Jul-1987 | jw | X3.1-1 Added check to see if the typeinfo2 field | | should contain the address of a structure or | | entry declaration). If so, the data is | | interpreted as the "linear order number" | | (index into the node_address array) used to | | assign the appropriate address to | | nod$a_typeinfo2. | | | | Note: This change corresponds to a change | | in SDLOUTTRE.PLI, both of which comprise | | the one bug fix (SDL_BUGS Note 63). ________________!_______!______________________________________________________ 19-Jul-1987 | jw | X3.1-2 Removed the check described in the previous | | entry; added a similar check for ENTRY | | RETURNS ADDRESS to the process_list routine. | | The entry node's nod$a_typeinfo2 field will | | be assigned the address of the head node | | (which points to the object node) if the | | entry node has a data type of typ$k_address | | and if the head node follows the entry node. | | | | Also, changed the initialization of | | node_index to 2, to remain consistent with | | the starting linear order number generated | | the OUTTREE module (SDLOUTTRE.PLI). | | | | Both of these modifications should complete | | the fixes to the problems described in Note | | 63 of the SDL_BUGS Notes file. ________________!_______!______________________________________________________ 21-Jul-1987 | jw | X3.1-3 Fixed bug reported in SDL_BUGS Note 65: | | UNIONs were not always being included in the | | definition of "aggregate." Added a check | | in the inrec routine to make sure that the | | linear order number of a UNION's item node is | | used for ADDRESS(union-name) and PARAMETER | | of type union-name (corresponding change made | | in module OUTTREE). ________________!_______!______________________________________________________ 22-Jul-1987 | jw | X3.1-4 Fixed bug reported in SDL_BUGS Note 66: | | (A corresponding fix was made in module | | OUTTREE.) Added processing of type nodes | | in routine process_list. ________________!_______!______________________________________________________ 26-Oct-1987 | jw | X3.1-5 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 SDLOUTTRE.PLI, 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 this file, implemented the same kludge | | by interpreting a set OFFSET flag as a | | return_name flag when the node type is ENTRY. ________________!_______!______________________________________________________ 28-Jan-1988 | PG | X3.2-0 Add STRING CONSTANT | | Read in string size and allocate | | accordingly ________________!_______!______________________________________________________ 16-Feb-1988 | jg | X3.2-1 Add processing for user data type, literal | | node, and conditional node. | | Replace magic number 12 for end node type | | with nod$k_endnode, now defined in | | SDLNODEF.SDL. Here it was defined in a | | %replace statement, which is marginally | | better that the raw 12 in SDLOUTTRE. ________________|_______|______________________________________________________ 4-May-92 | jak | EV1-8 Changed name and adapted to support old format | | intermediate files. | | Also fixed bug: old OUTTRE was not writing out | | value of nod$t_maskstr field, so recreate it here | | as was done in sdlaction. ________________|_______|______________________________________________________ 15-Jul-92 | jak | EV1-16 Bug fix: ENTRY RETURNS(usertype) was overwriting | | TYPEINFO2 field with child (parameter list) ptr. ________________|_______|______________________________________________________ **/ %replace MODULE_IDENT by 'EV1-16'; /** * FUNCTIONAL DESCRIPTION: OLDINTREE * * This is the obsolete version of the INTREE routine. This one is * functionally frozen (except for bug fixes). It is called only to * read old (file format 0) intermediate files. Current file format is * supported by the new INTREE routine. * * This routine opens an intermediate tree file that was produced by * the OUTTRE routine with the SDL/PARSE=filespec command. The routine * reads this intermediate form of SDL source code and produces the * tree necessary for the language backends. This tree looks exactly * like the tree that would have been produced, had the SDL parser * produced it from the original source. * * FORMAL PARAMETERS: * * sdi_filein - The file variable for intermediate tree. * * IMPLICIT INPUTS: * * none * * IMPLICIT OUTPUTS: * * the parse tree. * * ROUTINE VALUE: * none * * COMPLETION CODES: * * none * * SIDE EFFECTS: * * Upon completion of this routine, the full sdl parse tree is in * memory starting at external_tree_root. * **/ oldintree: proc (sdi_filein) options( ident(MODULE_IDENT)); /* INCLUDED FILES */ %include 'SDL$LIBRARY:sdlnodef.in'; %include 'SDL$LIBRARY:sdltypdef.in'; %include 'SDL$LIBRARY:sdloldnodmsk.in'; %include pli_file_display; /* GLOBALS VARIABLES */ dcl external_tree_root pointer external ; /* the tree root pointer */ /*CONSTANTS*/ %replace true by '1'b; %replace false by '0'b; /* %replace nod$k_endnode by 12; */ /* jg */ /*LOCALS*/ dcl sdi_filein file variable; /* the intermediate file variable */ dcl (p) pointer init (null()); dcl eof bit(1) init ('0'b); /* flag to be set when the end of the tree file is encountered */ dcl i fixed bin (31); dcl fptr pointer init (null()); dcl comment_size fixed bin (31); dcl based_string char(comment_size) var based ; /* string to hold the comments */ dcl node_index fixed bin (31) init (2); /* index to the node_address array; initialized to 2 to remain consistent with the "linear order numbers" assigned to each node by the OUTTREE module (SDLOUTTRE.PLI). That is, the first node in the intermediate tree (the root node) is assigned the number 2. Obviously, one may obtain the absolute traversal order number for each node by subtracting 1 from node_index. */ dcl node_count fixed bin (31) /* node count stored in the intermediate */ init (0); /* file. */ dcl nod_buf char(510) based ; /* node buffer from the tree file records are 510 bytes */ dcl (buf_ptr,mptr) pointer; /* buffer and mask pointers */ dcl loc_counter fixed bin (31) init (0); /* a location counter for the node buffer (nod_buf) */ dcl temp_int fixed bin (31); dcl cptr pointer init (null()); /* based pointer for the char4 and int_byte array. */ dcl charstring char(1024) init (''); /* string used to store result in get_char routine */ dcl int fixed bin(31) /* fixed binary (31) map */ based (cptr); /* for the longword */ dcl char4(1:4) char(1) /* character map of the */ based (cptr); /* longword. */ dcl int4(1:4) fixed bin (7) /* structure to map integer to */ based (cptr); /* character bytes in get_char routine. */ dcl byte_count fixed bin (7) /* count of number of bytes in */ init (0); /* buffer for get_char and get_int */ dcl string_size fixed bin(31) init (0); /* size of the string to be returned from get_char */ dcl nodes fixed bin (31) init (0); /*** main ***/ on endfile (sdi_filein) begin; eof = '1'b; end; /* Read in the node count which is the contained in the first record of the tree file */ read file (sdi_filein) into (node_count); nodes = node_count; mptr = null(); /* initialize the mask pointer */ call get_node (nodes); return; get_node: proc (vdim); dcl vdim fixed bin (31) ; /* variable dimension for node_address array */ dcl node_address(1:vdim) pointer; /* array of pointers containing node addresses */ dcl array_index fixed bin (31) /* index to the node_address array */ init (0); node_address = null(); /* initialize the array of node addresses */ /* get the node buffer */ allocate nod_buf set (buf_ptr); allocate msk$r_struc set (mptr); /* allocate a mask structure*/ allocate int set (cptr); read file (sdi_filein) into (buf_ptr->nod_buf) ; temp_int = get_int(1); /* kd...extra byte in buffer? This may be due to the node_count that gets written as the first record. CHECK THIS OUT...*/ /* if this is a root node then we must set the external_tree_root */ external_tree_root = inrec(); if external_tree_root->nod$b_type = nod$k_rootnode then call process_list(external_tree_root); else close file (sdi_filein); return; process_list: proc(startp); dcl startp pointer; dcl topitem pointer; dcl (done,already_bound) bit(1); dcl (lastp,current,parent,back) pointer; done = false; /* flag to be set with the end of a circular list */ parent = startp->nod$a_parent; /* the parent for the entire list */ lastp = startp; /* the last node */ back = startp; /* the last node that is not a based pointer - based pointers were implemented without a circular list ? */ already_bound = false; /* flag to indicate that the based ptr. already been bound to a header node */ do while (^done); current = inrec(); /* if this is an aggregate node, an entry node, a module node, or a conditional node then set the topitem pointer to this node. Only these nodes have children. */ if (current->nod$b_type = nod$k_itemnode & (current->nod$w_datatype = typ$k_structure | current->nod$w_datatype = typ$k_union )) | current->nod$b_type = nod$k_entrynode | current->nod$b_type = nod$k_modulnode | current->nod$b_type = nod$k_condnode /* jg */ then topitem = current; /* special case for based pointers */ if lastp->nod$v_bound then do; lastp->nod$a_typeinfo2 = current; current->nod$a_parent = parent; current->nod$a_flink = null(); current->nod$a_blink = null(); lastp = current; /* make the based pointer node the last node - this is the only time back will differ from lastp. */ end; /* * If this is a type node, then the last node must have been an * item node. Set the nod$a_typeinfo2 field of that last item * node to point to this type node (since this type node holds the * name of the pre-defined aggregate whose type is being specified * for the aggregate member represented by that last item node). */ else if current->nod$b_type = nod$k_typnode /* TYPE node */ then do; lastp->nod$a_typeinfo2 = current; current->nod$a_parent = parent; current->nod$a_flink = current; current->nod$a_blink = current; end; else if current->nod$b_type = nod$k_headnode /* HEAD node */ then do; current->nod$a_parent = lastp; /* Any objects or based pointer nodes */ if ((lastp->nod$b_type = nod$k_itemnode | /* based pointer */ lastp->nod$b_type = nod$k_parmnode ) & lastp->nod$w_datatype=typ$k_address ) | (lastp->nod$b_type = nod$k_objnode & /* entry object */ lastp->nod$w_datatype=typ$k_entry) | (lastp->nod$b_type = nod$k_entrynode & /* ENTRY RETURNS ADDRESS */ lastp->nod$w_datatype = typ$k_address) | lastp->nod$w_datatype = typ$k_user | /* user type head/object */ lastp->nod$b_type = nod$k_condnode /* conditional language names */ then do; if ^already_bound /* if this pointer has not yet been bound to an object */ & lastp->nod$a_typeinfo2 = null() /* EV1-16 */ then do; lastp->nod$a_typeinfo2 = current; lastp->nod$a_parent = parent; already_bound = true; end; else do; /* this is to ensure that the top of the structure gets to point to the children and not the based pointer */ if topitem->nod$a_child = null() then topitem->nod$a_child = current; end; end; else do; if topitem->nod$a_child = null() then topitem->nod$a_child = current; current->nod$a_parent = lastp; already_bound = false; end; call process_list (current); end; else if current->nod$b_type = nod$k_endnode /* END-of-LIST node */ then do; startp->nod$a_blink = back; back->nod$a_flink = startp; done = true; free current->nod$_node; /* free up the endnode */ end; else do; if ^lastp->nod$v_bound /* this is to ensure that the flink of the based pointer doesn't get set. */ then do; back->nod$a_flink = current; current->nod$a_blink = back; end; current->nod$a_parent = parent; back = current; lastp = current; already_bound = false; if topitem->nod$a_flink = null() then topitem->nod$a_flink = current; end; end; return; end process_list; /**** get the node from the buffer ****/ inrec: proc returns(pointer); allocate nod$_node set (p); /* allocate a node */ if mptr ^= null() then /* reinitialize the mask fields */ mptr->mask$w_fields = 0; mptr->mask$w_fields = get_int(2); /* get the TYPE of node */ p->nod$b_type = get_int(1); /* if the node is an */ if p->nod$b_type ^= nod$k_endnode /* END-of-LIST node */ then do; node_address (node_index) = p; /* add the address to the array*/ node_index = node_index + 1 ; node_count = node_count - 1; end; /* now go thru the flag and fill in the fields of the node */ if mptr->msk$v_hidim /* NOD$L_HIDIM and */ then do; /* NOD$L_LODIM */ p->nod$l_hidim = get_int(4) ; p->nod$l_lodim = get_int(4) ; end; if mptr->msk$v_initial then do; /* NOD$L_INITIAL */ p->nod$l_initial = get_int(4) ; end; if mptr->msk$v_offset & (p->nod$b_type ^= nod$k_entrynode) then do; /* NOD$L_OFFSET */ p->nod$l_offset = get_int (4) ; end; if mptr->msk$v_fldsiz /* NOD$L_FLDSIZ */ then do; p->nod$l_fldsiz = get_int (4); end; if mptr->msk$v_datatype /* NOD$W_DATATYPE */ then do; p->nod$w_datatype = get_int (2) ; end; if mptr->msk$v_flags /* NOD$L_FIXFLAGS */ then do; p->nod$l_fixflags = get_int (4) ; end; if mptr->msk$v_typeinfo /* NOD$L_TYPEINFO */ then do; p->nod$l_typeinfo = get_int (4) ; end; if mptr->msk$v_typeinfo2 /* NOD$L_TYPEINFO2 */ then do; /* * If typeinfo2 needs to contain a pointer to an aggregate * declaration, or to the defining node for a user type, jg * we know that the next 4 bytes are the linear * order number corresponding to the address of the item node * representing the aggregate; therefore, use that number to * look up the address in the node_address array and assign * to nod$a_typeinfo2. */ if (p->nod$b_type = nod$k_objnode & /* could be a pointer to an aggregate */ (p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union)) | /* or */ p->nod$w_datatype = typ$k_user | /* could be a user type */ (p->nod$b_type = nod$k_parmnode & /* could be a parameter of the type of a previously defined aggregate; */ (p->nod$w_datatype = typ$k_structure | p->nod$w_datatype = typ$k_union)) /* the typeinfo2 field should point BACK to the aggregate */ then do; /* get out the linear order number */ array_index = get_int (4); p->nod$a_typeinfo2 = node_address(array_index); end; else /* put out the field itself */ if ((p->nod$b_type = nod$k_constnode & /* constant string node PG */ p->nod$w_datatype = typ$k_char) | /* or */ p->nod$b_type = nod$k_litnode) /* literal string */ then do; comment_size = get_int(2); allocate based_string set(p->nod$a_typeinfo2); p->nod$a_typeinfo2->based_string = get_char(comment_size); end; else if (p->nod$w_datatype = typ$k_vield | p->nod$w_datatype = typ$k_decimal) /* EV1-16 */ then p->nod$l_typeinfo2 = get_int (4); else temp_int = get_int (4); /* discard */ end; if mptr->msk$v_name /* NOD$T_NAME */ then do; string_size = get_int(2); p->nod$t_name = get_char (string_size); end; if mptr->msk$v_prefix /* NOD$T_PREFIX */ then do; string_size = get_int(2); p->nod$t_prefix = get_char (string_size); end; if mptr->msk$v_marker /* NOD$T_MARKER */ then do; string_size = get_int(2); p->nod$t_marker = get_char (string_size); end; if mptr->msk$v_tag /* NOD$T_TAG */ then do; string_size = get_int(2); p->nod$t_tag = get_char (string_size); end; if mptr->msk$v_naked /* NOD$T_NAKED */ then do; string_size = get_int(2); p->nod$t_naked = get_char(string_size); end; if mptr->msk$v_comment /* NOD$T_COMMENT */ then do; comment_size = get_int(2); allocate based_string set (p->nod$a_comment); p->nod$a_comment->based_string = get_char(comment_size); end; if mptr->msk$v_typename /* NOD$T_TYPENAME */ then do; string_size = get_int(2); p->nod$t_typename = get_char(string_size); end; if mptr->msk$v_offset & (p->nod$b_type = nod$k_entrynode) /* NOD$T_RETURN_NAME */ then do; string_size = get_int(2); p->nod$t_return_name = get_char(string_size); end; if p->nod$b_type = nod$k_constnode & p->nod$v_mask then /* NOD$T_MASKSTR */ p->nod$t_maskstr = hexstr(p->nod$l_typeinfo); return (p); end inrec; hexstr: proc (val) returns(char(8) var); dcl val fixed bin(31); dcl k fixed bin(31); dcl (str,tmp) char(8) var; if val = 0 then return('0'); str = ''; k = val; do while( k ^= 0 ); tmp = str; str = substr('0123456789ABCDEF',mod(k,16)+1,1) || tmp; if k >= 0 then k = divide(k,16,31); else do; /* take out sign bit, divide by 16, put sign bit back */ k = k + 2147483647; /* 0x80000000 - 1 */ k = divide(k+1,16,31) + 134217728; /* + 0x08000000 */ end; end; return(str); end hexstr; get_char: proc (size) returns (char(*)) ; dcl size fixed bin (31); /* size in bytes */ byte_count = 0; charstring = ' '; do while (byte_count < size); byte_count = byte_count + 1; /* increment the index to the char_byte array */ substr(charstring, byte_count, 1) = substr(buf_ptr->nod_buf, loc_counter, 1) ; /* increment the counter in the output buffer. */ if (loc_counter = 510 ) /* if the buffer is full */ then do ; buf_ptr->nod_buf = ' '; /* init the buffer*/ loc_counter = 1 ; read file (sdi_filein) into (buf_ptr->nod_buf); end; loc_counter = loc_counter + 1; end; return (substr(charstring,1,size)); end get_char; get_int: proc(size) returns (fixed bin(31)) ; dcl size fixed bin (31); /* size in bytes */ byte_count = 0; if cptr ^= null then cptr->int = 0; do while (byte_count < size ); byte_count = byte_count + 1; /* increment the index to the char4 array */ cptr->char4(byte_count) = substr(buf_ptr->nod_buf, loc_counter, 1); /* increment the counter in the output buffer. */ if (loc_counter = 510 ) /* if the buffer is full */ then do ; buf_ptr->nod_buf = ' '; /* init the buffer*/ loc_counter = 1 ; read file (sdi_filein) into (buf_ptr->nod_buf); end; loc_counter = loc_counter + 1; end; return (cptr->int); end get_int; end get_node; end oldintree;