From:	EMSLRT::COATS        28-JAN-1988 08:12
To:	VAXTM1::XCC
Subj:	TPU program

!       This is the SPERRY Marine EVE Listing facility. The TPU procedures in
!       this file allow the user to create a compiler or RUNOFF listing of the
!       current buffer without leaving the editor or writing scratch files.
!       The LIST file is displayed along with the source buffer on a split
!       screen. 
!
!	Currently the following compilers and utilities are supported:
!
!		Utility			EVE command
!		-------			-----------
!		C			CC
!		FORTRAN			FORTRAN
!		PASCAL			PASCAL
!		RUNOFF			RUNOFF
! 
! 
!	Use the following DCL commands to compile this file: 
!
!	$ ASSIGN/USER_MODE SYS$DISK:'F$DIRECTORY()' TPU$EVEPLUS 
!       $ EDIT/TPU/NODISPLAY/SECTION=SYS$SHARE:EVESECINI - 
!	        /COMMAND=TPU$EVEPLUS:LIST.TPU
! 
!	A TPU section file - EVEANDEDT.TPU$SECTION will be created in the 
!	current directory. 
! 
!
!          Written by : Scott E. Smith 
!			Sperry Marine Inc. 
!			Charlottesville, VA  22906
!                       (804) 973-0186 
! 
!	Version: 23-Apr-1987 
! 
! 
! 
! 
!
procedure evextend$list_init_buffer 

local new_buffer;

on_error
 return;		! quit if buffer already exist
endon_error;                  

 new_buffer := create_buffer ("LIST Buffer");
 set (margins, new_buffer, 1, 512);
 set (eob_text, new_buffer, eve$x_null);
 set (no_write, new_buffer);
 set (system, new_buffer);
 evextend$list_buffer := new_buffer;
endprocedure;
!
!
!	Convert all RUNOFF LN01 escape sequences in the List Buffer to markers
!
procedure evextend$fix_escapes

local
   start_marker,
   end_marker,                                                     
   found_range,                                                           
   vid_count;
      
on_error
 if error <> tpu$_strnotfound
 then return
 endif;
endon_error;

start_marker := beginning_of (evextend$list_buffer);
set (insert, evextend$list_buffer);
position (start_marker);				! Delete the LN01 header
position (search (ascii(12), forward, exact));		! information
end_marker := mark (none);
erase (create_range (start_marker, end_marker, none));
position (beginning_of (evextend$list_buffer));
loop								! loop through
 found_range := search (ascii(27)+'[13m', forward, exact);	! file and fix
 exitif found_range = 0;					! matched sets
 position (found_range);     					! of escape
 erase (found_range);                                           ! sequences.
 execute ('vid_mark_'+str(vid_count)+':=mark(none);');
 found_range := search (ascii(27)+'[12m', forward, exact);
 exitif found_range = 0;
 position (found_range);
 erase (found_range);
 move_horizontal (-1);
 execute ('vid_range'+str(vid_count)+
	':=create_range (vid_mark_'+str(vid_count)+',mark(none),bold)');
 vid_count := vid_count + 1;
endloop;
position (beginning_of (evextend$list_buffer));
loop
 found_range := search (ascii(27)+'[14m', forward, exact);
 exitif found_range = 0;
 position (found_range);
 erase (found_range);
 execute ('vid_mark_'+str(vid_count)+':=mark(none);');
 found_range := search (ascii(27)+'[12m', forward, exact);
 exitif found_range = 0;
 position (found_range);
 erase (found_range);
 move_horizontal (-1);
 execute ('vid_range'+str(vid_count)+
	':=create_range (vid_mark_'+str(vid_count)+',mark(none),underline)');
 vid_count := vid_count + 1;
endloop;
position (beginning_of (evextend$list_buffer));               
loop
 found_range := search (ascii(27)+'[15m', forward, exact);
 exitif found_range = 0;
 position (found_range);
 erase (found_range);
 execute ('vid_mark_'+str(vid_count)+':=mark(none);');
 found_range := search (ascii(27)+'[12m', forward, exact);
 exitif found_range = 0;
 position (found_range);
 erase (found_range);
 move_horizontal (-1);
 execute ('vid_range'+str(vid_count)+
	':=create_range (vid_mark_'+str(vid_count)+',mark(none),bold)');
 execute ('vid_range'+str(vid_count+1)+
	':=create_range (vid_mark_'+str(vid_count)+',mark(none),underline)');
 vid_count := vid_count + 2;
endloop;
position (beginning_of (evextend$list_buffer));
loop
 found_range := search (ascii(13)+ascii(10), forward, exact);
 exitif found_range = 0;
 position (found_range);
 erase_line;                                                              
