/* ***************************************************************************** * * * Copyright (c) 1978, 1979, 1980, 1987 * * 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: Generates the FORTRAN language output from the SDL tree. author: Rich Grove date: 31-JUL-1981 revised 22-DEC-1980 ctp revised 30-JUN-1982 ls version 1.5 changes revised 15-APR-1983 kd fix accvio bug with FILL attribute revised 10-Apr-1984 kd make changes necessary to convert to a shareable image for V2. revised 19-Nov-1987 jw [V3.1-1] Converted some recursion involving OUTPUTNODE to a DO WHILE in order to prevent an over-consumption of dynamic memory; changed the name of the first formal parameter of OUTPUTNODE and assigned its value to the "walking" pointer. revised 13-Feb-1990 William R. Vales Make changes to record Robert Thomson dependency data for VMS VDE [V3.1-VMS1] system builder. (see CHANGE LOG) revised 8-Jun-1992 jak EV1-14 Change first arg of sdl$putline to "outfile". */ %replace MODULE_IDENT by 'EV1-14'; sdl$output: proc (out_file, def_filename, sdl$_shr_data) options(ident(MODULE_IDENT)); %include 'sdl$library:sdlnodef.in'; /* include node structure definition */ %include 'sdl$library:sdltypdef.in'; /* include data type definitions */ %include 'sdl$library:sdlmsgdef.in'; /* include error message interface */ %include 'sdl$library:sdlshr.in'; /* include shared data - shared with the front end and passed as an argument to the backends */ %include 'SDL$LIBRARY:filedef.in'; /* rms file definitions */ %replace line_length by 120; %replace lang_ext by '.for'; /* extension for fortran */ %replace k_buf by '0'b; /* flags for puttyp */ %replace k_out by '1'b; dcl types(20) char (32) var; /* the data type equivalents */ types(typ$k_address) = 'INTEGER*4'; types(typ$k_byte) = 'BYTE '; types(typ$k_boolean) = 'BYTE '; types(typ$k_char) = 'CHARACTER'; types(typ$k_decimal) = ''; types(typ$k_double) = 'REAL*8 '; types(typ$k_float) = 'REAL*4 '; types(typ$k_grand) = 'REAL*8 '; types(typ$k_huge) = 'REAL*16 '; types(typ$k_longword) = 'INTEGER*4'; types(typ$k_octaword) = ''; types(typ$k_quadword) = ''; types(typ$k_vield) = ''; types(typ$k_word) = 'INTEGER*2'; types(typ$k_structure) = ''; types(typ$k_union) = ''; types(typ$k_any) = ''; dcl xptr ptr; /* pointer to level-1 aggregate */ dcl output_file file output record sequential; dcl out_file char(128) var ; dcl def_filename char(132) var; dcl buf char(1024) var; dcl based_string char(1024) var based; dcl tab char(1) initial(byte(9)); /* Declare variables needed for getting a fully resolved file specification. The resolved file specification will be recorded as a dependency for the VDE system builder through the LIB$REC_DEPENDENCY interface. */ dcl vde_filename char(128) var init (''); /* input source file name */ dcl vde_input_file file variable static; dcl vde_in_file pointer initial(addr(vde_input_file)); dcl vde_in_file_ptr pointer based (vde_in_file); dcl vde_esa_area char(120) static; dcl vde_addr_esa_area pointer initial(addr(vde_esa_area)); dcl vde_rsa_area char(120) static; dcl vde_addr_rsa_area pointer initial(addr(vde_rsa_area)); dcl vde_full_name pointer; dcl vde_result_name char(132) based (vde_full_name) ; /*** main ***/ /* Set up file structures for receiving the fully resolved language specific output file from the open call. The fully resolved output file, file specification is passed back to the front end through the variable vde_lang_file which is declared in the shared data area (SDLSHR.SDL). */ vde_input_file = output_file; /* set up name block */ vde_in_file_ptr->nam$l_esa = vde_addr_esa_area; vde_in_file_ptr->nam$b_ess = 120; vde_in_file_ptr->nam$l_rsa = vde_addr_rsa_area; vde_in_file_ptr->nam$b_rss = 120; /* concatenate the extension for the language */ open file (output_file) title (out_file) environment (default_file_name( def_filename || lang_ext) ); outfile = output_file; /* equate the file with the file variable in the shared structure */ /* output the little SDL header with time and date info */ call sdl$header(sdl$_shr_data, '! ','',line_length); /* begin at the root of the tree, and let it go */ call outputnode(tree_root->nod$a_flink,tree_root,0); /* Get the fully resolved language specific output file and and move it the shared data area for the front-end. The reultant name will be recorded as a file dependency for the VDE system builder. */ vde_full_name = vde_in_file_ptr->nam$l_rsa; vde_filename = vde_result_name; vde_lang_file = substr( vde_result_name, 1, vde_in_file_ptr->nam$b_rsl); return; /** print node routine **/ outputnode: proc (initp,startp,level); /* parameters: initp = address of node to output startp = address of where we started (i.e. where to stop in traversing a circular list ) level = level number of aggregate (incremented by 1 with each sub-aggregate */ dcl (initp,p,startp,q) ptr; dcl level fixed bin(31); dcl tmpbuf char(32) var; dcl i fixed bin(31); /* * "p" will walk the associated list, if one exists. */ p = initp; /* * Case on the node type and go do the appropriate processing */ do while (p ^= startp); goto case(p->nod$b_type); case(nod$k_rootnode): /* nothing done here except to move on to list of module nodes of which this is the head */ buf=''; goto common_2; case(nod$k_commnode): /* clear the buffer and let the common stuff output the comment line */ buf=''; goto common; case(nod$k_constnode): /* do a straightforward PARAMETER for the constant node */ if index(p->nod$t_name, '_fill_') + index(p->nod$t_name, '$$fill_') ^= 0 then goto common_2; buf='PARAMETER '||p->nod$t_name||' = '; /* All constants are put out in Hex form, to avoid inappropriate typing and conversion (as small integer constants. It would be nice if the tree contained the radix used in the SDL source specification of the constant. But lacking that, hex is safest! */ buf=buf||hexval(p->nod$l_typeinfo); goto common; case(nod$k_entrynode): /* declare an external entry point */ /* if it's a function, output the datatype */ if p->nod$w_datatype^=0 & types(p->nod$w_datatype)^='' then call puttype(p, k_out); buf='EXTERNAL '||p->nod$t_name; goto common; case(nod$k_itemnode): if level=1 then do; xptr=p; /*initialize xptr to level 1 aggregate */ if p->nod$v_common then do; buf='COMMON /'||p->nod$t_name||'/ '||p->nod$t_name; call sdl$putline (outfile, tab||buf,line_length); end; end; if p->nod$v_userfill /* if user specified FILL attribute */ then goto common_2; /* don't output aggregate name symbol*/ if (level>1) & (p->nod$w_datatype ^= typ$k_vield) then do; buf='EQUIVALENCE ('|| xptr->nod$t_name||'('||trim(p->nod$l_offset+1)||'), '|| p->nod$t_name||')'; call sdl$putline (outfile, tab||buf,line_length); end; call puttype(p, k_buf); goto common; case(nod$k_modulnode): /* put out the module name as a comment */ call sdl$putline (outfile, ' ',line_length); buf='!*** MODULE '||p->nod$t_name; if p->nod$t_naked ^= '' then buf=buf || ' IDENT '||p->nod$t_naked; buf=buf||' ***'; call sdl$putline (outfile, buf,line_length); buf=''; goto common; case(nod$k_parmnode): buf=''; goto common_2; case(nod$k_objnode): /* ignore object nodes-- FORTRAN doesn't care what a pointer is pointing to */ buf=''; goto common_2; case(nod$k_headnode): /* nothing done with head nodes-- just use them to move down a circular list */ buf=''; goto common_2; common: /* if there is attached comment, then append it to end of line and output it */ if p->nod$a_comment^=null() & buf^='' then buf=fill2(buf,40); if buf^='' then buf=tab||buf; if p->nod$a_comment^=null() then buf=buf||'! '||p->nod$a_comment->based_string; call sdl$putline (outfile, buf,line_length); buf=''; common_2: /* travel down the child node */ if p->nod$a_child^=null() then call outputnode(p->nod$a_child->nod$a_flink,p->nod$a_child,level+1); common_3: /* * Travel across the circular list to the sibling node */ p = p->nod$a_flink; end; /* do while */ return; /** puttype **/ /* format the datatype information for an item */ puttype: proc(p,outflag); dcl p ptr; dcl dim char(32) var; dcl outflag bit(1); dcl (pos,siz) fixed bin(31); dim=''; buf=types(p->nod$w_datatype); if p->nod$w_datatype=typ$k_decimal then do; buf='BYTE '; siz=divide(p->nod$l_typeinfo, 2, 31) + 1; dim=trim(siz); end; if p->nod$w_datatype=typ$k_quadword then do; buf='INTEGER*4'; dim='2'; end; if p->nod$w_datatype=typ$k_octaword then do; buf='INTEGER*4'; dim='4'; end; if p->nod$w_datatype=typ$k_char then do; siz = p->nod$l_typeinfo; if p->nod$v_varying then siz = siz+2; if p->nod$v_varying then do; if (p->nod$b_type = nod$k_itemnode) then do; if ^p->nod$v_dimen then do; call sdl$putline (outfile, tab||'INTEGER*2 '||p->nod$t_name||'_LEN', line_length); call sdl$putline (outfile, tab||'CHARACTER*'||trim(siz-2)||' '||p->nod$t_name||'_TXT', line_length); call sdl$putline (outfile, tab||'EQUIVALENCE', line_length); call sdl$putline (outfile, tab||'1 ('||p->nod$t_name||'_LEN, '||p->nod$t_name||'),', line_length); call sdl$putline (outfile, tab||'2 ('||p->nod$t_name||'_TXT, '||p->nod$t_name||'(3:))', line_length); end; end; end; if siz=0 then siz=1; buf=buf||'*'||trim(siz); end; if p->nod$w_datatype=typ$k_vield then do; pos = p->nod$l_typeinfo2; siz = p->nod$l_typeinfo; buf = 'PARAMETER '||p->nod$t_prefix; call sdl$putline (outfile, tab||buf||'S_'||p->nod$t_naked||' = '||trim(siz), line_length); buf = buf||'V_'||p->nod$t_naked||' = '||trim(pos); end; else do; if buf='' then do; buf='BYTE '; dim=trim(p->nod$l_fldsiz); end; buf=buf||' '||p->nod$t_name; end; /* if there is a dimension, append it */ if (p->nod$v_dimen) & (p->nod$w_datatype ^= typ$k_vield) then do; if dim^='' then dim=dim||','; dim=dim||trim(p->nod$l_lodim)||':'||trim(p->nod$l_hidim); end; if dim^='' then buf=buf||'('||dim||')'; if outflag then do; call sdl$putline (outfile, tab||buf, line_length); buf=''; end; if p->nod$w_datatype = typ$k_structure & p->nod$a_typeinfo2 ^= null() & p->nod$a_typeinfo2->nod$b_type = nod$k_typnode then call errmsg(sdl$_shr_data, sdl$_typnam,p->nod$l_srcline,); return; end puttype; end outputnode; /** fill **/ /* fill out the statement part of a short statement to n characters */ fill2: proc(a,n) returns (char(line_length) var); dcl n fixed bin, ntabs fixed bin, nblks fixed bin; dcl a char(*) var; dcl b char(line_length) var; b = a; if length(b) < n then do; ntabs = divide(n,8,31) - divide(length(b),8,31); if ntabs>0 then nblks=mod(n,8); else nblks=n-length(b); b = b || copy(tab,ntabs) || copy(' ',nblks); end; else b = b||' '; return (b); end fill2; /** hexval **/ /* generate a FORTRAN hexadecimal constant form */ HEXVAL: proc(i) returns (char(11)); dcl i fixed bin(31); dcl hexstr char(8); dcl ots$cvt_l_tz entry(fixed bin(31),char(*),fixed bin(31) value); call ots$cvt_l_tz(i, hexstr, 8); return (''''||hexstr||'''X'); end hexval; end sdl$output;