endloop;
endprocedure;
!
!+
!	FIX_CRLFS.TPU - Routine to turn CRLFs into line breaks 
!			and remove leading CRs and trailing CRLFs 
!
!	This procedure take from EVEPlus Version A-15 - DECUS Edition
!-

procedure eve_fix_crlfs 

LOCAL	the_range;

    on_error
        if (ERROR <> tpu$_STRNOTFOUND) then
            message("Error (" + str(ERROR) + ") at line " + str(ERROR_LINE));
            return;
        endif;
    endon_error;

!
! First remove the CRLFs. If they are not at the EOL, add a line break.
!
    position(beginning_of(current_buffer));
    loop
        the_range := search(ascii(13)+ascii(10), FORWARD);
        exitif (the_range = 0);
        erase(the_range);
        position(beginning_of(the_range));
        if (current_character <> "") then
            split_line;
        endif;
    endloop;
!
! Next remove naked LFs. If they are not at the EOL, add a line break.
!
    position(beginning_of(current_buffer));
    loop
        the_range := search(ascii(10), FORWARD);
        exitif (the_range = 0);
        erase(the_range);
        position(beginning_of(the_range));
        if (current_character <> "") then
            split_line;
        endif;
    endloop;
!
! Finally, remove naked CRs. If they are not at the BOL, add a line break.
!
    position(beginning_of(current_buffer));
    loop
        the_range := search(ascii(13), FORWARD);
        exitif (the_range = 0);
        position(end_of(the_range));
        if (current_offset <> 0) then
            split_line;
        endif;
        erase(the_range);
    endloop;

endprocedure

!
!
!
!
procedure evextend$list (list_command_line, fix_escapes, fix_crlfs)

local this_buffer,		! Current buffer
      error_line;		! Last error returned in the list buffer

on_error
    if error = tpu$_createfail then
	message ("DCL subprocess could not be created");
	return (0);
    endif;
endon_error;

evextend$list_init_buffer; 
if (get_info (evextend$x_dcl_process, "type") = unspecified) or
   (evextend$x_dcl_process = 0) then
    evextend$x_dcl_process := create_process (evextend$list_buffer, 
		"$ set noon");
endif;

this_buffer := current_buffer;
                                      
erase (evextend$list_buffer);  
send (list_command_line, evextend$x_dcl_process);
send (this_buffer, evextend$x_dcl_process);
send_eof (evextend$x_dcl_process);
!
position (end_of (evextend$list_buffer));  ! Show the last error message if any
loop
 error_line := search ('%', REVERSE);
 exitif (error_line = 0);
 position (error_line);
 exitif (current_offset = 0);
endloop;
if (error_line <> 0)                                              
then message (current_line);
endif;
!
if fix_escapes then evextend$fix_escapes endif;
if fix_crlfs   then eve_fix_crlfs endif;
!
position (beginning_of (evextend$list_buffer));
if this_buffer <> evextend$list_buffer then
    if eve$x_number_of_windows = 2 then
	eve_other_window;
	if current_buffer <> evextend$list_buffer then
      	    map (current_window, evextend$list_buffer);
	endif;
    else
	unmap (eve$main_window);
	map (eve$top_window, this_buffer);
	eve$set_status_line (eve$top_window);
 	update (eve$top_window);
	map (eve$bottom_window, evextend$list_buffer);
	eve$x_number_of_windows := 2;                                   
	eve$x_this_window := eve$bottom_window;
    endif;
endif;

set (status_line, current_window, reverse, " LIST Buffer");
update (current_window);

return (1);                

endprocedure;
             
!
!
!
procedure eve_cc
 set (timer, on, 'working');
 evextend$list ('$ CC/NOOBJECT/LIST=SYS$OUTPUT SYS$INPUT',
	false, false);	! Don't fix escapes or crlfs.
 set (timer, off);
endprocedure;

procedure eve_fortran
 set (timer, on, 'working');
 evextend$list ('$ FORTRAN/NOOBJECT/LIST=SYS$OUTPUT SYS$INPUT',
	false, true);	! Fix crlfs only.
 set (timer, off);
endprocedure;

procedure eve_pascal
 set (timer, on, 'working');
 evextend$list('$ PASCAL/NOOBJECT/NOERROR_LIMIT/LIST=SYS$OUTPUT SYS$INPUT',
	false, false);	! Don't fix escapes or crlfs.
 set (timer, off);
endprocedure;

procedure eve_runoff
 set (timer, on, 'formatting');
 evextend$list
   ('$ runoff/output=sys$output/device=ln01/noright/messages=output/var=vt100'+
   ' sys$input', true, false);	! Fix escapes sequences only.
 set (timer, off);
endprocedure;
!
!
! Save the extended section file, and quit.
save ("tpu$eveplus:eveandedt");    ! and save the extended section
quit;