Programmer's ROM - The Computer Language Library

home *** CD-ROM | disk | FTP | other *** search

/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / edit / wpformat.src < prev

Wrap

Text File | 1988-05-03 | 475.4 KB | 10,499 lines

--:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntglob --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTGLOB -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Energy Systems Group -- Ada Software Development Project Team -- 2280 U.S. Highway 19 North, Suite 120 -- Clearwater, Florida 33575 -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with text_io ; -- for input with direct_io ; -- for output with io_exceptions ; with unchecked_conversion ; with string_library ; use string_library ; with basic_io_system ; with crt_windows ; use crt_windows ; with Wordp_Globals ; use Wordp_Globals ; Package Printer_globals is --------------------------------------------------------------------------- -- -- -- Start of types which are used by global callers to text formatter -- -- -- --------------------------------------------------------------------------- type printer_type is ( z_pdumb , z_pbackspace , z_qume , z_citoh , z_diablo , z_HP_laser_Printer , z_xerox , z_n3500 , z_n3510 , z_n3550 , z_n3515 , z_cent737 , z_aj832 , z_starwriter , z_dataproducts , z_la50 , z_lqp02 , z_la100draft , z_la100medium , z_la100high , z_unknown ) ; type printer_accessories_type is ( none , trayloader , dual_tray , mech_tray ) ; subtype Font_Number is integer ; -- Now, format commands type ot_format_type is (ot_fancy , ot_plain) ; type where_to_type is (to_screen , to_printer , to_file) ; type inp_source_type is (fm_database , fm_text) ; type formatter_environment is record Printer_Brand : Printer_Type := z_unknown ; Printer_Accessories: Printer_Accessories_Type := none ; Continuous_Forms : Boolean := true ; number_of_copies_to_print : integer := 1 ; First_Page_to_Print : integer := 1 ; Last_Page_to_Print : integer := integer'last ; ot_format : ot_format_type := ot_fancy ; where_to : where_to_type := to_printer ; inp_source : inp_source_type := fm_text ; Database_File_Name : ascii_text_file_name := no_file ; Font_To_Use : Font_Number := 0 ; Show_Output_Status : Boolean := true ; end record ; default_environment : constant formatter_environment := ( z_unknown , none , true , 1 , 1 , integer'last , ot_fancy , to_printer , fm_text , no_file , 0 , true ) ; --------------------------------------------------------------------------- -- -- -- End of types which are used by global callers to text formatter -- -- -- --------------------------------------------------------------------------- -- Font Information Font_file : constant string := "TYPEFONT.DATA" ; subtype Font_name_type is string ( 1 .. 25 ) ; subtype extended_character is basic_io_system.extended_character ; type a_map_string is array ( 1 .. 3 ) of extended_character ; subtype horizontal_measurement is integer range - 14 * 720 .. 14 * 720 ; -- because largest measurement is 14" paper wide -- by 720 points per inch subtype vertical_measurement is integer range 0 .. 14 * 720 ; -- becuase largest vertical measurement is 14" -- long by 720 per inch type width_array is array ( extended_character ) of horizontal_measurement ; type hammer_array is array ( extended_character ) of integer ; type map_array is array ( extended_character ) of a_map_string ; type Font_type is record name : Font_name_type ; Number : Font_Number ; vertical_points_per_inch : vertical_measurement ; horizontal_points_per_inch : horizontal_measurement ; Font_Width : horizontal_measurement ; Font_Height: Vertical_Measurement ; width : width_array ; hammer_intensity : hammer_array ; Mappings_Necessary : boolean ; map_string : map_array ; end record ; default_font : font_type ; -- assigned in the initialization code Permanent_Font : font_type ; Temporary_Font : font_type ; Current_Font : font_type ; Font_Width : horizontal_measurement ; -- For Permanent Font Space_Width : horizontal_measurement ; -- For Current Font Half_Space_Width : horizontal_measurement ; -- For Current Font default_printer : constant ascii_text_file_name := "PRINTER: "; default_console : constant ascii_text_file_name := "CONSOLE: "; initial_environment : formatter_environment ; current_environment : formatter_environment ; type smart_printer_type is (z_dumb , z_backspace , z_smart) ; type proportional_printer_type is (z_p_centronics , z_p_qume , z_p_diablo) ; z_proportional : proportional_printer_type ; z_smart_printer : smart_printer_type ; z_printer : printer_type ; z_forward : boolean ; permanent_printer : printer_type ; printer_accessories: printer_accessories_type ; printer_points_per_inch : horizontal_measurement ; printer_vertical_per_inch : vertical_measurement ; we_have_some_tray_loader : boolean ; we_have_single_tray_loader : boolean ; we_have_dual_tray_loader : boolean ; master_window : crt_windows.window_pointer ; type input_file_type is ( main_input_file , alternate_input_file , variable_input_file ) ; main_in_file_name : ascii_text_file_name := no_file ; alt_in_file_name : ascii_text_file_name := no_file ; var_in_file_name : ascii_text_file_name := no_file ; ot_file_name : ascii_text_file_name := no_file ; copies_printed_so_far: integer ; Physical_Page_Number : Integer ; Physical_Input_Lines : Integer ; Physical_Output_Lines: Integer ; where_to_read : input_file_type ; extended_nul : constant extended_character := extended_character ( character'pos( ascii.nul ) ) ; -- extended_soh : constant extended_character -- := extended_character ( character'pos( ascii.soh ) ) ; -- extended_stx : constant extended_character -- := extended_character ( character'pos( ascii.stx ) ) ; -- extended_etx : constant extended_character -- := extended_character ( character'pos( ascii.etx ) ) ; -- extended_eot : constant extended_character -- := extended_character ( character'pos( ascii.eot ) ) ; -- extended_enq : constant extended_character -- := extended_character ( character'pos( ascii.enq ) ) ; -- extended_ack : constant extended_character -- := extended_character ( character'pos( ascii.ack ) ) ; -- extended_bel : constant extended_character -- := extended_character ( character'pos( ascii.bel ) ) ; extended_bs : constant extended_character := extended_character ( character'pos( ascii.bs ) ) ; extended_ht : constant extended_character := extended_character ( character'pos( ascii.ht ) ) ; extended_lf : constant extended_character := extended_character ( character'pos( ascii.lf ) ) ; -- extended_vt : constant extended_character -- := extended_character ( character'pos( ascii.vt ) ) ; extended_ff : constant extended_character := extended_character ( character'pos( ascii.ff ) ) ; extended_cr : constant extended_character := extended_character ( character'pos( ascii.cr ) ) ; extended_so : constant extended_character := extended_character ( character'pos( ascii.so ) ) ; extended_si : constant extended_character := extended_character ( character'pos( ascii.si ) ) ; -- extended_dle : constant extended_character -- := extended_character ( character'pos( ascii.dle ) ) ; -- extended_dc1 : constant extended_character -- := extended_character ( character'pos( ascii.dc1 ) ) ; -- extended_dc2 : constant extended_character -- := extended_character ( character'pos( ascii.dc2 ) ) ; -- extended_dc3 : constant extended_character -- := extended_character ( character'pos( ascii.dc3 ) ) ; -- extended_dc4 : constant extended_character -- := extended_character ( character'pos( ascii.dc4 ) ) ; -- extended_nak : constant extended_character -- := extended_character ( character'pos( ascii.nak ) ) ; -- extended_syn : constant extended_character -- := extended_character ( character'pos( ascii.syn ) ) ; -- extended_etb : constant extended_character -- := extended_character ( character'pos( ascii.etb ) ) ; -- extended_can : constant extended_character -- := extended_character ( character'pos( ascii.can ) ) ; -- extended_em : constant extended_character -- := extended_character ( character'pos( ascii.em ) ) ; -- extended_sub : constant extended_character -- := extended_character ( character'pos( ascii.sub ) ) ; extended_esc : constant extended_character := extended_character ( character'pos( ascii.esc ) ) ; -- extended_fs : constant extended_character -- := extended_character ( character'pos( ascii.fs ) ) ; -- extended_gs : constant extended_character -- := extended_character ( character'pos( ascii.gs ) ) ; -- extended_rs : constant extended_character -- := extended_character ( character'pos( ascii.rs ) ) ; -- extended_us : constant extended_character -- := extended_character ( character'pos( ascii.us ) ) ; extended_space : constant extended_character := extended_character ( character'pos( ' ' ) ) ; extended_zero : constant extended_character := extended_character ( character'pos( '0' ) ) ; extended_one : constant extended_character := extended_character ( character'pos( '1' ) ) ; -- extended_two : constant extended_character -- := extended_character ( character'pos( '2' ) ) ; -- extended_three : constant extended_character -- := extended_character ( character'pos( '3' ) ) ; -- extended_four : constant extended_character -- := extended_character ( character'pos( '4' ) ) ; -- extended_five : constant extended_character -- := extended_character ( character'pos( '5' ) ) ; -- extended_six : constant extended_character -- := extended_character ( character'pos( '6' ) ) ; -- extended_seven : constant extended_character -- := extended_character ( character'pos( '7' ) ) ; -- extended_eight : constant extended_character -- := extended_character ( character'pos( '8' ) ) ; extended_nine : constant extended_character := extended_character ( character'pos( '9' ) ) ; extended_UC_A : constant extended_character := extended_character ( character'pos( 'A' ) ) ; extended_UC_S : constant extended_character := extended_character ( character'pos( 'S' ) ) ; extended_UC_Z : constant extended_character := extended_character ( character'pos( 'Z' ) ) ; extended_lc_a : constant extended_character := extended_character ( character'pos( 'a' ) ) ; extended_lc_z : constant extended_character := extended_character ( character'pos( 'z' ) ) ; extended_quote : constant extended_character := extended_character ( character'pos( ''' ) ) ; extended_exclam : constant extended_character := extended_character ( character'pos( ascii.exclam)); extended_quotation : constant extended_character := extended_character(character'pos(ascii.quotation)); -- extended_sharp : constant extended_character -- := extended_character ( character'pos( ascii.sharp )); -- extended_dollar : constant extended_character -- := extended_character ( character'pos( ascii.dollar)); extended_percent : constant extended_character := extended_character ( character'pos(ascii.percent)); extended_ampersand : constant extended_character := extended_character(character'pos(ascii.ampersand)); -- extended_colon : constant extended_character -- := extended_character ( character'pos( ascii.colon )); -- extended_semicolon : constant extended_character -- := extended_character(character'pos(ascii.semicolon)); -- extended_query : constant extended_character -- := extended_character ( character'pos( ascii.query )); extended_at_sign : constant extended_character := extended_character ( character'pos(ascii.at_sign)); -- extended_l_bracket : constant extended_character -- := extended_character(character'pos(ascii.l_bracket)); -- extended_back_slash: constant extended_character -- :=extended_character(character'pos(ascii.back_slash)); -- extended_r_bracket : constant extended_character -- := extended_character(character'pos(ascii.r_bracket)); -- extended_circumflex: constant extended_character -- :=extended_character(character'pos(ascii.circumflex)); extended_underline : constant extended_character := extended_character(character'pos(ascii.underline)); -- extended_grave : constant extended_character -- := extended_character ( character'pos( ascii.grave )); -- extended_l_brace : constant extended_character -- := extended_character ( character'pos(ascii.l_brace)); -- extended_bar : constant extended_character -- := extended_character ( character'pos( ascii.bar ) ) ; -- extended_r_brace : constant extended_character -- := extended_character ( character'pos(ascii.r_brace)); -- extended_tilde : constant extended_character -- := extended_character ( character'pos( ascii.tilde )); -- extended_plus : constant extended_character -- := extended_character ( character'pos( '+' ) ) ; extended_minus : constant extended_character := extended_character ( character'pos( '-' ) ) ; extended_del : constant extended_character := extended_character ( character'pos( ascii.del ) ) ; procedure open_for_read ( file_to_open : input_file_type ; file_name : in out ascii_text_file_name ; successfull : out boolean ) ; procedure select_for_read( file_to_select : input_file_type ) ; procedure read_next_line ( new_line : out pstring ; end_of_file : out boolean ) ; procedure create_output_file ( new_file_name: in ascii_text_file_name ; successfull : out boolean ) ; procedure close_output_file ( successfull : out boolean ) ; Procedure file_out(char1 : in character ; char2 : in character := ascii.nul ; char3 : in character := ascii.nul ) ; -- note that the only way to send a nul out is to send it as -- the first parameter Procedure file_out(char1 : in extended_character ) ; -- note that the only way to send a nul out is to send it as -- the first parameter Procedure file_out(char1 : in extended_character ; char2 : in extended_character ) ; -- note that the only way to send a nul out is to send it as -- the first parameter Procedure file_out(char1 : in extended_character ; char2 : in extended_character ; char3 : in extended_character ) ; -- note that the only way to send a nul out is to send it as -- the first parameter Procedure z_file_out(char1 : in character ; char2 : in character := ascii.nul ; char3 : in character := ascii.nul ) ; -- note that the only way to send a nul out is to send it as -- the first parameter procedure end_dumb_output_line ; -- end an output line to a "dumb" device Procedure otsxy( x , y : in integer ; s : in string) ; Procedure otnxy( x , y , n : in integer ; len : in integer := 1 ) ; Function Stall ( done_on_q : in boolean ) return boolean ; Procedure change_printer( new_printer : in printer_type ) ; Function Odd ( I : Integer ) return boolean ; Procedure UpDate_Status ; procedure initialize_Printer_Globals_for_a_new_document ; procedure finish_Printer_Globals_for_an_old_document ; procedure close_Printer_Globals ; end ; Package body Printer_globals is package formatter_io renames text_io ; -- is new direct_io ( character ) ; -- the following is there because of a(nother!) telesoft bug... ----------- function bobs_convert is new unchecked_conversion( integer , character ) ; bobs_cr : constant character := ascii.cr ; -- bobs_convert ( 141 ) ; bobs_lf : constant character := ascii.lf ; -- bobs_convert ( 138 ) ; Telesoft_Text_Io_Bugs : constant boolean := true ; no_movement_on_printer_line_yet : boolean := true ; A_Line_Feed_Skipped_Already : boolean := true ; -- end of special stuff for telesoft bug ----------- ot_file : formatter_io.file_type ; main_in_file : text_io.file_type ; alt_in_file : text_io.file_type ; var_in_file : text_io.file_type ; -- crt_ot_file : text_io.file_type ; procedure open_for_read ( file_to_open : input_file_type ; file_name : in out ascii_text_file_name ; successfull : out boolean ) is -- look for the orig_file_name on the appropriate disks. Return -- successfull if found, and also set the final_file_name as -- the fully elaborated file path/name. Open the file setting -- the handle begin -- open_for_read case file_to_open is when main_input_file => open_for_read( main_in_file , file_name , successfull ) ; main_in_file_name := file_name ; when alternate_input_file => open_for_read( alt_in_file , file_name , successfull ) ; alt_in_file_name := file_name ; when variable_input_file => open_for_read( var_in_file , file_name , successfull ) ; var_in_file_name := file_name ; end case ; end open_for_read ; procedure select_for_read( file_to_select : input_file_type ) is begin -- select_for_read where_to_read := file_to_select ; end select_for_read ; procedure read_next_line ( new_line : out pstring ; end_of_file : out boolean ) is in_line : string ( 1 .. 255 ) ; in_leng : integer ; begin -- read_next_line case where_to_read is when main_input_file => if text_io.end_of_file( main_in_file) then end_of_file := true ; new_line := blank_line ; else -- we are ready to read... -- Note that for speed, we are reading -- directly into the PString array... text_io.get_line( main_in_file , new_line.data , new_line.actual_length); end_of_file := false ; end if ; when alternate_input_file => if text_io.end_of_file( alt_in_file ) then end_of_file := true ; new_line := blank_line ; else -- we are ready to read... -- Note that for speed, we are reading -- directly into the PString array... text_io.get_line( alt_in_file , new_line.data , new_line.actual_length); end_of_file := false ; end if ; when variable_input_file => if text_io.end_of_file( var_in_file ) then end_of_file := true ; new_line := blank_line ; else -- we are ready to read... -- Note that for speed, we are reading -- directly into the PString array... text_io.get_line( var_in_file , new_line.data , new_line.actual_length); end_of_file := false ; end if ; end case ; end read_next_line ; procedure create_output_file ( new_file_name: in ascii_text_file_name ; successfull : out boolean ) is -- open the file for output and return status begin -- create if formatter_io.is_open(ot_file) then formatter_io.close(ot_file); end if ; -- Now, we need to see if it is an open or create..... if new_file_name = default_printer or else new_file_name = default_console then -- open it... formatter_io.open ( ot_file , formatter_io.out_file , no_blanks(new_file_name)); else -- create it... formatter_io.create( ot_file , formatter_io.out_file , no_blanks(new_file_name)); end if ; ot_file_name := new_file_name ; successfull := true ; exception -- when io_exceptions.status_error => put("StatusError"); -- when io_exceptions.name_error => put("NameError "); -- when io_exceptions.use_error => put("UseError "); when others => successfull := false ; end create_output_file ; procedure close_output_file ( successfull : out boolean ) is begin -- close_output_file -- for posn in 1 .. 256 loop -- file_out(character'val(26)) ; -- end loop ; formatter_io.close ( ot_file ) ; successfull := true ; exception when others => successfull := false ; end close_output_file ; Procedure file_out(char1 : in character ; char2 : in character := ascii.nul ; char3 : in character := ascii.nul ) is -- the following code required by wicat... c1 , c2 , c3 : character ; begin -- file_out -- we also know where_to = to_file or something... c1 := char1 ; -- formatter_io.write( ot_file , c1 ) ; -- if char2 /= ascii.nul then -- c2 := char2 ; -- formatter_io.write( ot_file , c2 ) ; -- if char3 /= ascii.nul then -- c3 := char3 ; -- formatter_io.write( ot_file , c3 ) ; -- end if ; -- end if ; -- If Telesoft_Text_Io_Bugs and then char2 = ascii.nul then if c1 = ascii.cr then c1 := bobs_cr ; elsif c1 = ascii.lf then c1 := bobs_lf ; end if ; -- we are possibly processing a <cr> or <lf> -- only a single character to be worked....check out for -- trying to fix telesoft Text I/O problems if no_movement_on_printer_line_yet then -- for telesoft problems if c1 = bobs_cr then return ; -- don't do anything elsif c1 = bobs_lf then if not A_Line_Feed_Skipped_Already then a_line_feed_skipped_already := true ; return ; end if ; else no_movement_on_printer_line_yet := false ; end if ; elsif c1 = bobs_cr then no_movement_on_printer_line_yet := true ; a_line_feed_skipped_already := false ; end if ; -- for telesoft problems else no_movement_on_printer_line_yet := false ; -- for telesoft problems end if ; -- formatter_io.put( ot_file , c1 ) ; if char2 /= ascii.nul then c2 := char2 ; formatter_io.put( ot_file , c2 ) ; if char3 /= ascii.nul then c3 := char3 ; formatter_io.put( ot_file , c3 ) ; end if ; end if ; end file_out ; Procedure file_out(char1 : in extended_character ) is -- note that the only way to send a nul out is to send it as -- the first parameter begin -- file_out file_out ( character'val( char1 ) ) ; end file_out ; Procedure file_out(char1 : in extended_character ; char2 : in extended_character ) is -- note that the only way to send a nul out is to send it as -- the first parameter begin -- file_out file_out ( character'val( char1 ) , character'val( char2 ) ) ; end file_out ; Procedure file_out(char1 : in extended_character ; char2 : in extended_character ; char3 : in extended_character ) is -- note that the only way to send a nul out is to send it as -- the first parameter begin -- file_out file_out ( character'val( char1 ) , character'val( char2 ) , character'val( char3 ) ) ; end file_out ; Procedure z_file_out(char1 : in character ; char2 : in character := ascii.nul ; char3 : in character := ascii.nul ) is -- same as file_out but does not try to fix Telesoft Problems -- the following code required by wicat... -- This is used exclusively for transmitting escape sequences to -- output devices c1 , c2 , c3 : character ; begin -- z_file_out -- we also know where_to = to_file or something... c1 := bobs_convert ( character'pos(char1) + 128 ) ; formatter_io.put( ot_file , c1 ) ; if char2 /= ascii.nul then c2 := bobs_convert ( character'pos(char2) + 128 ) ; formatter_io.put( ot_file , c2 ) ; if char3 /= ascii.nul then c3 := bobs_convert ( character'pos(char3) + 128 ) ; formatter_io.put( ot_file , c3 ) ; end if ; end if ; end z_file_out ; procedure end_dumb_output_line is -- end an output line to a "dumb" device begin -- end_dumb_output_line formatter_io.new_line( ot_file ) ; end end_dumb_output_line ; Procedure otsxy( x , y : in integer ; s : in string) is begin crt_windows.goto_line_column( master_window , y , x ) ; crt_windows.put(s) ; end otsxy ; Procedure otnxy( x , y , n : in integer ; len : in integer := 1 ) is begin crt_windows.goto_line_column( master_window , y , x ) ; put(n , len ) ; end otnxy ; Function Stall ( done_on_q : in boolean ) return boolean is chr : character ; done : boolean ; begin clear_end_of_screen ( master_window , 22 , 1 ) ; otsxy(10,22,"Type <space> to continue...") ; if done_on_q then otsxy(10,23,"Type 'Q' to Quit Listing...") ; end if ; bell ; chr := char_within_range_or_abort ( ascii.nul , ascii.nul , ascii.del ) ; done := ( (chr = 'q') or (chr = 'Q') ) and done_on_q ; if done then clear_end_of_screen ( master_window , 22 , 1 ) ; else clear_window ( master_window ) ; clear_prompt ( master_window ) ; end if ; return done ; end stall ; Procedure change_printer( new_printer : in printer_type ) is begin current_environment.printer_brand := new_printer ; -- first set z_printer z_printer := new_printer ; -- then, deal with idiosyncrasies of printers if z_printer = z_cent737 then printer_points_per_inch := 150 ; --###--RSC02 start else printer_points_per_inch := 120 ; -- for the qume/diablo prop end if ; printer_vertical_per_inch := 48 ; z_forward := z_printer = z_cent737 ; --just a forward printer if z_printer = z_cent737 then z_proportional := z_p_centronics ; elsif z_printer = z_qume then z_proportional := z_p_qume ; else z_proportional := z_p_diablo ; end if ; --###--RSC02 end if z_printer = z_pdumb then z_smart_printer := z_dumb ; elsif z_printer = z_pbackspace or z_printer = z_la100draft or z_printer = z_la100medium or z_printer = z_la100high then z_smart_printer := z_backspace ; else z_smart_printer := z_smart ; end if ; we_have_single_tray_loader := printer_accessories = trayloader ; we_have_dual_tray_loader := printer_accessories = dual_tray ; we_have_some_tray_loader := we_have_single_tray_loader or we_have_dual_tray_loader ; end change_printer; Function Odd ( I : Integer ) return boolean is begin -- odd return i mod 2 = 1 ; end odd ; procedure Printer_Globals_initialize is begin -- Printer_Globals_initialize master_window := create_window ( 1 , basic_io_system.total_crt_col , 1 , basic_io_system.total_crt_line , true , 1 ) ; -- Create a screen window -- Make the window the entire screen, with a 1 line status area -- at the top of the window set_current_window ( master_window ) ; clear_prompt( master_window ) ; clear_window( master_window ) ; default_font.name := "12 Pitch " ; default_font.number:= 0 ; default_font.vertical_points_per_inch := 48 ; default_font.horizontal_points_per_inch := 120 ; default_font.Font_width := 10 ; default_font.Font_height := 8 ; default_font.mappings_necessary := false ; for posn in extended_character loop default_font.width (posn) := horizontal_measurement(10); default_font.hammer_intensity(posn) := 1 ; default_font.map_string (posn) (1) := posn ; for inside in 2 .. a_map_string'last loop default_font.map_string (posn) (inside) := 0 ; end loop ; end loop ; current_font := default_font ; Space_Width := default_font.width( extended_space ) ; Half_Space_Width := Space_Width / 2 ; permanent_font := default_font ; temporary_font := default_font ; end Printer_Globals_initialize ; Procedure UpDate_Status is begin If Initial_Environment.Show_Output_Status and then Initial_Environment.Where_To /= To_Screen then set_reverse(true); -- unchanging ... otsxy( 39 , 2 , ' ' & Main_In_File_Name & ' ' ) ; otsxy( 39 , 4 , ' ' & Alt_In_File_Name & ' ' ) ; -- the alt in file name is set within PRNTCMD1 -- unchanging ... otsxy( 39 , 6 , ' ' & Var_In_File_Name & ' ' ) ; -- also, line 6 could be an index file name -- and is set inside PRNTCMD1 -- unchanging ... otsxy( 39 , 8 , ' ' & Ot_File_Name & ' ' ) ; -- copy , current page , input , output -- In Initialize ... otnxy( 39 , 10 , ' ' & Copy # & ' ' , 10 ) ; otnxy( 39 , 12 , Physical_Page_Number , 10 ) ; put ( " " ) ; -- page number also updated by prntout2 otnxy( 39 , 14 , Physical_Input_Lines , 10 ) ; put ( " " ) ; otnxy( 39 , 16 , Physical_Output_Lines , 10 ) ; put ( " " ) ; set_reverse(false); goto_line_column( master_window , 1 , 1 ) ; end if ; end UpDate_Status ; procedure initialize_Printer_Globals_for_a_new_document is begin -- initialize_printer_globals_for_a_new_document Physical_Page_Number := 1 ; Physical_Input_Lines := 1 ; Physical_Output_Lines := 0 ; If Initial_Environment.Show_Output_Status and then Initial_Environment.Where_To /= To_Screen then if copies_printed_so_far = 0 then clear_prompt( master_window ) ; clear_window( master_window ) ; goto_prompt_line_column ( master_window , 1 , 14 ) ; put ( "E X E C U T I N G W O R D P R O C E S S O R"); otsxy( 15 , 2 , "Main File Title" ) ; otsxy( 15 , 4 , "Included File Title" ) ; otsxy( 15 , 6 , "Variable File Title" ) ; otsxy( 15 , 8 , "Output File Title" ) ; otsxy( 15 , 10 , "Current Copy Number" ) ; otsxy( 15 , 12 , "Current Page Number" ) ; otsxy( 15 , 14 , "Current Input Line" ) ; otsxy( 15 , 16 , "Total Output Lines" ) ; -- now, put in permanent lines... set_reverse(true); otsxy( 39 , 2 , ' ' & Main_In_File_Name & ' ' ) ; otsxy( 39 , 6 , ' ' & Var_In_File_Name & ' ' ) ; otsxy( 39 , 8 , ' ' & Ot_File_Name & ' ' ) ; otnxy( 39 , 10 , 1 , 10 ) ; put( " " ) ; set_reverse(false); else -- new copy set_reverse ( true ) ; otnxy( 39 , 10 , copies_printed_so_far+1, 10 ) ; put ( " " ) ; set_reverse ( false ) ; end if ; update_status ; end if ; end initialize_Printer_Globals_for_a_new_document ; procedure finish_Printer_Globals_for_an_old_document is begin -- finish_Printer_Globals_for_an_old_document null ; end finish_Printer_Globals_for_an_old_document ; procedure close_Printer_Globals is begin -- close_Printer_Globals null ; end close_Printer_Globals ; begin -- printer_globals Printer_Globals_initialize ; end printer_globals ; --$$$- PRNTGLOB --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --nametree --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ NAMETREE -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Energy Systems Group -- Ada Software Development Project Team -- 2280 U.S. Highway 19 North, Suite 120 -- Clearwater, Florida 33575 -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with string_library ; use string_library ; with crt_windows ; use crt_windows ; with Wordp_Globals ; use Wordp_Globals ; Package NAME_TREE is type Text_Formatter_Command is ( illegal_command , add_command , backward_add_command , binding_command , bold_command , center_command , char_spacing_command , char_width_command , comments_command , date_dmy_command , date_mdy_command , date_slash_command , date_dash_command , date_ymd_command , dot_lead_command , lcrm_command , rclm_command , else_command , end_page_command , envelope_feed_command , fancy_print_command , fill_command , finish_command , footers_command , footnote_command , forward_printing_command , go_left_command , headers_command , head_foot_space_command , hypen_command , if_command , ifswitch_command , indent_command , indent_neg_command , index_command , indexfile_command , insert_command , justify_margins_command , justify_numbers_command , justify_rtmargin_command , same_line_command , line_save_command , mult_line_spacing_command , vert_line_spacing_command , bottom_margin_command , left_margin_command , right_margin_command , top_margin_command , page_numbering_command , section_page_numbering_command , paper_length_command , paper_width_command , para_indent_command , new_para_command , pause_command , printer_control_command , read_command , ribbon_color_command , shadow_printing_command , prop_spacing_command , subpara_command , switch_command , tabs_command , tabs_vertical_command , underline_chars_command , underline_cont_command , underscore_command , variable_data_command , write_command , -- now, we have character setting commands subscript_command , superscript_command , underline_foothead_command , underline_character_command , ucontinuous_character_command , bold_character_command , shadow_character_command , temporary_font_character_command, forced_space_character_command , -- user_defined_command ) ; a_tree_name_string_length : constant integer := 25 ; subtype a_tree_name_string is string ( 1 .. a_tree_name_string_length ) ; type NODE_TYPE ; type NAME_NODE is access node_type ; type NODE_TYPE is record name : a_tree_name_string ; printer_command : Text_Formatter_Command ; other_info : integer ; left_son : name_node ; right_son : name_node ; end record ; blank_tree_name_string : constant a_tree_name_string := " " ; illegal_node : constant name_node := null ; empty_node : constant node_type := (blank_tree_name_string,illegal_command,0,null,null) ; last_good_command : a_tree_name_string ; Procedure INSERT_NAME( orig_name: in string ; new_printer_command : in Text_Formatter_Command ; new_info : in integer ; startnode : in out name_node ; case_sensitive : boolean := false ) ; -- insert the new name into the tree structure Procedure DELETE_NAME ( del_name : in string ; startnode : in out name_node ) ; -- delete the given name from the tree Function QUERY ( search_name : in a_tree_name_string ; startnode : in name_node ; case_sensitive : in boolean := false ) return name_node ; -- search for given name in tree structure and if found return -- the information on it end ; Package body NAME_TREE is Procedure MAP_UP( name : in out string ) is map_up_length : integer := name'length ; begin for i in 1 .. map_up_length loop if name(i) >= 'a' and name(i) <= 'z' then name(i) := character'val(character'pos(name(i)) - 32 ) ; end if ; end loop ; end ; Procedure INSERT_NAME( orig_name: in string ; new_printer_command : in Text_Formatter_Command ; new_info : in integer ; startnode : in out name_node ; case_sensitive : boolean := false ) is new_node : name_node ; name_len : constant integer := orig_name'length ; new_name : string ( 1 .. name_len ) := orig_name ; begin if not case_sensitive then map_up ( new_name ) ; end if ; if startnode = null then new_node := new node_type ; for i in 1 .. name_len loop new_node.name(i) := new_name(i) ; end loop ; for i in name_len+1 .. 25 loop new_node.name(i) := ' ' ; end loop ; new_node.left_son := null ; new_node.right_son := null ; new_node.other_info := new_info ; new_node.printer_command := new_printer_command ; startnode := new_node ; elsif new_name(1 .. name_len) < startnode.name(1 .. name_len) then INSERT_NAME( new_name , new_printer_command , new_info , startnode.left_son ); elsif new_name(1 .. name_len) > startnode.name(1 .. name_len) then INSERT_NAME( new_name , new_printer_command , new_info , startnode.right_son ); else error(" Error - """ & compress(new_name) & """ is already in tree" , not_fatal_error , operator_wait , short_beep ) ; end if ; end INSERT_NAME ; Procedure DELETE_NAME ( del_name : in string ; startnode : in out name_node ) is new_start : name_node ; parent_new_start : name_node ; name_len : integer := del_name'length ; Procedure FINDMIN( startnode : in out name_node ; parent_min_node : out name_node ) is new_node : name_node ; begin new_node := startnode ; while new_node.left_son.left_son /= null loop new_node := new_node.left_son ; end loop ; parent_min_node := new_node ; end ; begin if startnode /= null then if del_name(1 .. name_len) < startnode.name(1 .. name_len) then DELETE_NAME( del_name , startnode.left_son ) ; elsif del_name(1 .. name_len) > startnode.name(1 .. name_len) then DELETE_NAME( del_name , startnode.right_son ) ; elsif (startnode.left_son = null) and (startnode.right_son = null) then -- get here when startnode contains del_name -- dispose the node holding del_name and assign the value null startnode := null ; elsif startnode.left_son = null then -- dispose of the node holding del_name and -- move right son up position del_name node held startnode := startnode.right_son ; elsif startnode.right_son = null then -- dispose of the node holding del_name and -- move left son up to position del_name node held startnode := startnode.left_son ; else -- both children are present if startnode.right_son.left_son = null then startnode.right_son.left_son := startnode.left_son ; startnode := startnode.right_son ; else FINDMIN( startnode.right_son , parent_new_start ) ; new_start := parent_new_start.left_son ; new_start.left_son := startnode.left_son ; parent_new_start.left_son := new_start.right_son ; new_start.right_son := startnode.right_son ; startnode := new_start ; end if ; end if ; else -- startnode = null ; name to delete most not have -- been in the tree error(" Error - """ & compress(del_name) & """ was not in tree! Not Del", not_fatal_error , operator_wait , short_beep ) ; end if ; end DELETE_NAME ; Function QUERY ( search_name : in a_tree_name_string ; startnode : in name_node ; case_sensitive : in boolean := false ) return name_node is -- search for given name in tree structure and if found return -- the information on it -- for now, we ignore case_sensitive and assume that the -- tree is upper case, and we map search_name to upper case s_name_len : integer ; case_search_name : a_tree_name_string := search_name ; cur_node : name_node ; begin if startnode = null then return illegal_node ; else cur_node := startnode ; if not case_sensitive then map_up(case_search_name); end if ; -- now, find length for compare... s_name_len := position( ' ' , case_search_name ) ; if s_name_len = 0 then -- no space in the name... s_name_len := a_tree_name_string'length ; else s_name_len := s_name_len - 1 ; -- because space does not count... if s_name_len = 0 then -- blank name sent over return illegal_node ; elsif s_name_len < 3 then s_name_len := 3 ; -- to force it to compare spaces... end if ; end if ; -- time to work it... loop if case_search_name ( 1 .. s_name_len ) = cur_node.name ( 1 .. s_name_len ) then -- found it... last_good_command := cur_node.name ; -- for others to use... return cur_node ; elsif case_search_name ( 1 .. s_name_len ) < cur_node.name ( 1 .. s_name_len ) then -- is to the left of current cur_node := cur_node.left_son ; else -- is to the right of current cur_node := cur_node.right_son ; end if ; if cur_node = null then -- not found -- try to make it shorter and try again... if s_name_len > 3 then -- try abbreviation case_search_name ( s_name_len ) := ' ' ; return query ( case_search_name , startnode , case_sensitive ) ; else return illegal_node ; -- not found... end if ; end if ; end loop ; end if ; end query ; begin -- NAME_TREE -- null ; -- end NAME_TREE ; --$$$- NAMETREE --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --printf --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRINTF -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Energy Systems Group -- Ada Software Development Project Team -- 2280 U.S. Highway 19 North, Suite 120 -- Clearwater, Florida 33575 -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with string_library ; use string_library ; with Wordp_Globals ; use Wordp_Globals ; with printer_globals ; use printer_globals ; Package Printf is current_vertical_motion_index : vertical_measurement := 8 ; current_horizontal_motion_index : horizontal_measurement := 10 ; current_printer_direction_Forward : boolean := true ; current_print_font : Font_Number := 0 ; -- 0 means that font has not yet been set Binding_Edge_Amount : horizontal_measurement ; type type_ribbon_color is ( ribbon_unknown , ribbon_red , ribbon_black ) ; current_ribbon_color : type_ribbon_color := ribbon_unknown ; -- the list of commands which we might issue to a printer... type printer_command_type is ( set_hmi , abs_hor_tab , graphics_on , graphics_off , set_subscript , set_superscript , move_prop_points , dont_move , set_vmi , set_red_ribbon , set_black_ribbon , set_proportional , set_non_proportional , set_form_length , set_print_forward , set_print_backward , go_up_on_page , printer_reset , absolute_point_tab , Underline_On , Underline_Off , Bold_On , Bold_Off , Shadow_On , Shadow_Off , set_font_number , print_special_spoke_2 , print_special_spoke_4 , start_first_page , end_page_start_another , start_middle_page , end_last_page , start_envelope ) ; Procedure delay_printer ; Procedure execute_printer_command( new_print_command : in printer_command_type ; param : in integer := 0 ) ; end ; Package body Printf is Procedure delay_printer is begin for looper in 1 .. 30 loop file_out(ascii.nul) ; end loop; end delay_printer ; Procedure execute_printer_command( new_print_command : in printer_command_type ; param : in integer := 0 ) is Fparm : integer := param ; Procedure do_errors is err_str : pstring ; begin err_str := "Program Error : Printf called with " & int_to_str ( printer_command_type'pos(new_print_command) ) & "/" & int_to_str( Fparm ) ; error(err_str , not_fatal_error , operator_wait , short_beep ) ; end do_errors ; --###--RSC02 Procedure Tab_To_Absolute_Horizontal_Position ( Destination : Horizontal_Measurement ) is actual_destination : horizontal_measurement := destination ; Col_To_Move_To : Integer ; Points_To_Move_Extra : Integer ; Old_HMI : Horizontal_Measurement := current_horizontal_motion_index ; new_hmi : horizontal_measurement ; old_forward : boolean := current_printer_direction_forward ; begin -- put( "Destination => " ) ; -- put( destination , 5 ) ; put ( ascii.cr ) ; -- put( "HMI => " ) ; -- put( current_horizontal_motion_index , 5 ) ; put ( ascii.cr ) ; If Binding_Edge_Amount /= 0 and then odd ( Physical_Page_Number ) then Actual_Destination := Actual_Destination + Binding_Edge_Amount ; end if ; if z_proportional = z_p_centronics then z_file_out ( ascii.cr ) ; execute_printer_command ( move_prop_points , Actual_Destination ) ; else Col_To_Move_To := Actual_Destination / current_horizontal_motion_index ; Points_To_Move_Extra := Actual_Destination mod Current_Horizontal_Motion_Index ; if col_to_move_to > 126 then -- we have to be tricky..... -- put("##################################"); put ( ascii.cr ) ; -- put( "To Col => " ) ; -- put( col_to_move_to , 5 ) ; put ( ascii.cr ) ; -- put( "Plus Points => " ) ; -- put( points_to_move_extra , 5 ) ; put ( ascii.cr ) ; -- put("##################################"); put ( ascii.cr ) ; if col_to_move_to < 250 then new_hmi := old_hmi + old_hmi ; elsif col_to_move_to < 375 then new_hmi := old_hmi + old_hmi + old_hmi ; else -- that gives 25" and our max allowed anyway is 14" new_hmi := printer_points_per_inch / 5 ; end if ; execute_printer_command ( set_hmi , new_hmi ) ; if not current_printer_direction_forward then execute_printer_command ( set_print_forward ) ; end if ; Col_To_Move_To := Actual_Destination / new_hmi ; Points_To_Move_Extra := Actual_Destination mod new_hmi ; end if ; -- put( "To Col => " ) ; -- put( col_to_move_to , 5 ) ; put ( ascii.cr ) ; -- put( "Plus Points => " ) ; -- put( points_to_move_extra , 5 ) ; put ( ascii.cr ) ; -- if current_printer_direction_forward then -- put( "Forward => " ) ; put ( ascii.cr ) ; -- else -- put( "Backward => " ) ; put ( ascii.cr ) ; -- end if ; if ( not Current_Printer_Direction_Forward ) and then ( Points_To_Move_Extra /= 0 ) then Col_To_Move_To := Col_To_Move_To + 1 ; Points_To_Move_Extra := Current_Horizontal_Motion_Index - Points_To_Move_Extra ; -- put( "To Col => " ) ; -- put( col_to_move_to , 5 ) ; put ( ascii.cr ) ; -- put( "Plus Points => " ) ; -- put( points_to_move_extra , 5 ) ; put ( ascii.cr ) ; end if ; execute_printer_command ( abs_hor_tab , Col_To_Move_To ) ; -- Jump to the column -- and then take care of the rest if Points_To_Move_Extra > 0 then -- must take care of leftovers if z_proportional = z_p_qume then execute_printer_command ( set_non_proportional ) ; end if ; execute_printer_command ( set_hmi , Points_To_Move_Extra ) ; z_file_out ( ' ' ) ; if z_proportional = z_p_qume then execute_printer_command ( set_proportional ) ; end if ; end if ; -- here, the hmi could have been changed by either of two actions if old_hmi /= current_horizontal_motion_index then execute_printer_command ( set_hmi , old_hmi ) ; end if ; if old_forward /= current_printer_direction_forward then -- can only get here if we changed backwards to forward, so -- simply switch back... execute_printer_command ( set_print_backward ) ; end if ; end if; end Tab_To_Absolute_Horizontal_Position ; Procedure do_qume is cc : character ; begin case new_print_command is when set_hmi => z_file_out(ascii.esc , character'val(31) , character'val(Fparm + 1) ) ; when abs_hor_tab => z_file_out(ascii.esc , ascii.ht , character'val(Fparm + 1) ) ; when absolute_point_tab => Tab_To_Absolute_Horizontal_Position ( Fparm ) ; when graphics_on => z_file_out(ascii.esc,'3') ; when graphics_off => z_file_out(ascii.esc,'4') ; when set_subscript => z_file_out(ascii.esc,'U') ; when set_superscript => z_file_out(ascii.esc,'D') ; when move_prop_points => while Fparm > 50 loop z_file_out(character'val(31) , character'val(50) ) ; Fparm := Fparm - 50 ; end loop ; z_file_out(character'val(31) , character'val(Fparm) ) ; when dont_move => z_file_out(character'val(31) , 'A' ) ; when set_vmi => z_file_out(ascii.esc , character'val(30) , character'val(Fparm + 1) ) ; when set_red_ribbon => z_file_out(ascii.esc ,'A') ; when set_black_ribbon => z_file_out(ascii.esc ,'B') ; when set_proportional => null ; -- z_file_out(ascii.esc , -- character'val(14)); when set_non_proportional => null ; -- z_file_out(ascii.esc , -- character'val(15)); when set_form_length => if z_printer=z_qume then if we_have_some_tray_loader then Fparm := Fparm+48; --add 1inch for tray end if ; end if ; Fparm := Fparm / 8 ; if z_printer = z_citoh then if Fparm > 66 then Fparm := 66 ; end if ; end if ; cc := character'val(48+(Fparm mod 10)); -- '0' + last digit Fparm := Fparm / 10 ; if Fparm < 10 then Fparm := Fparm + 48 ; else Fparm := Fparm + 55 ; -- so 10 = 'A' end if ; delay_printer ; --for qume problem delay_printer ; --for qume problem z_file_out(ascii.esc) ; z_file_out('F',character'val(Fparm), cc); when set_print_forward => z_file_out(ascii.esc,'5') ; when set_print_backward => z_file_out(ascii.esc,'6') ; when go_up_on_page => -- go Fparm lines up fix for backslash for tmpvar in 1 .. (Fparm + 1) loop z_file_out(ascii.esc,ascii.lf) ; end loop ; delay_printer ; -- now do a positive line feed z_file_out(ascii.lf) ; when printer_reset => -- delay_printer ; -- delay_printer ; -- z_file_out( ascii.esc , -- character'val(26) , 'I' ) ; execute_printer_command( set_hmi , 12); execute_printer_command( set_vmi , 8); execute_printer_command( set_black_ribbon ) ; execute_printer_command( set_print_forward ) ; when set_font_number => null ; when print_special_spoke_2 => z_file_out(ascii.esc ,' '); when print_special_spoke_4 => z_file_out(ascii.esc ,'/'); when start_first_page => if (z_printer = z_citoh) and then we_have_some_tray_loader then -- insert a page z_file_out(ascii.esc , 'M' ,'1') ; end if ; when end_page_start_another => z_file_out(ascii.ff) ; if z_printer = z_citoh and then we_have_some_tray_loader then z_file_out(ascii.ff) ; -- to ensure it is ejected z_file_out(ascii.esc , 'M' , '2') ; end if ; when start_middle_page => if z_printer = z_citoh and then we_have_some_tray_loader then z_file_out(ascii.esc , 'M' , '2') ; end if ; when end_last_page => z_file_out(ascii.ff); if z_printer = z_citoh and then we_have_some_tray_loader then z_file_out(ascii.ff) ; end if ; when start_envelope => z_file_out(ascii.ff) ; if z_printer = z_citoh and then we_have_some_tray_loader then z_file_out(ascii.ff) ; z_file_out(ascii.esc , 'M' , '3') ; end if ; when others => do_errors ; end case ; end ; --###--RSC02 Procedure do_xerox is begin case new_print_command is when set_hmi => z_file_out(ascii.esc , character'val(31) , character'val(Fparm + 1) ) ; when abs_hor_tab => z_file_out(ascii.esc , ascii.ht , character'val(Fparm + 1) ) ; when absolute_point_tab => Tab_To_Absolute_Horizontal_Position ( Fparm ) ; when set_subscript => z_file_out(ascii.esc ,'U') ; when set_superscript => z_file_out(ascii.esc ,'D') ; when set_vmi => z_file_out(ascii.esc , character'val(30) , character'val(Fparm + 1) ) ; when set_red_ribbon => z_file_out(ascii.esc , 'A') ; when set_black_ribbon => z_file_out(ascii.esc , 'B') ; when set_form_length => if we_have_some_tray_loader then Fparm := Fparm+48; -- for tray end if ; z_file_out(ascii.esc , ascii.ff , character'val(Fparm / 8)); when set_print_forward => z_file_out(ascii.esc , '5') ; when set_print_backward => z_file_out(ascii.esc , '6') ; when go_up_on_page => for tmpvar in 1 .. (Fparm + 1) loop z_file_out(ascii.esc) ; z_file_out(ascii.lf) ; end loop ; delay_printer ; -- now do a positive line feed z_file_out(ascii.lf) ; when printer_reset => z_file_out( ascii.esc , '\' ) ; when set_font_number => null ; when print_special_spoke_2 => z_file_out(ascii.esc ,'Y'); when print_special_spoke_4 => z_file_out(ascii.esc ,'Z'); when start_first_page => null ; when end_page_start_another => z_file_out(ascii.ff) ; when start_middle_page => null ; when end_last_page => z_file_out(ascii.ff) ; when start_envelope => null ; when others => do_errors ; end case ; end do_xerox ; Procedure do_cent737 is cc : character ; begin case new_print_command is when set_subscript => z_file_out(ascii.esc, character'val(28)) ; when set_superscript => z_file_out(ascii.esc, character'val(30)) ; when absolute_point_tab => Tab_To_Absolute_Horizontal_Position ( Fparm ) ; when move_prop_points => while Fparm >= 6 loop z_file_out( ascii.esc , character'val(6)) ; Fparm := Fparm - 6 ; end loop ; if Fparm > 0 then z_file_out(ascii.esc , character'val(Fparm)) ; end if ; when set_proportional => if (Fparm = 6) or (Fparm = 0) then cc := character'val(19) ; elsif Fparm = 7 then cc := character'val(20) ; elsif Fparm = 8 then cc := character'val(17) ; end if ; z_file_out(ascii.esc , cc ) ; when set_non_proportional => z_file_out(ascii.esc,character'val(19)); when go_up_on_page => for tmpvar in 1 .. (Fparm + 1) loop z_file_out(ascii.esc) ; z_file_out(ascii.lf) ; end loop ; delay_printer ; -- now do a positive line feed z_file_out(ascii.lf) ; when printer_reset => z_file_out( ascii.esc , character'val(19) , character'val(13) ) ; when set_font_number => null ; when print_special_spoke_2 => z_file_out(ascii.esc ,'\'); when print_special_spoke_4 => z_file_out(ascii.esc ,'_'); when start_first_page => null ; when end_page_start_another => z_file_out(ascii.ff) ; when start_middle_page => null ; when end_last_page => z_file_out(ascii.ff) ; when start_envelope => z_file_out(ascii.ff) ; when Underline_On => z_file_out ( ascii.si ) ; when Underline_Off => z_file_out ( ascii.so ) ; -- both bold and shadow are treated as bold when Bold_On => z_file_out ( ascii.esc , ascii.so ) ; when Bold_Off => z_file_out ( ascii.esc , ascii.si ) ; when Shadow_On => z_file_out ( ascii.esc , ascii.so ) ; when Shadow_Off => z_file_out ( ascii.esc , ascii.si ) ; when others => do_errors ; end case ; end do_cent737 ; --###--RSC02 Procedure do_dumb is begin null ; end do_dumb ; --###--RSC02 procedure do_dataproducts is begin case new_print_command is when set_hmi => z_file_out(ascii.esc , character'val(31) , character'val(Fparm + 1) ) ; when abs_hor_tab => z_file_out(ascii.esc , ascii.ht , character'val(Fparm + 1) ) ; when absolute_point_tab => Tab_To_Absolute_Horizontal_Position ( Fparm ) ; when set_subscript => z_file_out(ascii.esc ,'U') ; when set_superscript => z_file_out(ascii.esc ,'D') ; when set_vmi => z_file_out(ascii.esc , character'val(30) , character'val(Fparm + 1) ) ; when set_red_ribbon => z_file_out(ascii.esc , 'A') ; when set_black_ribbon => z_file_out(ascii.esc , 'B') ; when set_form_length => if we_have_some_tray_loader then Fparm := Fparm+48; --for tray end if ; z_file_out(ascii.esc , ascii.ff , character'val(Fparm / 8)) ; when set_print_forward => z_file_out(ascii.esc ,'5') ; when set_print_backward => z_file_out(ascii.esc ,'6') ; when go_up_on_page => for tmpvar in 1 .. (Fparm + 1) loop z_file_out(ascii.esc) ; z_file_out(ascii.lf) ; end loop ; delay_printer ; -- now do a positive line feed z_file_out(ascii.lf) ; when printer_reset => delay_printer ; delay_printer ; z_file_out( ascii.esc , character'val(13) , 'P') ; when set_font_number => null ; when print_special_spoke_2 => z_file_out(ascii.esc ,' '); when print_special_spoke_4 => z_file_out(ascii.esc , character'val(127)); when start_first_page => null ; when end_page_start_another => z_file_out(ascii.ff) ; when start_middle_page => null ; when end_last_page => z_file_out(ascii.ff) ; when start_envelope => null ; when others => do_errors ; end case ; end do_dataproducts ; --###--RSC02 begin -- execute_printer_command --###--RSC02 starts case z_printer is when z_pdumb | z_pbackspace => do_dumb ; when z_qume => do_qume ; when z_xerox => do_xerox ; when z_cent737 => do_cent737 ; when z_dataproducts=> do_dataproducts ; when z_unknown => do_errors; when others => do_errors ; end case ; --###--RSC02 ends case new_print_command is when set_hmi => current_horizontal_motion_index := Fparm ; when set_vmi => current_vertical_motion_index := Fparm ; when set_red_ribbon => current_ribbon_color := ribbon_red ; when set_black_ribbon => current_ribbon_color := ribbon_black ; when set_print_forward => current_printer_direction_Forward := true ; when set_print_backward => current_printer_direction_Forward := false ; when set_font_number => current_print_font := Fparm ; when others => null ; end case ; end execute_printer_command ; begin -- printf null ; end printf ; --$$$- PRINTF --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntinot --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTINOT -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Ada Software Development Project Team -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with string_library ; use string_library ; with crt_windows ; use crt_windows ; with printer_globals ; use printer_globals ; with name_tree ; -- for command_error last_good_command Package print_in_to_out is -- This Package Is the Highest Output Device Dependent Package... -- The main goal of this package is to work with single lines and -- move them to good output lines .. max_characters_in_output_line : constant integer := 400 ; subtype output_line_index is integer range 0 .. max_characters_in_output_line + 1 ; type charact_array is array ( output_line_index ) of extended_character ; cleared_char : constant charact_array := ( 0 .. max_characters_in_output_line + 1 => extended_space ) ; type measure_array is array ( output_line_index ) of horizontal_measurement; -- note that these measurement include any extra widths for -- shadow or double width etc... cleared_meas : constant measure_array := ( 0 .. max_characters_in_output_line + 1 => 0 ) ; type boolean_array is array ( output_line_index ) of boolean ; cleared_bool : constant boolean_array := ( 0 .. max_characters_in_output_line + 1 => false ) ; type up_or_down_position is ( superscript , normal , subscript ) ; ot_subscript : constant up_or_down_position := subscript ; ot_superscript : constant up_or_down_position := superscript ; type updownp_array is array ( output_line_index ) of up_or_down_position ; cleared_updn : constant updownp_array := ( 0 .. max_characters_in_output_line + 1 => normal ) ; type font_nm_array is array ( output_line_index ) of font_number ; cleared_font : constant font_nm_array := ( 0 .. max_characters_in_output_line + 1 => 1 ) ; type output_line_type is -- this is the data needed to correctly print out a single line of -- text..... record Start_Position : horizontal_measurement ; Stop_Position : horizontal_measurement ; Justify_To : horizontal_measurement ; First_Justify : Output_Line_Index ; Character_Count: Output_Line_Index ; WordSpace_Count: Output_Line_Index ; the_character : charact_array ; the_width : measure_array ; font_changes : boolean ; -- if any font changes Font_Number : font_nm_array ; Special_Options: boolean ; -- true if any of the double_strike : boolean_array ; -- following boolean offset_strike : boolean_array ; -- arrays contain any underline : boolean_array ; -- true values... Sub_Or_Supers : updownp_array ; end record ; -- note that each array has a position on each side of the -- valid positions for blank character position. this makes -- checking for changes of state easier... type output_line_pointer is access output_line_type ; blank_output_line : constant output_line_type := ( 0 , 0 , 0 , 0 , 0 , 0 , cleared_char , cleared_meas , false , cleared_font , false , cleared_bool , cleared_bool , cleared_bool , cleared_updn ) ; max_line_length : constant integer := 513 ; -- however, the last position is reserved, so the user -- can only send over up to 512 characters.... subtype input_line_index is integer range 0 .. max_line_length ; Type Input_Line_Type is array ( input_line_index range 1 .. max_line_length ) of extended_character ; Input_Line : Input_Line_Type ; Input_Line_Length : Input_Line_Index ; waiting_output_line : output_line_pointer ; waiting_output_invalid_breaks : boolean_array ; rightmost_text_position : horizontal_measurement ; leftmost_para_text_position : horizontal_measurement ; leftmost_text_position : horizontal_measurement ; leftmost_normal_position : horizontal_measurement ; -- used for filling off, has left margin and sub paragraph -- is the default place to go. leftmost_edge_position : horizontal_measurement ; -- used for page numbers, right to left margin type Line_Modification_Type is ( Nothing , Center_mod , Right_Justify , To_Left_Margin ) ; -- to_left_margin is only used by the page number routines and -- the headers and footers type Line_Modification_Status is ( Off , Do_Forever , Do_While_Counting ) ; Type Permanent_And_Temporary_Character_Changes is ( Subscriptc , Superscriptc , Underline , Underline_Continuous , Bold , Shadow ) ; Type Character_Changes_Array is array ( Permanent_And_Temporary_Character_Changes ) of boolean ; no_character_changes : constant character_changes_array := ( subscriptc .. shadow => false ) ; type formatting_parameters is record Left_Indentation : horizontal_measurement ; Right_Indentation : horizontal_measurement ; -- only fill on Paragraph_Indent : horizontal_measurement ; -- only fill on Subsequent_Line_Ind: horizontal_measurement ; -- only fill on Filling_On : boolean ; Justification_On : boolean ; Fill_Before_Special: boolean ; Just_Before_Special: boolean ; Delay_Justification_Till_After_Dots : boolean ; -- Special Line Handling Information Line_Modification : Line_Modification_Type ; Modification_Status: Line_Modification_Status ; Modify_To_Do : Integer ; -- now, how to modify each character... Permanent_Character_Changes : Character_Changes_Array ; -- The settings set by the .bold etc. commands.... Temporary_Character_Changes : Character_Changes_Array ; -- This holds the settings temporarily when we go into a -- header/footer/fnote. It is filled on entry, and is -- emptied on end of the special item Current_Character_Changes : Character_Changes_Array ; -- The settings set by the .bold etc. commands as modified by -- the printer control character settings (which get reset at -- the end of the line if filling off and at the end of the -- paragraph if filling is on... This holds the temporary -- character changes settings normally, however when we are -- in a header/footer/footnote, then this gets moved to -- temporary and gets cleared to hold the settings for the -- special item... at end of the special item, is reloaded -- from temporary end record ; current_formatting_parameters : formatting_parameters ; blank_formatting_parameters : constant formatting_parameters := ( 0 , 0 , 0 , 0 , false , false , false , false , false , nothing , off , 0 , no_character_changes , no_character_changes , no_character_changes ) ; -- Now, we have some character processing information -- A_Char_Type is the list of the different values a character can have -- Note that it can only have ONE value at a time type a_char_type is ( Subscript_Start , Subscript_Stop , Subscript_Toggle , Superscript_Start , Superscript_Stop , Superscript_Toggle , Underline_Start , Underline_Stop , Underline_Toggle , UCont_Start , UCont_Stop , UCont_Toggle , UFoot_Start , UFoot_Stop , UFoot_Toggle , Bold_Start , Bold_Stop , Bold_Toggle , Shadow_Start , Shadow_Stop , Shadow_Toggle , Temp_Font_Start , Temp_Font_Stop , Temp_Font_Toggle , Soft_Hyphen , Dot_Leader , Character_Tab , Actual_Space , Forced_Space , Text_Character , Illegal_Character ) ; -- Char_Types is an array which provides a mapping from a character to -- find if it is a Text_Character or a Print Control Character type type_char_types is array ( extended_character ) of a_char_type ; char_types : type_char_types ; -- Default_Characters_Array is an array which provides a mapping from -- the Print Control Characters to their default values Type Type_Control_Character_Array is array ( a_char_type ) of extended_character ; Default_Characters_Array : Type_Control_Character_Array ; -- Current_Characters_Array contains the current settings for the -- printer control characters Current_Characters_Array : Type_Control_Character_Array ; character_tab_positions : boolean_array := cleared_bool ; -- End of character processing information in_header_or_footer : boolean ; Users_Requested_Abort : exception ; bad_user_command : exception ; -- raised when the user has a bad -- command and we can no longer parse -- the input line. Function User_Pause ( Message : String ; Prompt_For_Halt : boolean := false ) return boolean ; procedure command_error ( s : in string ; show_cmd : boolean := false ; loc : in input_line_index :=0; loc2: in input_line_index :=0) ; Procedure Input_Line_To_Output_Line ; -- change the current input line into an acceptable output line is end print_in_to_out ; Package body print_in_to_out is Function User_Pause ( Message : String ; Prompt_For_Halt : boolean := false ) return boolean is Output_Message : String ( 1 .. 28 ) := " Tap <space> to continue... " ; Other_Output_Message : String ( 1 .. 18 ) := " [or `H` to Halt] " ; Output_Length : integer ; ch : character ; begin -- User_Pause If Prompt_For_Halt then Output_Length := Message'Length + Output_Message'Length + Other_Output_Message'Length ; else Output_Length := Message'Length + Output_Message'Length ; end if ; goto_line_column ( master_window , window_height( master_window ) , ( highest_column_number(master_window) - Output_Length ) / 2 ) ; put( Message & Output_Message ) ; if Prompt_For_Halt then put( Other_Output_Message ) ; ch := char_or_abort ( ' ' , ' ' , 'H' ) ; else ch := char_or_abort ( ' ' , ' ' ) ; end if; clear_end_of_screen (master_window , window_height(master_window) , 1 ) ; return ch = 'H' or ch = ascii.nul ; -- because ascii.nul returned on <reject> key tapped end User_Pause ; procedure command_error ( s : in string ; show_cmd : boolean := false ; loc : in input_line_index :=0; loc2: in input_line_index :=0) is -- we have a command line error at the specified position temp_bool : boolean ; ot_string : pstring ; begin -- command_error -- must make an error message clear_end_of_screen ( master_window , 19 , 1 ) ; goto_line_column ( master_window , 19 , 2 ) ; set_reverse ( true ) ; put( " Command Error: " ) ; if show_cmd then put ( """" & compress( name_tree.last_good_command ) & """ " ) ; end if ; goto_line_column ( master_window , 20 , 2 ) ; put( " " ) ; put( s ) ; set_reverse ( false ) ; goto_line_column ( master_window , 21 , 2 ) ; for posn in 1 .. min ( 75 , input_line_length ) loop put( character'val ( input_line ( posn ) ) ) ; end loop ; if ( loc > 0 ) and ( loc <= 75 ) then goto_line_column ( master_window , 22 , loc + 1 ) ; set_reverse ( true ) ; put( '^' ) ; set_reverse ( false ) ; end if ; if ( loc2 > 0 ) and ( loc2 <= 75 ) then goto_line_column ( master_window , 22 , loc2 + 1 ) ; set_reverse ( true ) ; put( '^' ) ; set_reverse ( false ) ; end if ; -- wait for a space...... temp_bool := User_Pause ( " " , true ) ; clear_end_of_screen ( master_window , 19 , 1 ) ; if temp_bool then -- Halt raise users_requested_abort ; else raise bad_user_command ; end if ; end command_error ; Procedure Input_Line_To_Output_Line is -- change the current input line into an acceptable output line -- we have an input line and would like it interpreted for lengths -- and any imbedded commands and moved over to waiting_to_output -- area... last_space_posn : integer := 0 ; -- so that first spaces do not count word_space_ctr : integer := 0 ; -- counts the word spaces ot_posn : output_line_index := 0 ; cc : extended_character ; dot_leader_input_position : integer := 0 ; dot_leader_position : output_line_index := 0 ; dot_leader_leading_length : horizontal_measurement := 0 ; length_so_far : horizontal_measurement := 0 ; type type_of_request is ( Req_On , Req_Off , Req_Toggle ) ; procedure cng ( To_Change : Permanent_And_Temporary_Character_Changes ; HowToDoIt : Type_Of_Request ) is -- this handles bold, shadow, underline, underline continuous, -- and subscripts and superscripts... val : boolean ; begin -- cng case HowToDoIt is when Req_On => val := true ; when Req_Off => val := false ; when Req_Toggle => val := not current_formatting_parameters .current_character_changes ( To_Change ) ; end case ; current_formatting_parameters.current_character_changes ( To_Change ) := val ; -- if they do anything with any of these commands on a line, then -- we will do all of the compares...and it will be slowed down -- slightly waiting_output_line.special_options := true ; -- now, some items have side effects.... -- although, these should really be treated as errors() if to_change = subscriptc then current_formatting_parameters.current_character_changes ( superscriptc ) := false ; elsif to_change = superscriptc then current_formatting_parameters.current_character_changes ( subscriptc ) := false ; end if ; end cng ; procedure to_ot ( char_to_ot : extended_character ; len_to_use : horizontal_measurement := 0 ) is -- if measurement is 0, then we must determine it ourselves actual_len_to_use : horizontal_measurement := len_to_use ; begin -- to_ot -- char_to_ot is the character to move to output stream if actual_len_to_use = 0 then -- we must determine the length to use... actual_len_to_use := current_font.width ( char_to_ot ) ; end if ; ot_posn := ot_posn + 1 ; waiting_output_line.the_character ( ot_posn ) := char_to_ot ; waiting_output_line.font_number( ot_posn ) := current_font.number ; if not waiting_output_line.special_options then -- we don't need to do anything special waiting_output_line.the_width ( ot_posn ) := actual_len_to_use ; else -- must work special -- [ Shadow ] if current_formatting_parameters.current_character_changes ( Shadow ) then -- shadow affects width.. If z_proportional = z_p_centronics then -- these types of printers must be handled separately if current_environment.printer_brand = z_cent737 then actual_len_to_use := actual_len_to_use + actual_len_to_use ; -- else same width applies end if ; else -- only do shadow on for "normal" printer (daisy) if char_to_ot /= extended_space and then z_smart_printer = z_smart then actual_len_to_use := actual_len_to_use + 1 ; end if ; end if ; waiting_output_line.offset_strike ( ot_posn ) := true ; end if ; waiting_output_line.the_width ( ot_posn ) := actual_len_to_use ; -- now, work the special options -- [ Subscript ] if current_formatting_parameters.current_character_changes ( Subscriptc ) then waiting_output_line.Sub_Or_Supers ( ot_posn ) := ot_subscript ; -- [ Superscript ] elsif current_formatting_parameters.current_character_changes ( Superscriptc ) then waiting_output_line.Sub_Or_Supers ( ot_posn ) := ot_superscript ; end if ; -- [ Underline ] if current_formatting_parameters.current_character_changes ( Underline ) then if char_to_ot /= extended_space then waiting_output_line.underline ( ot_posn ) := true ; end if ; -- [ Underline_Continuous ] elsif current_formatting_parameters.current_character_changes ( Underline_Continuous ) then waiting_output_line.underline ( ot_posn ) := true ; end if ; -- [ Bold ] if current_formatting_parameters.current_character_changes ( Bold ) then waiting_output_line.double_strike ( ot_posn ) := true ; end if ; end if ; length_so_far := length_so_far + actual_len_to_use ; end to_ot ; procedure do_char_tab ( posn : in integer ) is pn : integer ; length_to_add : horizontal_measurement ; begin -- do_char_tab pn := length_so_far / font_width ; loop exit when pn > output_line_index'last ; exit when character_tab_positions ( pn ) ; pn := pn + 1 ; end loop ; if pn > output_line_index'last then command_error ( "No tab found for this tab character." , false , posn ) ; else length_to_add := pn * font_width - length_so_far ; while length_to_add >= font_width loop to_ot ( extended_space , font_width ) ; length_to_add := length_to_add - font_width ; end loop ; if length_to_add > 0 then to_ot ( extended_space , length_to_add ) ; end if ; end if ; end do_char_tab ; procedure change_for_dot_leader is fill_amount : integer ; leading_end : integer ; leading_filler : integer ; trailing_filler : integer ; trailing_start : integer ; space_len : horizontal_measurement ; dot_len : horizontal_measurement ; each_fill_len : horizontal_measurement ; dots_to_add : integer ; move_amount : integer ; extended_dot : constant extended_character := extended_character ( character'pos('.') ) ; old_opts : boolean ; begin -- change_for_dot_leader -- step 1 : determine the amount to fill in fill_amount := rightmost_text_position - waiting_output_line.stop_position ; -- note that we need enough room to start at a multiple of a space -- position and then put in two dots before another space... -- ( meaning, at least <space><dot><space><dot><space> ) -- Various Lengths (Fixed for any font...) space_len := current_font.width ( extended_space ) ; dot_len := current_font.width ( extended_dot ) ; each_fill_len := space_len + dot_len ; -- step 2 : count the number of spaces and partial space to -- fill in the area -- first, set the leading filler to make an even start... leading_end := leftmost_normal_position + dot_leader_leading_length ; leading_filler := font_width + each_fill_len - ( leading_end mod each_fill_len ) ; trailing_start := rightmost_text_position - ( waiting_output_line.stop_position - leading_end ) ; trailing_filler := trailing_start mod font_width + font_width ; fill_amount := fill_amount - leading_filler - trailing_filler ; if fill_amount < each_fill_len then -- not enough room for a dot.... command_error("Not Enough room on line for Dot Leader.", false, dot_leader_input_position ) ; end if ; -- we get here knowing how much to do... -- make the fill amount even.... trailing_filler := trailing_filler + fill_amount mod each_fill_len ; -- and do dots to add... dots_to_add := fill_amount / each_fill_len ; -- step 3 : move all text over by that amount ( only do special if -- special is set.. -- Note that we need to add in <leading fill><2 places for each dot> -- <trailing fill> -- have to move over text ( dot_leader_position .. waiting_output_line. -- character_count) move_amount := dots_to_add + dots_to_add + 2 ; for posn in reverse dot_leader_position .. waiting_output_line . character_count loop waiting_output_line.the_character( posn + move_amount ) := waiting_output_line.the_character( posn ) ; waiting_output_line.the_width( posn + move_amount ) := waiting_output_line.the_width( posn ) ; waiting_output_line.font_number( posn + move_amount ) := waiting_output_line.font_number( posn ) ; waiting_output_line.double_strike( posn + move_amount ) := waiting_output_line.double_strike( posn ) ; waiting_output_line.offset_strike( posn + move_amount ) := waiting_output_line.offset_strike( posn ) ; waiting_output_line.Underline( posn + move_amount ) := waiting_output_line.Underline( posn ) ; waiting_output_line.Sub_Or_Supers( posn + move_amount ) := waiting_output_line.Sub_Or_Supers( posn ) ; end loop ; waiting_output_line.character_count := waiting_output_line.character_count + move_amount ; -- step 4 : put in the spaces & widths old_opts := waiting_output_line.special_options ; waiting_output_line.special_options := false ; ot_posn := dot_leader_position - 1 ; -- cause to_ot adds one... to_ot( extended_space , leading_filler ) ; for posn in 1 .. dots_to_add loop to_ot( extended_dot , dot_len ) ; to_ot( extended_space , space_len ) ; end loop ; -- yes, the last part of dot leader could possibly be two spaces long.. to_ot( extended_space , trailing_filler ) ; waiting_output_line.special_options := old_opts ; if old_opts then -- we must clear them out... for posn in dot_leader_position .. dot_leader_position + move_amount - 1 loop waiting_output_line.double_strike ( posn ) := false ; waiting_output_line.offset_strike ( posn ) := false ; waiting_output_line.underline ( posn ) := false ; waiting_output_line.sub_or_supers ( posn ) := normal; end loop ; end if ; -- step 5 : fix the line information to account for added spaces. waiting_output_line.stop_position := rightmost_text_position ; waiting_output_line.justify_to := waiting_output_line.stop_position; waiting_output_line.first_justify := waiting_output_line .character_count + 1 ; exception when bad_user_command => waiting_output_line.all := blank_output_line ; -- simply return a blank line.... end change_for_dot_leader ; procedure smooth_out_line is -- make sure that any spaces which are too large are broken up into -- smaller spaces.... space_len : horizontal_measurement ; pos_to_check : output_line_index ; last_pos_to_check:output_line_index ; begin -- smooth_out_line space_len := current_font.width ( extended_space ) ; pos_to_check := 1 ; last_pos_to_check := waiting_output_line.character_count ; while pos_to_check <= last_pos_to_check loop -- check each position for a wide space if waiting_output_line.the_character ( pos_to_check ) = extended_space and then waiting_output_line.the_width ( pos_to_check ) > space_len then -- must break this up -- fix master variables for posn in reverse pos_to_check .. waiting_output_line.character_count loop -- move over each character ... waiting_output_line.the_character( posn + 1 ) := waiting_output_line.the_character( posn ) ; waiting_output_line.the_width( posn + 1 ) := waiting_output_line.the_width( posn ) ; waiting_output_line.font_number( posn + 1 ) := waiting_output_line.font_number( posn ) ; waiting_output_line.double_strike( posn + 1 ) := waiting_output_line.double_strike( posn ) ; waiting_output_line.offset_strike( posn + 1 ) := waiting_output_line.offset_strike( posn ) ; waiting_output_line.Underline( posn + 1 ) := waiting_output_line.Underline( posn ) ; waiting_output_line.Sub_Or_Supers( posn + 1 ) := waiting_output_line.Sub_Or_Supers( posn ) ; end loop ; waiting_output_line.character_count := waiting_output_line.character_count + 1 ; -- now, split up the widths... waiting_output_line.the_width ( pos_to_check ) := space_len ; waiting_output_line.the_width ( pos_to_check + 1 ) := waiting_output_line.the_width ( pos_to_check + 1 ) - space_len ; last_pos_to_check := waiting_output_line.character_count ; end if ; pos_to_check := pos_to_check + 1 ; end loop ; waiting_output_line.first_justify := waiting_output_line .character_count + 1 ; end smooth_out_line ; begin -- Input_Line_to_output_line -- first, we need to clear the output line fancy items... if waiting_output_line.font_changes then waiting_output_line.font_changes := false ; waiting_output_line.font_number := cleared_font ; end if ; if waiting_output_line.special_options then waiting_output_line.special_options := false ; waiting_output_line.double_strike := cleared_bool ; waiting_output_line.offset_strike := cleared_bool ; waiting_output_line.underline := cleared_bool ; waiting_output_line.sub_or_supers := cleared_updn ; end if ; waiting_output_invalid_breaks := cleared_bool ; -- now, set in case of any special changes..... waiting_output_line.special_options := current_formatting_parameters.current_character_changes /= no_character_changes ; -- Then, start moving things over... for posn in 1 .. input_line_length loop -- first, check to see what type of character it is... cc := input_line ( posn ) ; case char_types ( cc ) is when subscript_start => cng ( Subscriptc , Req_On ); when subscript_stop => cng ( Subscriptc , Req_Off ); when subscript_toggle => cng ( Subscriptc , Req_Toggle ); when superscript_start => cng ( Superscriptc , Req_On ); when superscript_stop => cng ( Superscriptc , Req_Off ); when superscript_toggle => cng ( Superscriptc , Req_Toggle ); when underline_start => cng ( Underline , Req_On ); when underline_stop => cng ( Underline , Req_Off ); when underline_toggle => cng ( Underline , Req_Toggle ); when ucont_start => cng ( Underline_Continuous, Req_On ); when ucont_stop => cng ( Underline_Continuous, Req_Off ); when ucont_toggle => cng ( Underline_Continuous, Req_Toggle ); when ufoot_start => if in_header_or_footer then cng ( Underline , Req_On ); end if ; when ufoot_stop => if in_header_or_footer then cng ( Underline , Req_Off ); end if ; when ufoot_toggle => if in_header_or_footer then cng ( Underline , Req_Toggle ); end if ; when bold_start => cng ( Bold , Req_On ); when bold_stop => cng ( Bold , Req_Off ); when bold_toggle => cng ( Bold , Req_Toggle ); when shadow_start => cng ( Shadow , Req_On ); when shadow_stop => cng ( Shadow , Req_Off ); when shadow_toggle => cng ( Shadow , Req_Toggle ); when temp_font_start => waiting_output_line.font_changes := true; -- even if we turn it on and then off -- we will set it as true... -- just adds a few more compares to the -- code and is cleaner than trying to -- catch the user doing strange things.. when temp_font_stop => null ; when temp_font_toggle => waiting_output_line.font_changes := true; when soft_hyphen => null ; when dot_leader => if dot_leader_position /= 0 then command_error ( "Too many Dot Leader Characters." , false , dot_leader_input_position , posn ) ; else dot_leader_input_position := posn ; -- above line just to make error -- message exact dot_leader_position := ot_posn + 1 ; dot_leader_leading_length := length_so_far ; end if ; when character_tab => -- move until we have a true -- character_tab_position or end of line do_char_tab ( posn ) ; when actual_space => to_ot ( extended_space , space_width ) ; if last_space_posn + 1 /= posn then -- we have a new word space word_space_ctr := word_space_ctr + 1; end if ; last_space_posn := posn ; when forced_space => to_ot ( extended_space , space_width ) ; waiting_output_invalid_breaks ( ot_posn ) := true ; when text_character => to_ot ( cc ) ; when illegal_character => null ; end case ; end loop ; -- now, must set the start & stop positions, etc..... waiting_output_line.start_position := leftmost_normal_position ; waiting_output_line.stop_position := waiting_output_line.start_position + length_so_far ; waiting_output_line.character_count := Ot_Posn ; waiting_output_line.wordspace_count := word_space_ctr ; if current_formatting_parameters.Justification_On then waiting_output_line.justify_to := rightmost_text_position ; waiting_output_line.first_justify := 1 ; else waiting_output_line.justify_to := waiting_output_line.stop_position ; waiting_output_line.first_justify := waiting_output_line .character_count + 1 ; end if ; -- put ( ascii.cr ) ; -- put ( "Start_Posn" ) ; put (waiting_output_line.start_position -- , 5 ) ; put(ascii.cr); -- put ( "Stop_Posn " ) ; put (waiting_output_line.stop_position -- , 5 ) ; put(ascii.cr); -- put ( "Character " ) ; put (Ot_Posn , 5 ) ; put(ascii.cr); -- put ( "WordSpaces" ) ; put (word_space_ctr , 5 ) ; put(ascii.cr); -- put ( "JustifyTo " ) ; put (waiting_output_line.justify_to -- , 5 ) ; put(ascii.cr); -- put ( "First_Jus " ) ; put (waiting_output_line.first_justify -- , 5 ) ; put(ascii.cr); -- put ( ascii.cr ) ; if dot_leader_position /= 0 and then not current_formatting_parameters.Filling_on then -- we have to work a dot leader...justify starting with the -- specified position ... change_for_dot_leader ; smooth_out_line ; end if ; end Input_Line_to_output_line ; begin -- print_in_to_out ; waiting_output_line := new output_line_type ; end print_in_to_out ; --$$$- PRNTINOT --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntout --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTOUT -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Ada Software Development Project Team -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with string_library ; use string_library ; with crt_windows ; use crt_windows ; with printer_globals ; use printer_globals ; with printf ; use printf ; with print_in_to_out ; use print_in_to_out ; Package print_out is -- All packages that use this package are device independent -- (although they may be font dependent.....) -- The main goal of this package is to work with single lines and -- output them to the output device... type physical_parameters is record -- Horizontal Information Paper_Width : horizontal_measurement ; Left_Margin : horizontal_measurement ; Right_Margin : horizontal_measurement ; -- only fill on Binding_Edge : horizontal_measurement ; Printing_Left_Side: Boolean := true ; real_center_right : Horizontal_measurement := 0 ; real_center_left : Horizontal_measurement := 0 ; real_right : Horizontal_measurement := 0 ; real_left : Horizontal_measurement := 0 ; -- Vertical Information Paper_Length : Vertical_Measurement ; Top_Margin : Vertical_Measurement ; Bottom_Margin : Vertical_Measurement ; end record ; -- -- they point as follows : -- -- Real-left Real-cntr-right Real-cntr-left Real-right -- v v v v -- this is the text that is in the And this is the text which is in -- first column. You will note that the second column. It wraps ar- -- it wraps around just on this side. ound only on its side. -- -- current_physical_parameters : physical_parameters ; type place_for_page_number is ( Left_Side , Right_Side , Center , Alternating ) ; type Heading_Or_Footing_line is private ; type Heading_Or_Footing_line_pointer is access Heading_Or_Footing_line ; type document_parameters is record -- Page Numbering Information Page_Numbering_On : boolean ; Current_Page_Number: integer ; Section_Numbering_On:boolean ; Current_Section_Num: integer ; Number_Page_At_Top : boolean ; Page_Number_Goes : place_for_page_number ; Page_Prefix_Suffix : pstring ; Page_Heading_Footing_VMI : vertical_measurement ; -- Heading Information Heading_Lines : integer ; Heading_Height : vertical_measurement ; Heading_Pointer : Heading_Or_Footing_line_pointer ; -- Footing Information Footing_Lines : integer ; Footing_Height : vertical_measurement ; Footing_Pointer : Heading_Or_Footing_line_pointer ; -- Foot Note Information FootNote_Lines : integer ; FootNote_Height : vertical_measurement ; FootNote_Pointer : Heading_Or_Footing_line_pointer ; end record ; current_document_parameters : document_parameters ; need_to_start_page : boolean := true ; Output_Permitted : Boolean := True ; function page_to_pstring return pstring ; Procedure Pstring_To_Output_Line ( Ps : pstring ; OtLine : in out output_line_pointer ) ; -- change a standard pstring into an acceptable output line procedure output_a_line ( line : in output_line_pointer ) ; procedure Move_Down_Vertically ( Points_To_Move : Vertical_Measurement ) ; procedure Move_To_Vertical_Position ( New_Posn : Vertical_Measurement ) ; procedure end_a_page ; procedure start_a_page ; procedure clear_a_list ( list_heading : in out heading_or_footing_line_pointer ) ; procedure set_line_data( LineInfo : in out heading_or_footing_line_pointer ; LineData : in output_line_type ) ; procedure set_next_ptr ( LineInfo : heading_or_footing_line_pointer ) ; function next_line_ptr ( LineInfo : heading_or_footing_line_pointer ) return heading_or_footing_line_pointer ; function return_line_data(LineInfo : in heading_or_footing_line_pointer) return output_line_type ; procedure initialize_print_out_for_a_new_document ; procedure finish_print_out_for_an_old_document ; procedure close_print_out ; function ps_to_s ( p : in pstring ) return string ; procedure send_input_text_to_output_device ; procedure modify_a_line ( output_line : in out output_line_pointer ) ; Printer_Vertical_Position : Vertical_Measurement := 0 ; -- What vertical point position are we at ? Fatal_Output_Error : exception ; Last_Selected_Page_Printed : exception ; package FreeList_Heading is subtype list_item_value is heading_or_footing_line ; --###-- subtype List_Item is heading_or_footing_line_pointer ; --###-- -- heading_or_footing_line_pointer appears once in text --###-- -- and heading_or_footing_line appears once in text --###-- no_set_value : constant List_Item := null ; procedure put_onto_free_list ( item : in out list_item ) ; -- this item is added to the free list function get_from_free_list return list_item ; -- get an item back from the free list for usage... procedure clear_free_list ; private type private_item ; type private_pointer is access private_item ; type private_item is record data : List_Item ; prior_item , next_item : private_pointer ; end record ; no_item : constant private_pointer := null ; item_list_head : Private_Pointer := no_item ; next_free_item : Private_Pointer := no_item ; item_list_tail : Private_Pointer := no_item ; end FreeList_Heading ; private type heading_or_footing_line is record data : output_line_type ; next_line : heading_or_footing_line_pointer ; end record ; Printer_Position : Horizontal_Measurement := 0 ; -- Where is printer's hammer relative to the paper.... -- Used when doing bi-directional printing to minimize wear and -- tear on the printer....does not significantly speed up the -- printing process Console_Line : charact_array ; Console_Last : output_line_index ; Console_Length: output_line_index ; Console_Line_Number : window_line_number ; A_Blank_Page : boolean ; page_number_line : output_line_pointer ; page_number_position : output_line_index ; temporary_line : output_line_pointer ; type when_to_add_a_line is ( at_top , at_bottom , never ) ; end print_out ; Package body print_out is Points_Moved_Since_Text_Sent_To_Output_Device : horizontal_measurement ; -- maintained by movement routines (increments) -- zeroed by output_a_line -- initialized by start_a_page -- checked within end_a_page in case we need to move before footer... procedure start_console_page ; Procedure Tab_Printer_To_Column_Number ( Target_Col : Output_Line_Index ) ; package body FreeList_Heading is Function allocate_list_item ( with_new_List_Item : in List_Item ) return Private_Pointer is -- allocate a new item & set its data List_Item to with_new_List_Item AN_ITEM : Private_Pointer ; begin -- make a new item AN_ITEM := NEW private_Item ; AN_ITEM.DATA := WITH_NEW_List_Item ; AN_ITEM.NEXT_ITEM := null ; -- attach it to the list if item_list_tail = null then -- a new list an_item.prior_item := null ; item_list_head := an_item ; item_list_tail := an_item ; next_free_item := an_item ; else -- an old list AN_ITEM.PRIOR_ITEM := ITEM_LIST_TAIL ; ITEM_LIST_TAIL.NEXT_ITEM := AN_ITEM ; ITEM_LIST_TAIL := AN_ITEM ; end if; return AN_ITEM ; end ; Procedure DE_ALLOCATE_LIST_ITEM ( OLD_ITEM : in out Private_Pointer ) is -- de-allocate the old list item begin if OLD_ITEM = null then null ; else if OLD_ITEM = ITEM_LIST_HEAD then ITEM_LIST_HEAD := ITEM_LIST_HEAD.NEXT_ITEM ; end if ; if OLD_ITEM = ITEM_LIST_TAIL then ITEM_LIST_TAIL := ITEM_LIST_TAIL.PRIOR_ITEM ; end if ; -- $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ -- *** release ( OLD_ITEM ) ; *** -- $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ OLD_ITEM := null ; end if ; end ; procedure put_onto_free_list ( item : in out list_item ) is -- this item is added to the free list temp_ptr : private_pointer ; begin -- put_onto_free_list if next_free_item = no_item -- we must allocate new item onto one end of the list or else next_free_item = item_list_tail then -- we have a list, but none of the locations are empty... temp_ptr := allocate_list_item(item); else -- we can just put into the empty spot next_free_item := next_free_item.next_item ; -- and we knew it was not the tail.... next_free_item.data := item ; end if ; item := no_set_value ; end put_onto_free_list ; function get_from_free_list return list_item is -- get an item back from the free list for usage... temp_ptr : private_pointer := next_free_item ; temp_list_item : heading_or_footing_line_pointer ; begin -- get_from_free_list if temp_ptr = no_item then -- we must allocate new item from memory... temp_list_item := new heading_or_footing_line ; temp_list_item.next_line := null ; return temp_list_item ; else -- we must reclaim items from list .... next_free_item := next_free_item.prior_item ; temp_ptr.data.next_line := null ; return temp_ptr.data ; end if ; end get_from_free_list ; procedure clear_free_list is temp_ptr : private_pointer ; begin -- clear_free_list loop temp_ptr := item_list_head ; exit when temp_ptr = no_item ; de_allocate_list_item( temp_ptr ) ; end loop ; end clear_free_list ; begin -- FreeList_Heading -- FreeList by SAIC/Clearwater Item Packages 26 Dec 84 null ; end FreeList_Heading ; procedure ot ( c : extended_character ) is -- translate this character to the output character or string -- output to appropriate device/ also does ascii.cr , ascii.bs t_c : extended_character ; Procedure Finish_Plain_Line is User_Abort_Request : boolean := false ; Start_Place : Integer ; begin -- finish_plain_line -- we need to process it If c = extended_cr then -- a return.... Console_Length := Max ( Console_Length , Console_Last ) ; Console_Last := 0 ; else -- a line feed Console_Length := Max ( Console_Length , Console_Last ) ; Console_Last := 0 ; if current_environment.where_to = to_screen then Console_Line_Number := Console_Line_Number + 1 ; if Console_Line_Number > window_height(master_window) - 2 then -- blankpage tells us that nothing has yet been printed -- on the screen. Therefore, there is no need to stop. if not a_blank_page then User_Abort_Request := User_Pause ( "Pause!" , true ) ; if user_abort_request then raise users_requested_abort ; end if ; end if ; start_console_page ; end if ; end if ; -- else we are on the same page with no problems if Console_Length = 0 then if current_environment.where_to = to_screen then Goto_Line_Column( Master_Window , Console_Line_Number + 1 , 1 ) ; else end_dumb_output_line ; end if ; else -- we have a real line if current_environment.where_to = to_file then For posn in 1 .. Console_Length loop file_out ( Console_Line ( Posn ) ) ; end loop ; end_dumb_output_line ; else a_blank_page := false ; -- if we get here, we are showing something Start_Place := Current_Physical_Parameters.Left_Margin / Space_Width ; for posn in start_place .. min ( Highest_Column_Number ( master_window ) , Console_Length ) loop put( character'val( Console_Line( posn ) ) ) ; end loop ; Goto_Line_Column( Master_Window , Console_Line_Number + 1 , 1 ) ; -- set at next line end if ; -- end of show screen Console_Length := 0 ; end if ; -- end of real line end if ; -- end of line feed end finish_plain_line ; begin -- ot if current_environment.ot_format = ot_fancy then -- this will use all the standard I/O for a printer if Current_Font.Mappings_Necessary then file_out ( Current_Font.Map_String ( c ) ( 1 ) ) ; for inside in 2 .. a_map_string'last loop t_c := Current_Font.Map_String ( c ) ( inside ) ; if t_c /= 0 then file_out ( t_c ) ; end if ; end loop ; else file_out(c) ; -- otherwise, just output it end if ; else -- we are outputting in a plain format to screen or to file if c > extended_cr then -- normal character if Console_Last < Output_Line_index'Last then Console_Last := Console_Last + 1 ; end if ; Console_Line ( Console_Last ) := c ; else finish_plain_line ; end if ; end if ; end ot ; procedure output_a_line ( line : in output_line_pointer ) is Characters_Needed_To_Fill_Line : Output_Line_Index ; Number_Of_Spaces_To_Add_To_Every_Word_Space : Output_Line_Index ; Number_Of_Word_Spaces_Getting_An_Extra_Space : Output_Line_Index ; Print_This_Line_Forward : Boolean ; Characters_Available_To_Justify : Integer ; -- normally output_line_index, however, if the answer is less -- than 1 , then no justification has been requested Ok_Justify : Boolean ; Number_Of_Points_To_Add_To_Every_Character : Output_Line_Index ; Number_Of_Characters_Getting_An_Extra_Point : Output_Line_Index ; Last_Width : Horizontal_Measurement ; Next_Width : Horizontal_Measurement ; Add_To_Width : Horizontal_Measurement ; Procedure Other_Ot ( out_place : Output_Line_Index ) is -- output a single character position ... c : extended_character ; begin -- Other_Ot c := Line.The_Character ( out_place ) ; ot ( c ) ; If Line.Special_Options then -- we have to work special options, if they are available... if z_smart_printer = z_backspace then -- the printer is not smart enough to do subscript or superscript if Line.Double_Strike ( out_place ) or Line.Offset_Strike ( out_place ) then ot ( extended_bs ) ; -- backspace ot ( c ) ; end if ; if Line.UnderLine ( out_place ) then ot ( extended_bs ) ; ot ( extended_underline ) ; end if ; end if ; end if ; end other_ot ; Function Absol ( num : integer ) return integer is begin -- absol if num < 0 then return - num ; else return num ; end if ; end absol ; procedure output_the_line_now is Next_Direction : Integer ; Last_Direction : Integer ; Start_Position : Output_Line_Index ; Stop_Position : Output_Line_Index ; Current_Pos : Output_Line_Index ; Last_Pos : Output_Line_Index ; Up_Or_Down : up_or_down_position := normal ; Bold_is_On : Boolean := false ; Shadow_is_On : Boolean := false ; Underline_is_On: Boolean := false ; procedure output_centronics_simple_line is Char_To_Ot : extended_character; Total_Width_Ot : Horizontal_Measurement ; begin -- output_centronics_simple_line loop Char_To_Ot := Line.The_Character ( Current_Pos ) ; Total_Width_Ot := Line.The_Width ( Current_Pos ) ; ot ( Char_To_Ot ) ; -- Now, check for extra width if Total_Width_Ot /= 0 then -- we need to move execute_printer_command ( move_prop_points, total_width_ot); end if ; exit when Current_Pos = Stop_Position ; Last_Pos := Current_Pos ; Current_Pos := Current_Pos + Next_Direction ; end loop ; ot ( extended_cr ) ; end output_centronics_simple_line ; procedure output_centronics_complex_line is Char_To_Ot : extended_character; Total_Width_Ot : Horizontal_Measurement ; begin -- output_centronics_complex_line loop -- work Line. (Current_Pos) -- to compare last status, check Line. (Last_Pos) -- FONT If Line.Font_Changes and then current_print_font /= Line.Font_Number ( Current_Pos ) then -- must change fonts ... execute_printer_command ( set_font_number , Line.Font_Number ( Current_Pos ) ) ; end if ; Char_To_Ot := Line.The_Character ( Current_Pos ) ; Total_Width_Ot := Line.The_Width ( Current_Pos ) ; If not Line.Special_Options then -- we just output the character.... ot ( Char_To_Ot ) ; -- Now, check for extra width if Total_Width_Ot /= 0 then -- we need to move execute_printer_command ( move_prop_points, total_width_ot); end if ; else -- we must check everything to see if we must do something amazing -- SUBSCRIPT/SUPERSCRIPT if up_or_down /= Line.Sub_Or_Supers ( Current_Pos ) then -- first get back to normal if up_or_down = superscript then execute_printer_command ( set_subscript ) ; up_or_down := normal ; elsif Up_Or_Down = subscript then execute_printer_command ( set_superscript ) ; up_or_down := normal ; end if ; Case Line.Sub_Or_Supers ( Current_Pos ) is when superscript => execute_printer_command( set_superscript); up_or_down := superscript ; when normal => null ; when subscript => execute_printer_command ( set_subscript ); up_or_down := subscript ; end case ; end if ; -- sub or superscript If Bold_is_On /= Line.Double_Strike ( Current_Pos ) then -- need to change bold settings... Bold_is_On := not Bold_is_On ; -- now, select Upright or Italic if Bold_is_On then execute_printer_command ( Bold_On ) ; else execute_printer_command ( Bold_Off ) ; end if ; end if ; If shadow_is_On /= Line.Offset_Strike ( Current_Pos ) then -- need to change shadow settings... shadow_is_On := not shadow_is_On ; if Shadow_is_On then execute_printer_command ( Shadow_On ) ; else execute_printer_command ( Shadow_Off ) ; end if ; end if ; If Underline_is_On /= Line.Underline ( Current_Pos ) then Underline_is_On := not Underline_is_On ; if Underline_is_On then execute_printer_command ( Underline_On ) ; else execute_printer_command ( Underline_Off ) ; end if ; end if ; ot ( Char_To_Ot ) ; -- Now, check for extra width if Total_Width_Ot /= 0 then -- we need to move execute_printer_command ( move_prop_points, total_width_ot); end if ; end if ; -- not just font changes on the line exit when Current_Pos = Stop_Position ; Last_Pos := Current_Pos ; Current_Pos := Current_Pos + Next_Direction ; end loop ; ot ( extended_cr ) ; end output_centronics_complex_line ; procedure output_Other_Simple_line is Char_To_Ot : extended_character; Total_Width_Ot : Horizontal_Measurement ; begin -- output_Other_Simple_line -- we are working a simple line loop Char_To_Ot := Line.The_Character ( Current_Pos ) ; Total_Width_Ot := Line.The_Width ( Current_Pos ) ; if current_horizontal_motion_index /= Total_Width_Ot then execute_printer_command( set_hmi , total_width_ot ); end if ; ot ( Char_To_Ot ) ; --###--RSC02 exit when Current_Pos = Stop_Position ; Last_Pos := Current_Pos ; Current_Pos := Current_Pos + Next_Direction ; end loop ; -- end of working simple line end output_Other_Simple_line ; procedure output_Other_complex_line is Char_To_Ot : extended_character; Total_Width_Ot : Horizontal_Measurement ; Temp_Width_Ot : Horizontal_Measurement ; begin -- output_Other_complex_line loop -- work Line. (Current_Pos) -- to compare last status, check Line. (Last_Pos) -- FONT If Line.Font_Changes and then current_print_font /= Line.Font_Number ( Current_Pos ) then -- must change fonts ... execute_printer_command ( set_font_number , Line.Font_Number ( Current_Pos ) ) ; end if ; Char_To_Ot := Line.The_Character ( Current_Pos ) ; Total_Width_Ot := Line.The_Width ( Current_Pos ) ; If not Line.Special_Options then -- we just output the character.... if current_horizontal_motion_index /= Total_Width_Ot then execute_printer_command( set_hmi , total_width_ot ); end if ; ot ( Char_To_Ot ) ; else -- we must check everything to see if we must do something amazing -- SUBSCRIPT/SUPERSCRIPT if up_or_down /= Line.Sub_Or_Supers ( Current_Pos ) then -- first get back to normal if up_or_down = superscript then execute_printer_command ( set_subscript ) ; up_or_down := normal ; elsif Up_Or_Down = subscript then execute_printer_command ( set_superscript ) ; up_or_down := normal ; end if ; Case Line.Sub_Or_Supers ( Current_Pos ) is when superscript => execute_printer_command( set_superscript); up_or_down := superscript ; when normal => null ; when subscript => execute_printer_command ( set_subscript ); up_or_down := subscript ; end case ; end if ; -- sub or superscript If Char_To_Ot = extended_space then -- we must just worry about underlining the space area... If Underline_is_On /= Line.Underline ( Current_Pos ) then Underline_is_On := not Underline_is_On ; end if ; If Underline_is_On then -- must both work this underline and handle checking overlap if Line.UnderLine ( Current_Pos + Next_Direction ) and then Current_Font.Width ( extended_underline ) - 2 < total_width_ot then -- if the next character in the direction we are going is -- supposed to be underlined, and if the current character -- width is greater that 2 points less than the width of -- the underline character, then Temp_Width_Ot := Total_Width_Ot / 2 ; execute_printer_command( set_hmi , temp_width_ot ) ; Total_Width_Ot := Total_Width_Ot - Temp_Width_Ot ; -- note that this only works up to double size char ot ( extended_underline ) ; end if ; -- here, finally, do the underline and then move the -- correct distance.... execute_printer_command( set_hmi , total_width_ot ) ; ot ( extended_underline ) ; else if current_horizontal_motion_index /= Total_Width_Ot then execute_printer_command( set_hmi , total_width_ot ) ; end if ; ot ( extended_space ) ; end if ; else -- not working a space If Bold_is_On /= Line.Double_Strike ( Current_Pos ) then Bold_is_On := not Bold_is_On ; if bold_is_On then execute_printer_command ( set_hmi , 0 ) ; ot ( Char_To_Ot ) ; end if ; end if ; If Shadow_is_On /= Line.Offset_Strike ( Current_Pos ) then Shadow_is_On := not Shadow_is_On ; end if ; If Underline_is_On /= Line.Underline ( Current_Pos ) then Underline_is_On := not Underline_is_On ; end if ; -- here we still have to output char & work shadow & underline If Shadow_is_On then execute_printer_command ( set_hmi , 1 ) ; ot ( Char_To_Ot ) ; total_width_ot := total_width_ot - 1 ; end if ; -- still to output char and underline If not Underline_is_On then if current_horizontal_motion_index /= Total_Width_Ot then execute_printer_command( set_hmi , total_width_ot ) ; end if ; ot ( Char_To_Ot ) ; else -- here we need to do both the character and the underline execute_printer_command( set_hmi , 0 ) ; ot ( Char_To_Ot ) ; if Line.UnderLine ( Current_Pos + Next_Direction ) and then Current_Font.Width ( extended_underline ) - 2 < total_width_ot then -- if the next character in the direction we are going is -- supposed to be underlined, and if the current character -- width is greater that 2 points less than the width of -- the underline character, then Temp_Width_Ot := Total_Width_Ot / 2 ; execute_printer_command( set_hmi , temp_width_ot ) ; Total_Width_Ot := Total_Width_Ot - Temp_Width_Ot ; -- note that this only works up to double size char ot ( extended_underline ) ; end if ; -- here, finally, do the underline and then move the -- correct distance.... execute_printer_command( set_hmi , total_width_ot ) ; ot ( extended_underline ) ; end if ; -- underline on end if ; -- not working a space end if ; -- line had special options --###--RSC02 exit when Current_Pos = Stop_Position ; Last_Pos := Current_Pos ; Current_Pos := Current_Pos + Next_Direction ; end loop ; end output_Other_complex_line ; begin -- output_the_line_now -- we can only get here for a smart printer... If print_this_line_forward then -- First, change direction if necessary If not current_printer_direction_forward then execute_printer_command ( set_print_forward ) ; end if ; -- Then, Move to the starting Position ... execute_printer_command ( absolute_point_tab , Line.Start_Position ) ; -- Now, set the final print head location (to be used to determine -- direction for next line Printer_Position := Line.Stop_Position ; Next_Direction := + 1 ; Last_Direction := - 1 ; Start_Position := 1 ; Stop_Position := Line.Character_Count ; else -- First, change direction if necessary If current_printer_direction_forward then execute_printer_command ( set_print_backward ) ; end if ; -- Then, Move to the starting Position ... execute_printer_command ( absolute_point_tab , Line.Stop_Position ) ; -- Now, set the final print head location (to be used to determine -- direction for next line Printer_Position := Line.Start_Position ; Next_Direction := - 1 ; Last_Direction := + 1 ; Start_Position := Line.Character_Count ; Stop_Position := 1 ; end if ; -- do it to it..... Current_Pos := Start_Position ; Last_Pos := Current_Pos + Last_Direction ; If z_proportional = z_p_centronics then -- like a centronics but not a centronics... -- We use bold as Italic -- We use shadow as Bold If ( not Line.Font_Changes ) and then ( not Line.Special_Options ) then -- we are working a simple line output_centronics_simple_line ; else output_centronics_complex_line ; end if ; -- some special items in line else -- we don't have a centronics-like printer If ( not Line.Font_Changes ) and then ( not Line.Special_Options ) then output_other_simple_line ; else output_other_complex_line ; end if ; end if ; -- clear any funny settings???? If Bold_is_On then if z_proportional = z_p_centronics then execute_printer_command ( Bold_Off ) ; end if ; end if ; If Underline_is_On then if z_proportional = z_p_centronics then execute_printer_command ( Underline_Off ) ; end if ; end if ; If Shadow_is_On then if z_proportional = z_p_centronics then execute_printer_command ( Shadow_Off ) ; end if ; end if ; If up_or_down /= normal then if up_or_down = superscript then execute_printer_command ( set_subscript ) ; else -- Up_Or_Down = subscript execute_printer_command ( set_superscript ) ; end if ; end if ; end output_the_line_now ; begin -- output_a_line if not output_permitted or else line.character_count < 1 then return ; -- don't need to do anything... end if ; physical_output_lines := physical_output_lines + 1 ; if line.first_justify < 1 -- Justify off because we were sent a first_justify of zero or else Line.Stop_Position >= Line.Justify_To then -- Justify off because line is longer than length to justify to -- or else off because both are exactly the same length Line.first_justify := line.character_count + 1 ; Line.Justify_to := line.stop_position ; Characters_Available_To_Justify := 0 ; ok_justify := false ; else -- check for a different justify setting, which, if requested, -- is known to be valid... Characters_Available_To_Justify := Line.Character_Count - Line.First_Justify ; -- the number of characters to justify is the final place minus the -- start place which means that a ten character line has really -- nine characters available for justification.... ok_justify := ( Characters_Available_To_Justify > 0 ) ; end if ; if z_smart_printer /= z_smart then -- we have a dumb printer...... -- Dumb Printers cannot change fonts in the middle of a line..... Tab_Printer_To_Column_Number ( Line.Start_Position / Current_Font.Font_Width ) ; if Line.First_Justify > 1 then for temp in 1 .. Line.First_Justify - 1 loop other_ot ( temp ) ; end loop ; end if ; if ( Line.First_Justify < Line.Character_Count ) then -- justify Characters_Needed_To_Fill_Line := ( Line.Justify_To - Line.Stop_Position ) / Current_Font.Font_Width ; if Line.WordSpace_Count > 0 then Number_Of_Spaces_To_Add_To_Every_Word_Space := Characters_Needed_To_Fill_Line / Line.WordSpace_Count ; Number_Of_Word_Spaces_Getting_An_Extra_Space := Characters_Needed_To_Fill_Line mod Line.WordSpace_Count ; else Characters_Needed_To_Fill_Line := 0 ; end if ; if Number_Of_Spaces_To_Add_To_Every_Word_Space > 2 then -- we don't fill more than two..... Characters_Needed_To_Fill_Line := 0 ; end if ; for temp in Line.First_Justify .. Line.Character_Count loop other_ot ( temp ) ; if Line.The_Character ( temp ) = extended_space and then Characters_Needed_To_Fill_Line > 0 then for looper in 1 ..Number_Of_Spaces_To_Add_To_Every_Word_Space loop other_ot ( temp ) ; -- same as other_ot ( extended_space ) Characters_Needed_To_Fill_Line := Characters_Needed_To_Fill_Line - 1 ; end loop ; if Number_Of_Word_Spaces_Getting_An_Extra_Space > 0 then other_ot ( temp ) ; -- same as other_ot ( extended_space ) Number_Of_Word_Spaces_Getting_An_Extra_Space := Number_Of_Word_Spaces_Getting_An_Extra_Space - 1; Characters_Needed_To_Fill_Line := Characters_Needed_To_Fill_Line - 1 ; end if ; -- End Of Adding Spaces To Justify.. end if; -- End Of Single Character Output .... end loop ; -- End Of Justification ..... end if ; ot ( extended_cr ) ; -- End Of Dumb Printer ........ else -- We Have A Smart Printer..... -- Pick A Direction ........... Print_This_Line_Forward := Z_Forward -- Printer Only Prints Forward -- Or User Requested Only Forward or else Absol( Printer_Position - Line.Start_Position ) <= Absol( Printer_Position - Line.Justify_To ); if ok_justify then Number_Of_Points_To_Add_To_Every_Character := ( Line.Justify_To - Line.Stop_Position ) / Characters_Available_To_Justify ; Number_Of_Characters_Getting_An_Extra_Point := ( Line.Justify_To - Line.Stop_Position ) mod Characters_Available_To_Justify ; if Number_Of_Points_To_Add_To_Every_Character > Permanent_Font.Horizontal_Points_Per_Inch / 15 then -- only justify if up to five + 1 leftover points per char Number_Of_Points_To_Add_To_Every_Character := 0 ; Number_Of_Characters_Getting_An_Extra_Point := 0 ; Print_This_Line_Forward := true ; else Line.Stop_Position := Line.Justify_To ; end if ; end if ; -- Massage the width information to turn it into the -- amount of distance to be moved between each character, not -- the width of each character... -- Now, work special centronics type printer If Z_Proportional = Z_P_Centronics then -- no need to work on the widths, it is already figured out... for posn in 1 .. Line.Character_Count loop Line.The_Width ( posn ) := 0 ; -- because the width holds only justification informaiton.... end loop ; else -- must work widths -- -- Currently a line such as "THIS LINE" would have the following info -- -- Start At Position 104 -- Stop At Position 174 ( old value before ^ justify lines ) -- Justify To 200 -- T H I S L I N E -- 10 8 6 8 8 8 6 8 8 -- If print_this_line_forward then -- in the above line, to start at 104, we must move to 109 -- ( 104 + 10/2 ) Last_Width := Line.The_Width(1); Line.Start_Position := Line.Start_Position + Last_Width / 2 ; Last_Width := Last_Width - ( Last_Width / 2 ) ; -- note that that might not be equal to last_width / 2 !!!! for posn in 1 .. Line.Character_Count - 1 loop Next_Width := Line.The_Width ( posn + 1 ) ; Line.The_Width ( posn ) := Last_Width + Next_Width / 2 ; Last_Width := Next_Width - Next_Width / 2 ; end loop ; -- we don't care about the movement after the last character... else -- printing backwards..... -- in the above line, to start at 200, we must move to -- 196 ( 200 - 8/2 ) Last_Width := Line.The_Width ( Line.Character_Count ) ; Line.Stop_Position := Line.Stop_Position - Last_Width / 2 ; Last_Width := Last_Width - ( Last_Width / 2 ) ; -- note that that might not be equal to last_width / 2 !!!! for posn in reverse 2 .. Line.Character_Count loop Next_Width := Line.The_Width ( posn - 1 ) ; Line.The_Width ( posn ) := Last_Width + Next_Width / 2 ; Last_Width := Next_Width - Next_Width / 2 ; end loop ; end if ; end if ; if ok_justify then -- Now, we need to move the justification information in... -- Note that there are THREE ways to work proportional printing, -- and therefore THREE ways to figure movement... -- Qume: Print Character and then move a bit -- Diablo: Set moving Amount and then Print Character -- Centronics: Print Character while moving, and then move a bit -- for justification purposes, we need to set the width information -- to just the justification if we are doing the centronics stuff. -- but, luckily If print_this_line_forward then for posn in Line.First_Justify .. Line.Character_Count - 1 loop add_to_width := number_of_points_to_add_to_every_character ; if number_of_characters_getting_an_extra_point > 0 then add_to_width := add_to_width + 1 ; number_of_characters_getting_an_extra_point := number_of_characters_getting_an_extra_point -1 ; end if ; Line.The_Width ( posn ) := Line.The_Width ( posn ) + add_to_width; end loop ; else for posn in reverse Line.First_Justify + 1 .. Line.Character_Count loop add_to_width := number_of_points_to_add_to_every_character ; if number_of_characters_getting_an_extra_point > 0 then add_to_width := add_to_width + 1 ; number_of_characters_getting_an_extra_point := number_of_characters_getting_an_extra_point -1 ; end if ; Line.The_Width ( posn ) := Line.The_Width ( posn ) + add_to_width; end loop ; end if ; end if ; -- we end up here with all of the widths adjusted to correctly -- justify the line...so we no longer have to care about the -- setting of the justify switch output_the_line_now ; end if ; Points_Moved_Since_Text_Sent_To_Output_Device := 0 ; end output_a_line ; Procedure Tab_Printer_To_Column_Number ( Target_Col : Output_Line_Index ) is old_hmi : horizontal_measurement ; Col : Output_Line_Index := Target_Col ; begin -- take binding into account If Current_Physical_Parameters.Binding_Edge /= 0 and then odd ( current_document_parameters.Current_Page_Number ) then Col := Col + Current_Physical_Parameters.Binding_Edge / Current_Font.Font_Width ; end if ; if z_smart_printer /= z_smart then ot ( extended_cr ) ; for looper in 1 .. Col loop ot ( extended_space ) ; end loop ; elsif z_proportional = z_p_centronics then if current_environment.printer_brand = z_cent737 then ot ( extended_cr ) ; execute_printer_command ( move_prop_points , 15 * Col ) ; else execute_printer_command ( Absolute_Point_Tab , Col * current_horizontal_motion_index ) ; end if ; else -- for the other two types of printers old_hmi := current_horizontal_motion_index ; execute_printer_command ( set_hmi , Current_Font.Font_Width ) ; execute_printer_command ( abs_hor_tab , Col ) ; execute_printer_command ( set_hmi , Old_Hmi ) ; end if ; end Tab_Printer_To_Column_Number ; procedure start_console_page is begin -- start_console_page clear_window ( Master_Window ) ; Console_Last := 0 ; Console_Length := 0 ; Console_Line_Number := 0 ; A_Blank_Page := true ; Goto_Line_Column( Master_Window , 1 , 1 ) ; end start_console_page ; procedure clear_a_list ( list_heading : in out heading_or_footing_line_pointer ) is line_we_are_working : heading_or_footing_line_pointer ; line_to_do_next : heading_or_footing_line_pointer ; begin -- clear_a_list line_we_are_working := list_heading ; while line_we_are_working /= null loop line_to_do_next := line_we_are_working.next_line ; freelist_heading.put_onto_free_list ( line_we_are_working ) ; -- this item is added to the free list line_we_are_working := line_to_do_next ; end loop ; list_heading := null ; -- to clear to nothing... end clear_a_list ; procedure examine_vmi is -- this takes care of a vmi which is greater than a limited printer -- can handle. Note that this does not try to take care of reverse -- movement which has a large vmi moved_per_line : constant integer := current_font.vertical_points_per_inch / 6 ; still_to_move : integer ; old_vmi : vertical_measurement ; begin -- examine_vmi -- can only get here when really outputting and doing at least -- double spacing... if (z_smart_printer /= z_smart) or current_environment.printer_brand = z_cent737 then -- we need to work on it still_to_move := current_vertical_motion_index - moved_per_line; while still_to_move > 0 loop ot ( extended_lf ) ; still_to_move := still_to_move - moved_per_line ; end loop ; --###--RSC02 end if; end examine_vmi ; procedure Move_Down_A_Line ( Lines_To_Move : Integer := 1 ) is examine_vmi_for_special_work : boolean := current_vertical_motion_index >= printer_vertical_per_inch / 3 ; begin -- move_down_a_line if output_permitted then for linen in 1 .. lines_to_move loop ot ( extended_lf ) ; Printer_Vertical_Position := Printer_vertical_Position + Current_Vertical_Motion_Index ; if examine_vmi_for_special_work then examine_vmi ; end if ; end loop ; else printer_vertical_position := printer_vertical_position + lines_to_move * current_vertical_motion_index ; end if ; Points_Moved_Since_Text_Sent_To_Output_Device := Points_Moved_Since_Text_Sent_To_Output_Device + lines_to_move * current_vertical_motion_index ; end move_down_a_line ; procedure Move_Down_Vertically ( Points_To_Move : Vertical_Measurement ) is next_position : integer ; -- integer because can take on invalid values temp_vmi : vertical_measurement ; new_posn : vertical_measurement ; examine_vmi_for_special_work : boolean := current_vertical_motion_index >= printer_vertical_per_inch / 3 ; begin -- move_down_vertically -- if points_to_move < 1 then -- return ; -- end if ; New_Posn := Printer_Vertical_Position + Points_To_Move ; if output_permitted then loop next_position := Printer_Vertical_Position + Current_Vertical_Motion_Index ; exit when next_position > New_Posn ; ot ( extended_lf ) ; Printer_Vertical_Position := next_position ; if examine_vmi_for_special_work then examine_vmi ; end if ; end loop ; if printer_vertical_position /= new_posn then -- we must move forward slightly less than a line... temp_vmi := current_vertical_motion_index ; execute_printer_command ( set_vmi , new_posn - printer_vertical_position ) ; ot ( extended_lf ) ; execute_printer_command ( set_vmi , temp_vmi ) ; Printer_Vertical_Position := New_Posn ; end if ; else Printer_Vertical_Position := New_Posn ; end if ; Points_Moved_Since_Text_Sent_To_Output_Device := Points_Moved_Since_Text_Sent_To_Output_Device + points_to_move ; end move_down_vertically ; procedure Move_To_Vertical_Position ( New_Posn : Vertical_Measurement ) is next_position : integer ; -- integer because can take on invalid values temp_vmi : vertical_measurement ; to_move : integer ; examine_vmi_for_special_work : boolean := current_vertical_motion_index >= printer_vertical_per_inch / 3 ; begin -- move_to_vertical_position -- put("//PVP=> ") ; put( printer_vertical_position , 5 ) ; -- put("//NP => ") ; put( new_posn , 5 ) ; if output_permitted then if Printer_Vertical_Position < New_Posn then -- we can move there Points_Moved_Since_Text_Sent_To_Output_Device := Points_Moved_Since_Text_Sent_To_Output_Device + new_posn - printer_vertical_position ; loop next_position := Printer_Vertical_Position + Current_Vertical_Motion_Index ; exit when next_position > New_Posn ; ot ( extended_lf ) ; Printer_Vertical_Position := next_position ; if examine_vmi_for_special_work then examine_vmi ; end if ; end loop ; elsif Printer_Vertical_Position > New_Posn then -- we can move backwards... to_move := Printer_vertical_position - new_posn + current_vertical_motion_index - 1 ; -- that forces it to hit exact or overshoot less than a line. execute_printer_command ( go_up_on_page , to_move / current_vertical_motion_index ) ; printer_vertical_position := printer_vertical_position - to_move ; Points_Moved_Since_Text_Sent_To_Output_Device := Points_Moved_Since_Text_Sent_To_Output_Device + to_move ; -- else we are there already... end if ; if printer_vertical_position /= new_posn then -- we must move forward slightly less than a line... temp_vmi := current_vertical_motion_index ; execute_printer_command ( set_vmi , new_posn - printer_vertical_position ) ; ot ( extended_lf ) ; execute_printer_command ( set_vmi , temp_vmi ) ; Printer_Vertical_Position := New_Posn ; end if ; else Printer_Vertical_Position := New_Posn ; end if ; end move_to_vertical_position ; procedure set_line_information is -- used to be resetmax begin -- set_line_information -- this is really only needed in case we have double columns and then -- a page call means that the left and right margins must change.... null ; end set_line_information ; procedure output_line_set( Starting_Line : Heading_Or_Footing_Line_Pointer ; Number_Of_Lines : integer ; Merge_Another_Line : Boolean ; Merged_Line : output_line_pointer ; Merge_As_First_Line : boolean ; Add_A_Blank : when_to_add_a_line := never ) is old_vmi : vertical_measurement := current_vertical_motion_index ; next_ot_line : heading_or_footing_line_pointer ; begin -- output_line_set if old_vmi /= Current_Document_Parameters.Page_Heading_Footing_VMI then execute_printer_command ( set_vmi , Current_Document_Parameters .Page_Heading_Footing_VMI ) ; end if ; if add_a_blank = at_top then move_down_a_line ( 2 ) ; end if ; next_ot_line := Starting_line ; for this_line_number in 1 .. Number_Of_Lines loop Temporary_Line.all := next_ot_line.data ; if merge_another_line then if this_line_number = 1 and then merge_as_first_line then -- merge it in output_a_line ( merged_line ) ; elsif this_line_number = number_of_lines and then not merge_as_first_line then -- merge it in at the end output_a_line ( merged_line ) ; end if ; end if ; -- ready to print Temporary_Line output_a_line ( Temporary_Line ) ; move_down_a_line ; next_ot_line := next_ot_line.next_line ; end loop ; if add_a_blank = at_bottom then move_down_a_line ( 1 ) ; end if ; if old_vmi /= current_vertical_motion_index then execute_printer_command ( set_vmi , old_vmi ) ; end if ; end output_line_set ; function page_to_pstring return pstring is pg_num : integer ; nums : pstring ; pref_sufx : pstring ; place_for_number : integer ; begin -- page_to_pstring if current_document_parameters.section_numbering_on then pg_num := current_document_parameters.current_section_num ; else pg_num := current_document_parameters.current_page_number ; end if ; pref_sufx := current_document_parameters.Page_Prefix_Suffix ; nums := int_to_str ( pg_num ) ; if length ( pref_sufx ) = 0 then -- simplest case return nums ; else -- we must break it apart place_for_number := position ( '$' , pref_sufx ) ; -- we know it is non-zero because the command that sets it checks -- for that if place_for_number > 1 then nums := pref_sufx.data( 1 .. place_for_number - 1 ) & nums ; end if ; if place_for_number < length( pref_sufx ) then return nums & pref_sufx.data( place_for_number + 1 .. length ( pref_sufx ) ) ; else return nums ; end if ; end if ; end page_to_pstring ; procedure generate_page_number_line is page_pstring : pstring := page_to_pstring ; temp_pstring : pstring ; temporary_saved_formatting_parameters : formatting_parameters ; new_mod : line_modification_type := to_left_margin ; -- how to modify line begin -- generate_page_number_line -- first, change the pstring page number line over to pstring... if length ( current_document_parameters.Page_Prefix_Suffix ) /= 0 then -- we would like to inform the user about the page number temp_pstring := " " & page_pstring ; while length( temp_pstring ) < 20 loop temp_pstring := temp_pstring & " " ; end loop ; if length ( temp_pstring ) > 20 then set_length ( temp_pstring , 20 ) ; end if ; otsxy( 55 , 12 , ps_to_s ( temp_pstring ) ) ; -- page_pstring := temp_pstring ; end if ; -- now, find out how to modify the page number line... if current_document_parameters.page_number_goes = center then new_mod := center_mod ; elsif current_document_parameters.page_number_goes = right_side or else ( current_document_parameters.page_number_goes = Alternating and then odd( current_document_parameters.Current_Page_Number ) ) then -- here we need to move the page number to the right side of the page new_mod := right_justify ; -- else it stays on the left edge end if ; -- now, change into normal output line -- set to no special formatting to take place... temporary_saved_formatting_parameters := current_formatting_parameters ; current_formatting_parameters := blank_formatting_parameters ; in_header_or_footer := true ; -- the above turns on flag to allow ufoot character if new_mod /= nothing then current_formatting_parameters.line_modification := new_mod ; current_formatting_parameters.Modification_Status := Do_Forever ; end if ; Pstring_To_Output_Line ( page_pstring , page_number_line ) ; if new_mod /= nothing then modify_a_line ( page_number_line ) ; end if ; -- reset special formatting to the correct setting... current_formatting_parameters := temporary_saved_formatting_parameters ; in_header_or_footer := false ; -- if current_document_parameters.page_number_goes = center then -- we must find the center of the page. Note that if we have a -- binding edge we want to adjust this page number so that it -- exactly lines up with the number on the other side of the -- page, so we adjust the centering slightly -- if Current_Physical_Parameters.Binding_Edge > 0 then -- -- we have a binding edge to work on -- if odd( current_document_parameters.Current_Page_Number ) then -- page_start_position := page_start_position -- + ( Current_Physical_Parameters.Binding_Edge -- * Current_Font.Font_Width ) / 2 ; -- else -- -- even page -- page_start_position := page_start_position -- - ( Current_Physical_Parameters.Binding_Edge -- * Current_Font.Font_Width ) / 2 ; -- end if ; -- -- else no adjustment needed because no binding edge -- end if ; -- end if ; end generate_page_number_line ; function ps_to_s ( p : in pstring ) return string is begin -- ps_to_s return p.data( 1 .. length(p) ) ; end ps_to_s ; procedure start_a_page is page_number_line_ready : boolean ; begin -- start_a_page set_reverse(true ); otnxy( 39 , 12 , Physical_Page_Number , 10 ) ; put ( " " ) ; set_reverse(false); Output_Permitted := ( Current_Document_Parameters.Current_Page_Number >= Current_Environment.First_Page_To_Print ) and ( Current_Document_Parameters.Current_Page_Number <= Current_Environment.Last_Page_To_Print ) ; if current_physical_parameters.real_center_right /= 0 then if current_physical_parameters.Printing_Left_Side then current_Physical_Parameters.left_margin := current_physical_parameters.real_left ; current_Physical_Parameters.right_margin := current_physical_parameters.real_center_right ; else current_Physical_Parameters.left_margin := current_physical_parameters.real_center_left ; current_Physical_Parameters.right_margin := current_physical_parameters.real_right ; end if ; set_line_information ; end if ; if current_physical_parameters.Printing_Left_Side or ( current_physical_parameters.real_center_right = 0) then if Output_Permitted then -- we need to feed in the appropriate page in the printer if Current_Document_Parameters.Current_Page_Number = 1 then execute_printer_command(start_first_page) ; elsif Current_Document_Parameters.Current_Page_Number = 0 then execute_printer_command(start_envelope) ; elsif (Current_Document_Parameters.Current_Page_Number = current_environment.first_page_to_print) then -- a first page, but not page 1 execute_printer_command(start_middle_page) ; else -- eject the previous page unless we are already ready for new page if we_have_some_tray_loader -- then need to start page no matter or else ( Printer_Vertical_Position < Current_Physical_Parameters.Paper_Length ) then -- or not at end of a page anyway... execute_printer_command(end_page_start_another) ; end if ; end if ; if ( not current_environment.continuous_forms ) and ( current_environment.where_to = to_printer ) then if User_Pause ( "Insert the Next Page. " , true ) then raise Users_Requested_Abort ; end if ; end if ; end if ; end if ; Printer_Vertical_Position := 0 ; -- that says where the Top of the current character will print... -- we need to do the top margin stuff.... -- because we are either starting a new page move_to_vertical_position ( current_Physical_Parameters.top_margin ) ; -- we are now sitting on the first line on the page ... if ( current_physical_parameters.Printing_Left_Side or ( current_physical_parameters.real_center_right = 0) ) and then Output_Permitted then -- first column or not double column and we are printing -- this is either first col of two, or single column -- we are outputting now -- page number ? if Current_Document_Parameters.Page_Numbering_On and Current_Document_Parameters.Number_Page_At_Top then generate_page_number_line ; page_number_line_ready := true ; else page_number_line_ready := false ; end if ; if Current_Document_Parameters.Heading_Lines > 0 then output_line_set ( Current_Document_Parameters.Heading_Pointer , Current_Document_Parameters.Heading_Lines , page_number_line_ready , page_number_line , true , at_bottom ) ; elsif page_number_line_ready then output_a_line ( page_number_line ) ; move_down_a_line ( 2 ) ; end if ; -- end we are outputting else -- second column or else are not printing -- we need to put in the <cr><lf> -- if Output_Permitted is false, -- then do_do_crlf just advances Printer_Vertical_Position by vmi * x if Current_Document_Parameters.Heading_Lines > 0 then move_down_a_line ( Current_Document_Parameters.Heading_Lines + 1 ) ; elsif Current_Document_Parameters.Page_Numbering_On and Current_Document_Parameters.Number_Page_At_Top then move_down_a_line ( 2 ) ; end if ; end if ; Need_To_Start_Page := false ; end start_a_page ; procedure end_a_page is FootNote_And_Footer_Loc : vertical_measurement ; Footer_Loc : vertical_measurement ; PageNum_Loc : vertical_measurement ; bottom_Loc : vertical_measurement ; page_number_line_ready : boolean ; moving_vmi : vertical_measurement ; old_vmi : vertical_measurement ; lines_we_can_output : integer ; procedure generate_one_inch_line( ot_line : in out output_line_pointer) is und_width : horizontal_measurement ; num : integer ; ot_pos : horizontal_measurement ; begin -- generate_one_inch_line ot_line.all := blank_output_line ; und_width := current_font.width ( extended_underline ) ; num := current_font.horizontal_points_per_inch / und_width ; Ot_Pos := leftmost_edge_position; ot_line.Start_Position := Ot_Pos ; for posn in 1 .. num loop ot_line.the_character ( posn ) := extended_underline ; ot_line.the_width ( posn ) := und_width ; ot_line.Font_Number ( posn ) := current_font.number; Ot_Pos := Ot_Pos + und_width ; end loop ; ot_line.Stop_Position := Ot_Pos ; ot_line.Justify_To := Ot_Pos ; ot_line.First_Justify := 0 ; ot_line.Character_Count:= num ; ot_line.WordSpace_Count:= 0 ; end generate_one_inch_line ; procedure clear_footnotes ( lines_we_already_output : integer ) is -- we output the specified number of foot note lines. -- please do whatever is necessary to prepare for the next page line_we_are_working : heading_or_footing_line_pointer ; line_to_do_next : heading_or_footing_line_pointer ; begin -- clear_footnotes if lines_we_already_output > 0 then line_we_are_working := Current_Document_Parameters.FootNote_Pointer ; for linen in 1 .. lines_we_already_output loop line_to_do_next := line_we_are_working.next_line ; freelist_heading.put_onto_free_list ( line_we_are_working ) ; -- this item is added to the free list line_we_are_working := line_to_do_next ; end loop ; Current_Document_Parameters.FootNote_Pointer := line_we_are_working ; Current_Document_Parameters.FootNote_Lines := Current_Document_Parameters.FootNote_Lines - lines_we_already_output ; If Current_Document_Parameters.FootNote_Lines = 0 then Current_Document_Parameters.FootNote_Height := 0 ; else Current_Document_Parameters.FootNote_Height := Current_Document_Parameters.FootNote_Height - lines_we_already_output * Current_Document_Parameters.Page_Heading_Footing_VMI ; end if ; end if ; end clear_footnotes ; Procedure New_Page is begin if (z_smart_printer /= z_smart) or (current_environment.printer_brand = z_cent737) then -- fix for centronics move_to_vertical_position ( Current_Physical_Parameters.Paper_Length); -- we have to be here on a gotoscreen if current_environment.where_to = to_screen then ot ( extended_cr ) ; for looper in 1 .. 38 loop ot ( extended_minus ) ; ot ( extended_space ) ; end loop ; ot ( extended_cr ) ; end if ; end if ; end new_page ; procedure increment_page_number is begin -- increment_page_number -- Global....Used for Updating Status and Binding Determination -- for odd pages (within Printf) Physical_Page_Number := Physical_Page_Number + 1 ; Current_Document_Parameters.Current_Page_Number := Current_Document_Parameters.Current_Page_Number + 1 ; if Current_Document_Parameters.Section_Numbering_On then Current_Document_Parameters.Current_Section_Num := Current_Document_Parameters.Current_Section_Num + 1 ; end if ; if Current_Document_Parameters.Current_Page_Number > Current_Environment.Last_Page_To_Print then If output_permitted then -- we must eject the last page execute_printer_command( end_last_page ) ; end if ; -- finish_output_for_a_document ; raise Last_Selected_Page_Printed ; end if; end increment_page_number ; begin -- end_a_page if need_to_start_page then return ; end if ; -- First: We must move to the correct vertical position.... -- page number ? if Current_Document_Parameters.Page_Numbering_On and not Current_Document_Parameters.Number_Page_At_Top then if output_permitted then generate_page_number_line ; end if ; page_number_line_ready := true ; else page_number_line_ready := false ; end if ; -- Bottom_Loc is the last printable vertical position Bottom_Loc := Current_Physical_Parameters.Paper_Length - Current_Physical_Parameters.Bottom_Margin ; -- Footer_Loc is where to start the footer -- Note that the page number shares the last line with the -- footer Footer_Loc := Bottom_Loc - Current_Document_Parameters.Footing_Height ; -- PageNum_Loc is where to put the page number PageNum_Loc := Bottom_Loc - current_vertical_motion_index ; -- or ?? - Current_Font.Font_Height ; if page_number_line_ready and then footer_loc = bottom_loc then -- we must add in a line... Footer_Loc := PageNum_Loc ; end if ; -- FootNote_And_Footer_Loc is location to start the footer information FootNote_And_Footer_Loc := Footer_Loc - Current_Document_Parameters.FootNote_Height ; -- Now, however, if FootNote_And_Footer_Loc and Bottom_Loc are -- identical, then we need to simply work page numbering if ( current_physical_parameters.Printing_Left_Side or ( current_physical_parameters.real_center_right = 0) ) then -- first column or not double column and we are printing -- this is either first col of two, or single column -- we have to check this out even if not output_permitted because -- we might have a partial foot note If Output_Permitted then -- we are outputting now -- now, move If Bottom_Loc /= FootNote_And_Footer_Loc then -- we have to do work on the bottom of a page if Current_Document_Parameters.Footing_Height + Current_Document_Parameters.FootNote_Height = 0 then -- easiest, just a page number If PageNum_Loc > Printer_Vertical_Position + current_vertical_motion_index then move_to_vertical_position(PageNum_Loc); -- else we squeezed an extra line on the page, and therefore -- want to simply print whereever we are now... else move_down_a_line ( 2 ) ; end if ; output_a_line ( page_number_line ) ; else -- at least a footer or foot note, possibly also a page number moving_vmi:=Current_Document_Parameters.Page_Heading_Footing_VMI ; lines_we_can_output := Current_Document_Parameters.FootNote_Lines ; if lines_we_can_output > 0 then lines_we_can_output := lines_we_can_output + 2 ; -- take into account the two leading lines... end if ; If FootNote_And_Footer_Loc > Printer_Vertical_Position + current_vertical_motion_index then move_to_vertical_position(FootNote_And_Footer_Loc); elsif FootNote_And_Footer_Loc < Printer_Vertical_Position - moving_vmi then -- we get here if we cannot fit the entire footnote onto -- the page, even if we add one line to the length of the -- page...... Lines_We_Can_Output := ( Printer_Vertical_Position - Footer_Loc ) / moving_vmi ; if lines_we_can_output < 3 then lines_we_can_output := 0 ; -- because it takes two lines to set up the foot note end if ; move_down_a_line ( 2 ) ; -- else we can fit the entire footnote on the page..although -- we might be forced to add a line to do it... else move_down_a_line ( 2 ) ; end if ; if lines_we_can_output > 0 then -- we can do something with the foot notes... old_vmi := current_vertical_motion_index ; execute_printer_command ( set_vmi , moving_vmi ) ; generate_one_inch_line ( Temporary_Line ) ; output_a_line ( Temporary_Line ) ; move_down_a_line ( 2 ) ; lines_we_can_output := lines_we_can_output - 2 ; output_line_set ( Current_Document_Parameters.FootNote_Pointer , Lines_We_Can_Output , false , null , false , at_bottom ) ; clear_footnotes ( Lines_we_can_output ) ; execute_printer_command ( set_vmi , old_vmi ) ; end if ; -- now, we are here and done with footnotes..... if Current_Document_Parameters.Footing_Lines > 0 then output_line_set ( Current_Document_Parameters.Footing_Pointer , Current_Document_Parameters.Footing_Lines , page_number_line_ready , page_number_line , true , at_top ) ; elsif page_number_line_ready then output_a_line ( page_number_line ) ; end if ; end if ; -- end of doing work at the bottom of a page -- else there is no page number, footer, or foot note end if ; else -- output is not permitted If Current_Document_Parameters.FootNote_Lines > 0 then moving_vmi:=Current_Document_Parameters.Page_Heading_Footing_VMI ; lines_we_can_output:=Current_Document_Parameters.FootNote_Lines + 2; -- take into account the two leading lines... if FootNote_And_Footer_Loc < Printer_Vertical_Position - moving_vmi then -- we get here if we cannot fit the entire footnote onto -- the page, even if we add one line to the length of the -- page...... Lines_We_Can_Output := ( Printer_Vertical_Position - Footer_Loc ) / moving_vmi ; if lines_we_can_output < 3 then lines_we_can_output := 0 ; -- because it takes two lines to set up the foot note end if ; -- else we can fit the entire footnote on the page..although -- we might be forced to add a line to do it... end if ; if lines_we_can_output > 0 then -- we can do something with the foot notes... lines_we_can_output := lines_we_can_output - 2 ; clear_footnotes ( Lines_we_can_output ) ; end if ; end if ; -- output not permitted but we had foot notes to work end if ; -- else we are on the right half of a double column page end if ; if current_physical_parameters.real_center_right = 0 or else not current_physical_parameters.Printing_Left_Side then -- here when we have finished a page, either a normal page or -- else the right side of a dual column page if current_environment.where_to /= to_screen then UpDate_Status ; end if; if Output_Permitted then new_page ; end if ; Increment_Page_Number ; end if ; if current_physical_parameters.real_center_right /= 0 then -- we are doing double column work if current_physical_parameters.Printing_Left_Side then -- we were printing left side if output_permitted then move_to_vertical_position(0); else Printer_Vertical_Position := 0 ; end if ; else -- we were printing right side null ; end if ; current_physical_parameters.Printing_Left_Side := not current_physical_parameters.Printing_Left_Side ; if current_physical_parameters.Printing_Left_Side then current_Physical_Parameters.left_margin := current_physical_parameters.real_left ; current_Physical_Parameters.right_margin := current_physical_parameters.real_center_right ; else current_Physical_Parameters.left_margin := current_physical_parameters.real_center_left ; current_Physical_Parameters.right_margin := current_physical_parameters.real_right ; end if ; set_line_information ; end if ; -- end of double column work ... Need_To_Start_Page := true ; end end_a_page ; Procedure Pstring_To_Output_Line ( Ps : pstring ; OtLine : in out output_line_pointer ) is -- change a standard pstring into an acceptable output line tmp_holder : output_line_pointer ; pstring_temporary_invalid_breaks : boolean_array ; Save_Input_Line : Input_Line_Type := Input_Line ; Save_Input_Line_Length : Input_Line_Index := Input_Line_Length ; begin -- pstring_to_output_line -- first, save the current output line information... tmp_holder := waiting_output_line ; waiting_output_line := OtLine ; OtLine := tmp_holder ; pstring_temporary_invalid_breaks := waiting_output_invalid_breaks ; -- now, move over new data to input line input_line_length := length ( ps ) ; for posn in 1 .. input_line_length loop input_line ( posn ) := extended_character ( character'pos ( ps.data ( posn ) ) ) ; end loop ; -- and move to output line input_line_to_output_line ; -- and then switch back -- and since we do not have any justification, simply ignore any breaks.. tmp_holder := waiting_output_line ; waiting_output_line := OtLine ; OtLine := tmp_holder ; Input_Line := Save_Input_Line ; Input_Line_Length := Save_Input_Line_Length ; end pstring_to_output_line ; procedure send_input_text_to_output_device is -- we have an input line and filling is off begin -- send_input_text_to_output_device output_a_line ( waiting_output_line ) ; end send_input_text_to_output_device ; procedure modify_a_line ( output_line : in out output_line_pointer ) is len : horizontal_measurement ; new_pos : integer ; -- Integer in case they center crazily... rightmost_text_position : horizontal_measurement := current_physical_parameters.paper_width - current_physical_parameters.right_margin ; -- centering does not take into account the subparagraph or goleft begin -- modify_a_line case current_formatting_parameters.line_modification is when nothing => null ; when center_mod => len := output_line.stop_position - output_line.start_position ; new_pos := leftmost_normal_position -- left margin + ( rightmost_text_position -- Plus Right Boundry - leftmost_normal_position -- Minus Left Boundry, giving actual -- potential line length - len ) -- Minus used length, / 2 ; -- divided by 2 if new_pos > 0 then output_line.start_position := new_pos ; else output_line.start_position := 1 ; end if ; output_line.stop_position := output_line.start_position + len ; output_line.justify_to := output_line.stop_position ; output_line.first_justify := waiting_output_line .character_count + 1 ; when right_justify => len := output_line.stop_position - output_line.start_position ; output_line.stop_position := rightmost_text_position ; output_line.start_position := rightmost_text_position - len ; output_line.justify_to := rightmost_text_position ; output_line.first_justify := waiting_output_line .character_count + 1 ; when to_left_margin=> len := output_line.stop_position - output_line.start_position ; output_line.start_position := leftmost_edge_position ; output_line.stop_position := leftmost_edge_position + len ; output_line.justify_to := rightmost_text_position ; output_line.first_justify := waiting_output_line .character_count + 1 ; end case ; -- and adjust modification if necessary if current_formatting_parameters.line_modification /= nothing and then current_formatting_parameters.modification_status = do_while_counting then current_formatting_parameters.modify_to_do := current_formatting_parameters.modify_to_do - 1 ; if current_formatting_parameters.modify_to_do = 0 then -- we have just finished... Current_Formatting_Parameters.Filling_On := current_formatting_parameters.Fill_Before_Special ; Current_Formatting_Parameters.Justification_On := current_formatting_parameters.Just_Before_Special ; Current_Formatting_Parameters.Modification_Status := Off ; Current_Formatting_Parameters.Line_Modification := Nothing ; end if ; end if ; end modify_a_line ; procedure set_line_data( LineInfo : in out heading_or_footing_line_pointer ; LineData : in output_line_type ) is begin -- set_line_data LineInfo.Data := LineData ; end set_line_data ; procedure set_next_ptr ( LineInfo : heading_or_footing_line_pointer ) is begin -- set_next_ptr LineInfo.Next_Line := freelist_heading.get_from_free_list ; end set_next_ptr ; function next_line_ptr ( LineInfo : heading_or_footing_line_pointer ) return heading_or_footing_line_pointer is begin -- next_line_ptr return LineInfo.next_line ; end next_line_ptr ; function return_line_data(LineInfo : in heading_or_footing_line_pointer) return output_line_type is begin -- return_line_data return LineInfo.data ; end return_line_data ; procedure initialize_print_out_for_a_new_document is begin -- initialize_print_out_for_a_new_document if current_environment.where_to = to_screen then start_console_page ; else -- for output to text file for later editing Console_Last := 0 ; Console_Length := 0 ; Console_Line_Number := 0 ; end if ; -- Now, do private items... Printer_Position := 0 ; Printer_Vertical_Position := 0 ; -- console items set by start_console_page page_number_line.all := blank_output_line ; page_number_position := 0 ; temporary_line.all := blank_output_line ; waiting_output_line.all := blank_output_line ; Points_Moved_Since_Text_Sent_To_Output_Device := 0 ; end initialize_print_out_for_a_new_document ; procedure finish_print_out_for_an_old_document is -- temp : boolean ; begin -- finish_print_out_for_an_old_document clear_a_list ( Current_Document_Parameters.FootNote_Pointer ) ; -- that is possible if only selected pages were requested... clear_a_list ( Current_Document_Parameters.Footing_Pointer ) ; clear_a_list ( Current_Document_Parameters.Heading_Pointer ) ; end finish_print_out_for_an_old_document ; procedure close_print_out is temp : boolean ; begin -- close_print_out null ; -- need to release that memory... end close_print_out ; begin -- print_out ; page_number_line := new output_line_type ; temporary_line := new output_line_type ; end print_out ; --$$$- PRNTOUT --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntmsc --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTMSC -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Energy Systems Group -- Ada Software Development Project Team -- 2280 U.S. Highway 19 North, Suite 120 -- Clearwater, Florida 33575 -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with direct_io ; with text_io ; with io_exceptions ; with string_library ; use string_library ; with basic_io_system ; with crt_windows ; use crt_windows ; with Wordp_Globals ; use Wordp_Globals ; with name_tree ; use name_tree ; with Printer_globals ; use printer_globals ; with printf ; use printf ; with print_in_to_out ; use print_in_to_out ; with print_out ; use print_out ; Package Printer_Misc is Commands_Were_Processed_Just_Now : boolean ; -- set by get_line. If get_line has to process any commands while -- looking for new text, this item is set true, otherwise, it is -- set false type vertical_movement_request_type is ( stay_on_this_line , move_forward_on_page , move_backward_on_page , move_to_absolute_position ) ; end_of_main_input_file : boolean ; ready_to_stop : boolean ; processing_comment_area: boolean ; amount_waiting_to_move_vertically_before_line : vertical_measurement ; kind_of_move_before_line : vertical_movement_request_type ; amount_waiting_to_move_vertically_after_line : vertical_measurement ; kind_of_move_after_line : vertical_movement_request_type ; text_waiting_inside_filled_paragraph : boolean ; tab_requested_to_position : horizontal_measurement ; just_did_tab_command : boolean ; specifically_requested_to_remain_on_this_line : boolean ; max_switches : constant integer := 20 ; type switch_list is array ( 1 .. max_switches ) of boolean ; switches : switch_list ; command_word : a_tree_name_string ; command_tree : name_node := null ; -- types for a command line parse type numeric_contents_type is ( no_numeric_contents , absolute_numeric , positive_rel_numeric , negative_rel_numeric ) ; type modifier_type is ( no_modifier , default_modifier , on_modifier , off_modifier , toggle_modifier , top_modifier , bottom_modifier , left_modifier , right_modifier , center_modifier , alternating_modifier ) ; -- now, we have the results of a command line parse command_node : name_node ; command : text_formatter_command ; -- that is the command which was specified user_command_number : integer ; -- that is a number that signifies the -- special number a user can associate -- with user defined commands numeric_contents : numeric_contents_type ; -- this tells us if we have any numeric -- parameters, and if so whether it is -- absolute, positive relative, or -- negative relative. numeric_value : integer ; -- only defined if numeric_contents is -- not no_numeric_contents modifier_one : modifier_type ; -- if they have an alphabetic modifier, -- what is its value.... none, -- ON, OFF, or TOGGLE -- (can be abbr. to first 2 letters ) modifier_two : modifier_type ; -- if they have an alphabetic modifier, -- what is its value.... none, -- ON, OFF, or TOGGLE -- (can be abbr. to first 2 letters ) text_parameters : pstring ; -- if text parameters follow, -- ( noted by a ' or " as the -- signal ), then it is loaded -- into text_parameters -- trailing blanks are NOT significant Next_Position_To_Work : Input_Line_Index ; -- end of the results of a command line parse exactly_one : constant boolean := true ; type an_allowed_option is ( o_any_numeric , o_abs_numeric , o_rel_numeric , o_on_off , o_off , o_toggle , o_top_bottom , o_l_r_c_alt , o_text_param , o_none ) ; Index_Output_File : Text_IO.File_Type ; Index_File_Is_Open : Boolean ; Index_File_Name : Ascii_Text_File_Name ; -- now for some variable data max_user_variables : constant integer := 20 ; user_variable_data : array ( 1 .. max_user_variables ) of pstring ; function user_interrupt return boolean ; function select_font( New_Font_Number : in Font_Number ) return boolean ; procedure set_fixed_font ( Pitch : Horizontal_Measurement ) ; Procedure Parse_Input_Command_Line ; function map_up ( c : extended_character ) return extended_character ; Function If_Function return boolean ; -- Now, for some input line processing routines procedure initialize_printer_misc_for_a_new_document ; procedure finish_printer_misc_for_an_old_document ; procedure close_printer_misc ; --###--RSC02 end Printer_Misc ; Package Body Printer_Misc is package font_io is new direct_io( font_type ) ; font_input_file : font_io.file_type ; function user_interrupt return boolean is cc : character ; begin -- user_interrupt if basic_io_system.key_is_pressed then loop goto_line_column ( master_window , 23 , 1 ) ; cc := char_within_range_or_abort ( ' ' , ' ' , '~' ) ; clear_end_of_screen ( master_window , 23 , 1 ) ; case cc is when 'S'|'s'=> clear_end_of_screen ( master_window , 23 , 1 ) ; goto_line_column ( master_window , 23 , 1 ) ; put("User Pause. Tap any character to continue..."); cc := char_within_range_or_abort ( ' ' , ascii.nul , ascii.del ) ; clear_end_of_screen ( master_window , 23 , 1 ) ; when 'H'|'h'=> raise Users_Requested_Abort ; when others => null ; -- end case ; exit when not basic_io_system.key_is_pressed ; end loop ; return false ; else return false ; end if ; end user_interrupt ; Procedure Skip_blanks is begin -- skip_blanks while ( Next_Position_To_Work < Input_Line_Length ) and ( Input_Line(Next_Position_To_Work) = extended_space ) loop Next_Position_To_Work := Next_Position_To_Work + 1 ; end loop ; end skip_blanks ; Procedure Get_Command is -- note that get_command requires that a space be the last character -- of all input lines.... Command_Word_Place : integer := 1 ; begin -- get_command Command_Word := blank_tree_name_string ; while Input_Line(Next_Position_To_Work) /= extended_space and then command_word_place <= a_tree_name_string_length loop command_word(Command_Word_Place) := character'val( Input_Line(Next_Position_To_Work) ) ; Command_Word_Place := Command_Word_Place + 1 ; Next_Position_To_Work := Next_Position_To_Work + 1 ; end loop ; if input_line(next_position_to_work) /= extended_space then -- they had a really long name loop next_position_to_work := next_position_to_work + 1 ; exit when input_line(next_position_to_work) = extended_space ; end loop ; end if ; command_node := query( command_word , command_tree ) ; if command_node = null then command := illegal_command ; else command := command_node.printer_command ; user_command_number := command_node.other_info ; end if ; skip_blanks ; end get_command ; Function Translate_Current_Work_Character_To_Integer return integer is cc : extended_character := Input_Line ( Next_Position_To_Work ) ; begin -- translate_current_work_character_to_integer if ( cc <= extended_nine ) and ( cc >= extended_zero ) then return integer( cc - extended_zero ) ; else return -1 ; end if ; end translate_current_work_character_to_integer ; function map_up ( c : extended_character ) return extended_character is begin -- map_up if c >= extended_lc_a and then c <= extended_lc_z then return c - extended_lc_a + extended_uc_a ; else return c ; end if ; end map_up ; procedure work_text_string is -- they started a string with a leading item....move it over break_character : extended_character ; new_char : extended_character ; next_place : integer := 0 ; begin -- work_text_string if length(text_parameters) > 0 then -- we already have an input string.... command_error( "Multiple Text Parameters Not Allowed." , true , next_position_to_work ) ; else break_character := Input_Line ( Next_Position_To_Work ) ; loop next_position_to_work := next_position_to_work + 1 ; exit when next_position_to_work > input_line_length ; new_char := Input_Line ( Next_Position_To_Work ) ; exit when new_char = break_character ; next_place := next_place + 1 ; text_parameters.data ( next_place ) := character'val ( new_char ) ; end loop ; set_length ( text_parameters , next_place ) ; next_position_to_work := next_position_to_work + 1 ; skip_blanks ; end if ; end work_text_string ; function work_number return integer is -- look at the number which starts at the current position and -- turn it into an integer. If a number is not here, then -- signal with an error message and return a ( -1 ) ; working_number : integer := translate_current_work_character_to_integer ; temp_number : integer := working_number ; begin -- work_number if working_number < 0 then -- error because it should be a number command_error ( "Expecting Number Here.",true, next_position_to_work ) ; end if ; loop next_position_to_work := next_position_to_work + 1 ; working_number := translate_current_work_character_to_integer ; exit when working_number < 0 ; if temp_number > integer'last / 10 - 9 then command_error ( "Number Too Large.", true , next_position_to_work ) ; else temp_number := temp_number * 10 + working_number ; end if ; end loop ; -- we only get here on good number return temp_number ; end work_number ; procedure work_numeric_part ( num_type : in numeric_contents_type ) is temp_number : integer ; number_start : input_line_index ; begin -- work_numeric_part number_start := next_position_to_work ; if num_type /= absolute_numeric then -- must skip the sign... Next_Position_To_Work := Next_Position_To_Work + 1 ; skip_blanks ; end if ; temp_number := work_number ; -- a good one to work if numeric_contents /= no_numeric_contents then -- we have defined two fields.... command_error ( "Only One Numeric Field may appear in a command.", true , number_start ) ; else numeric_contents := num_type ; numeric_value := temp_number ; end if ; skip_blanks ; end work_numeric_part ; Function If_Function return boolean is --###--RSC02 begin -- If_Function --###--RSC02 return true; end If_Function ; Procedure Parse_Input_Command_Line is this_char : extended_character ; cc : character ; Procedure compress_input_line ( only_right : in boolean ) is start_ind : integer := 1 ; ending_ind : integer := input_line_length ; begin if not only_right then -- we are to compress both sides... While start_ind <= ending_ind and then Input_Line(start_ind) = extended_space loop start_ind := start_ind + 1 ; end loop ; end if ; while ending_ind >= start_ind and then Input_Line(ending_ind) = extended_space loop ending_ind := ending_ind - 1 ; end loop ; if start_ind > ending_ind then Input_Line_Length := 0 ; else if start_ind > 1 then for posn in start_ind .. ending_ind loop Input_Line ( posn - start_ind + 1 ) := Input_Line ( posn ) ; end loop ; end if ; Input_Line_Length := ending_ind - start_ind + 1 ; end if ; end compress_input_line ; procedure work_unquoted_text_string is -- we have a string but it is unquoted new_char : extended_character ; next_place : integer := 0 ; begin -- work_unquoted_text_string if length(text_parameters) > 0 then -- we already have an input string.... command_error( "Unrecognized Parameter." , true , next_position_to_work ) ; else -- need to get rid of trailing blanks, just like in prntwork compress_input_line ( True ) ; loop exit when next_position_to_work > input_line_length ; new_char := Input_Line ( Next_Position_To_Work ) ; next_place := next_place + 1 ; text_parameters.data ( next_place ) := character'val ( new_char ) ; next_position_to_work := next_position_to_work + 1 ; end loop ; set_length ( text_parameters , next_place ) ; end if ; -- put ( " Text Parameters => """ ) ; -- put ( text_parameters ) ; -- put ( """" ) ; -- put ( ascii.cr ) ; end work_unquoted_text_string ; procedure work_modifier is -- we have an alphabetic item, so we are assuming that it is -- a modifier start_place : input_line_index ; new_modifier: modifier_type ; ec : extended_character ; cc : character ; procedure unknown_modifier is begin -- unknown_modifier command_error ( "Unrecognized command parameter." , true , start_place ) ; end unknown_modifier ; begin -- work_modifier -- this routine is all in line because it is called LOTS of times start_place := next_position_to_work ; ec := Input_Line ( Next_Position_To_Work ) ; if ec > 128 then cc := ascii.del ; else cc := character'val ( ec ) ; end if ; Next_Position_To_Work := Next_Position_To_Work + 1 ; case cc is when 'a' | 'A' => -- can be alternating new_modifier := alternating_modifier ; when 'b' | 'B' => -- can be Bottom new_modifier := bottom_modifier ; when 'c' | 'C' => -- can be center new_modifier := center_modifier ; -- when 'd' | 'D' => -- can be default -- new_modifier := default_modifier ; when 'l' | 'L' => -- can be Left new_modifier := left_modifier ; when 'o' | 'O' => -- can be ON , OFF ec := Input_Line ( Next_Position_To_Work ) ; if ec > 128 then cc := ascii.del ; else cc := character'val ( ec ) ; end if ; if cc = 'n' or cc = 'N' then new_modifier := on_modifier ; elsif cc = 'f' or cc = 'F' then new_modifier := off_modifier ; else unknown_modifier ; end if ; when 'r' | 'R' => -- can be right new_modifier := right_modifier ; when 't' | 'T' => -- can be Toggle , Top ec := Input_Line ( Next_Position_To_Work ) ; if ec > 128 then cc := ascii.del ; else cc := character'val ( ec ) ; end if ; if cc = 'o' or cc = 'O' then Next_Position_To_Work:=Next_Position_To_Work + 1 ; -- the increment of next_position is guaranteed to -- work because we always know that the last char -- on any line is a space... ec := Input_Line ( Next_Position_To_Work ) ; if ec > 128 then cc := ascii.del ; else cc := character'val ( ec ) ; end if ; if cc = 'g' or cc = 'G' then new_modifier := toggle_modifier ; elsif cc = 'p' or cc = 'P' then new_modifier := top_modifier ; else unknown_modifier ; end if ; else unknown_modifier ; end if ; when others => unknown_modifier ; -- must be an error end case ; if modifier_one = no_modifier then modifier_one := new_modifier ; else if modifier_two = no_modifier then modifier_two := new_modifier ; else command_error ( "Too many command parameters." , true , start_place ) ; end if ; end if ; -- now, we need to scan until we hit a space loop exit when Input_Line ( Next_Position_To_Work ) = extended_space ; Next_Position_To_Work := Next_Position_To_Work + 1 ; end loop ; skip_blanks ; end work_modifier ; begin -- Parse_Input_Command_Line -- make sure that the line ends in a space if input_line_length < max_line_length then input_line_length := input_line_length + 1 ; end if ; Input_Line ( Input_Line_Length ) := extended_space ; -- prepare input line for reading Next_Position_To_Work := 2 ; -- because col 1 has a dot -- prepare default parameter values -- command is set no matter what -- user_command_number is only valid if the command turns into -- a user command. And then, it is set correctly -- somewhere else numeric_contents := no_numeric_contents ; -- numeric_value is only valid if numeric_contents is changed, and -- then whichever routine changes it changes -- the value too... modifier_one := no_modifier ; modifier_two := no_modifier ; set_length ( text_parameters , 0 ) ; -- -- OK. we are ready to parse the line.... -- First...get the command string. get_command ; -- get command gets in the string of characters starting -- at column 2. It reads until the next character avail -- is a space. It stops there and then changes the -- command string into a real name... -- here, we might have commands which must have their info moved over -- into text paramters only... case command is when if_command => return ; when write_command | read_command | insert_command | indexfile_command | index_command => if next_position_to_work <= input_line_length then work_unquoted_text_string ; return ; end if ; when others => null ; -- continue the parse... end case ; -- now, get all modifiers and parameters loop skip_blanks ; exit when Next_Position_To_Work >= input_line_length ; -- there is something there this_char := map_up ( Input_Line ( Next_Position_To_Work ) ) ; if this_char > 128 then cc := ascii.del ; else cc := character'val ( this_char ) ; end if ; case cc is when '+' => work_numeric_part ( positive_rel_numeric ) ; when '-' => work_numeric_part ( negative_rel_numeric ) ; -- we have a relative command when '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' => work_numeric_part ( absolute_numeric ) ; when ''' | '"' => work_text_string ; when others => if this_char >= extended_uc_a and then this_char <= extended_uc_z then work_modifier ; else work_unquoted_text_string ; end if ; end case ; end loop ; end Parse_Input_Command_Line ; function select_font( New_Font_Number : in Font_Number ) return boolean is font_num : font_io.positive_count ; begin -- select_font if new_font_number = current_font.number then space_width := current_font.width ( extended_space ) ; current_font.font_width := space_width ; half_space_width := space_width / 2 ; return true ; -- already set... elsif new_font_number = permanent_font.number then current_font := permanent_font ; space_width := current_font.width ( extended_space ) ; current_font.font_width := space_width ; half_space_width := space_width / 2 ; return true ; elsif new_font_number = temporary_font.number then current_font := temporary_font ; space_width := current_font.width ( extended_space ) ; current_font.font_width := space_width ; half_space_width := space_width / 2 ; return true ; else -- must actually read in from disk.... -- sets selected font as current font.... font_num := font_io.positive_count ( new_font_number ) ; Font_IO.Read ( font_input_file , current_font , font_num ) ; space_width := current_font.width ( extended_space ) ; current_font.font_width := space_width ; half_space_width := space_width / 2 ; return true ; end if ; exception when others => return false ; end select_font ; procedure set_fixed_font ( Pitch : Horizontal_Measurement ) is begin -- set_fixed_font current_font.name := "Mono Pitch " ; current_font.number:= 0 ; current_font.vertical_points_per_inch := 48 ; current_font.horizontal_points_per_inch := 120 ; current_font.Font_width := Pitch ; current_font.Font_height := 8 ; current_font.mappings_necessary := false ; for posn in extended_character loop current_font.width (posn) := horizontal_measurement(pitch); current_font.hammer_intensity(posn) := 1 ; current_font.map_string (posn) (1) := posn ; for inside in 2 .. a_map_string'last loop current_font.map_string (posn) (inside) := 0 ; end loop ; end loop ; Space_Width := current_font.width ( extended_space ) ; Half_Space_Width := Space_Width / 2 ; end set_fixed_font ; procedure printer_misc_global_initialize is pfont_file : pstring ; success : boolean ; function no_blanks ( s : in pstring ) return string is ot_string : string ( 1 .. length(s) ) ; ot_length : integer ; begin -- no_blanks ot_length := 0 ; for place in 1 .. length(s) loop if s.data(place) /= ' ' then ot_length := ot_length + 1 ; ot_string(ot_length) := s.data(place); end if ; end loop ; return ot_string( 1 .. ot_length ) ; end no_blanks ; function font_file_exists ( file_name : in pstring ) return boolean is -- look for this file name with no changes temp_file : font_io.file_type ; begin -- font_file_exists font_io.open(temp_file , font_io.in_file , no_blanks(file_name) ); font_io.close(temp_file) ; return true ; exception when io_exceptions.name_error | io_exceptions.use_error => return false ; when others => return false ; end font_file_exists ; function user_name ( s : in pstring ) return pstring is -- turn this file name into a user name begin -- user_name if basic_io_system.directory_separator = ' ' then -- nothing defined return s; else -- ok. we have a basic_io_system.directory separator to look for if position( basic_io_system.directory_separator , s ) /= 0 then -- they defined the basic_io_system.directory, so don't do anything return s; else -- ok, turn it into the appropriate one return basic_io_system.user_directory & s ; end if ; end if ; end user_name ; function wp_name ( s : in pstring ) return pstring is -- turn this file name into a wp name begin -- wp_name if basic_io_system.directory_separator = ' ' then -- nothing defined return s; else -- ok. we have a directory separator to look for if position( basic_io_system.directory_separator , s ) /= 0 then -- they defined the directory, so don't do anything return s; else -- ok, turn it into the appropriate one return basic_io_system.word_processor_directory & s ; end if ; end if ; end wp_name ; procedure font_to_read ( orig_file_name : in pstring ; final_file_name : out pstring ; fin_successfull : out boolean ) is -- For Editor Program Files (such as help) -- look for the orig_file_name on the appropriate disks. Return -- successfull if found, and also set the final_file_name as -- the fully elaborated file path/name new_name : pstring ; successfull : boolean ; begin -- font_to_read if font_file_exists ( orig_file_name ) then final_file_name := orig_file_name ; successfull := true ; else -- check for a user directory new_name := user_name( orig_file_name ) ; if new_name = orig_file_name then -- nothing we can do about it final_file_name := blank_line ; successfull := false ; else if font_file_exists( new_name ) then final_file_name := new_name ; successfull := true ; else final_file_name := blank_line ; successfull := false ; end if ; end if ; -- just finished looking in the user directory if not successfull then -- look in the system directory new_name := wp_name( orig_file_name ) ; if new_name = orig_file_name then -- nothing we can do about it final_file_name := blank_line ; successfull := false ; else if font_file_exists( new_name ) then final_file_name := new_name ; successfull := true ; else final_file_name := blank_line ; successfull := false ; end if ; end if ; end if ; end if ; fin_successfull := successfull ; end font_to_read ; function e ( c : character ) return extended_character is begin -- e return extended_character( character'pos( c ) ) ; end e ; begin -- printer_misc_global_initialize font_to_read( string_to_pstring ( font_file ) , pfont_file , success ) ; -- We have font_file_exists & Others because Telesoft Ada -- messes with file if we use SOK_TO_READ to determine its location -- ( text_io Stuff in WPGLOBAL ) if not success then error( " Font File Not Available." , fatal_error , operator_wait , short_beep ) ; end if ; font_io.open ( font_input_file , font_io.in_file , no_blanks ( pfont_file ) ) ; -- Now, we have some character processing information Default_Characters_Array := ( e( ascii.nul ), -- Subscript_Start , e( ascii.nul ), -- Subscript_Stop , e( '~' ), -- Subscript_Toggle , e( ascii.nul ), -- Superscript_Start , e( ascii.nul ), -- Superscript_Stop , e( '^' ), -- Superscript_Toggle , e( ascii.nul ), -- e( '<' ), -- Underline_Start , e( ascii.nul ), -- e( '>' ), -- Underline_Stop , e( ascii.nul ), -- Underline_Toggle , e( ascii.nul ), -- UCont_Start , e( ascii.nul ), -- UCont_Stop , e( ascii.nul ), -- e( '|' ), -- UCont_Toggle , e( ascii.nul ), -- UFoot_Start , e( ascii.nul ), -- UFoot_Stop , e( ascii.nul ), -- UFoot_Toggle , e( ascii.nul ), -- e( '{' ), -- Bold_Start , e( ascii.nul ), -- e( '}' ), -- Bold_Stop , e( ascii.nul ), -- Bold_Toggle , e( ascii.nul ), -- e( '[' ), -- Shadow_Start , e( ascii.nul ), -- e( ']' ), -- Shadow_Stop , e( ascii.nul ), -- Shadow_Toggle , e( ascii.nul ), -- Temp_Font_Start , e( ascii.nul ), -- Temp_Font_Stop , e( ascii.nul ), -- e( '/' ), -- Temp_Font_Toggle , e( ascii.nul ), -- Soft_Hyphen , e( '\' ), -- Dot_Leader , e( ascii.nul ), -- Character_Tab , e( ' ' ), -- Actual_Space , e( ascii.nul ), -- e( '_' ), -- Forced_Space , e( ascii.nul ), -- Text_Character , e( ascii.nul ) -- Illegal_Character , ) ; -- End of character processing information -- exception -- when others => -- Here on font file error -- error( " Font File Not Available." , fatal_error , -- operator_wait , short_beep ) ; end printer_misc_global_initialize ; procedure initialize_printer_misc_for_a_new_document is begin -- initialize_printer_misc_for_a_new_document end_of_main_input_file := false ; ready_to_stop := false ; processing_comment_area := false ; amount_waiting_to_move_vertically_before_line := 0 ; amount_waiting_to_move_vertically_after_line := 0 ; kind_of_move_before_line := move_forward_on_page ; kind_of_move_after_line := move_forward_on_page ; text_waiting_inside_filled_paragraph := false ; just_did_tab_command := false ; for numb in 1 .. max_switches loop switches ( numb ) := false ; end loop ; index_file_is_open := false ; for numb in 1 .. max_user_variables loop set_length ( user_variable_data ( numb ) , 0 ) ; end loop ; specifically_requested_to_remain_on_this_line := false ; index_file_name := no_file ; end initialize_printer_misc_for_a_new_document ; procedure finish_printer_misc_for_an_old_document is begin -- finish_printer_misc_for_an_old_document null ; end finish_printer_misc_for_an_old_document ; procedure close_printer_misc is begin -- close_printer_misc Font_IO.close ( font_input_file ) ; end close_printer_misc ; begin -- Printer_Misc printer_misc_global_initialize ; end Printer_Misc ; --$$$- PRNTMSC --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntcmd --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTCMD -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with text_io ; with string_library ; use string_library ; with basic_io_system ; with crt_windows ; use crt_windows ; with Wordp_Globals ; use Wordp_Globals ; with name_tree ; use name_tree ; with Printer_globals ; use printer_globals ; with printf ; use printf ; with print_in_to_out ; use print_in_to_out ; with print_out ; use print_out ; with printer_misc ; use printer_misc ; Package Printer_Commands is Procedure Options ( Return_Input_Line_Contains_Text : out boolean ) ; procedure initialize_printer_commands_for_a_new_document ; procedure finish_printer_commands_for_an_old_document ; procedure close_printer_commands ; procedure force_into_input_stream ( s : pstring ; Input_Line_Contains_Text : out boolean) ; procedure load_input_line ( skip_blank_lines : boolean := false ) ; Procedure Move_Before_Current_Line ( allow_one_extra : boolean := false ; allow_one_less : boolean := false ) ; procedure tidy_up_and_output_filled_line ( Last_Line_In_Paragraph : Boolean := False ) ; Filling_output_line : output_line_pointer ; -- this is where the filled text goes... filling_trailing_spaces : integer ; end Printer_Commands ; Package Body Printer_Commands is -- package cmd_io is new enumeration_io(text_formatter_command) ; Temp_Input_Pstring : Pstring ; Vertical_Page_Limit : Integer ; -- It is really, normally, a Vertical_Measurement, but if we have a -- lot of foot notes, we could make it negative, meaning that we have -- suddenly generated over a page of foot notes.... -- what is the last position we can use vertically?? erased_it : boolean := false ; last_line : integer := 0 ; procedure deb ( s : string ; info : integer := 0 ) is begin -- deb if ( s = "PAUSE" ) or ( s = "pause" ) then -- we must pause ... if User_Pause ( "Pause!" , true ) then raise users_requested_abort ; end if ; erased_it := true ; clear_window( master_window ) ; clear_prompt( master_window ) ; last_line := 1 ; else if not erased_it then erased_it := true ; clear_window( master_window ) ; clear_prompt( master_window ) ; last_line := 1 ; elsif ( last_line = 20 ) then -- we must pause ... if User_Pause ( "Pause!" , true ) then raise users_requested_abort ; end if ; erased_it := false ; end if ; -- here ready to go to work last_line := last_line + 1 ; goto_line_column ( master_window , last_line , 2 ) ; put ( s ) ; if s'length < 30 then for posn in s'length + 1 .. 30 loop put ( ' ' ) ; end loop ; end if ; put ( " " ) ; put ( info , 5 ) ; end if ; end deb ; procedure reset_vertical_physical_page_limits is -- physical boundries were changed....re set any other information -- note that this MUST be called after each page is output, just in -- case footnotes change things.... page_number_line_ready : boolean ; bottom_Loc : Integer ; PageNum_Loc : Integer ; Footer_Loc : Integer ; FootNote_And_Footer_Loc : Integer ; -- These items are really vertical_measurements, but we want to -- do our own error handling in case the user asked for -- strange things.... we_have_command_error : Boolean := false ; err_code : Integer ; begin -- reset_vertical_physical_page_limits -- First: We must move to the correct vertical position.... -- page number ? page_number_line_ready := Current_Document_Parameters.Page_Numbering_On and not Current_Document_Parameters.Number_Page_At_Top ; -- Bottom_Loc is the last printable vertical position Bottom_Loc := Current_Physical_Parameters.Paper_Length - Current_Physical_Parameters.Bottom_Margin ; --###-- RSC -- work with font_height later!!! If Bottom_Loc < 0 then -- If bottom margin is > paper_length, we ZERO Bottom Margin Current_Physical_Parameters.Bottom_Margin := 0 ; Bottom_Loc := Current_Physical_Parameters.Paper_Length ; we_have_command_error := true ; err_code := 1 ; end if ; -- Footer_Loc is where to start the footer -- Note that the page number shares the last line with the -- footer If Current_Document_Parameters.Footing_Height > 0 then -- page numbers do not matter Footer_Loc := Bottom_Loc - Current_Document_Parameters.Footing_Height ; elsif page_number_line_ready then -- footers do not matter Footer_Loc := Bottom_Loc - current_vertical_motion_index - current_vertical_motion_index ; -- page number takes two lines.. -- or ?? - Current_Font.Font_Height ; else Footer_Loc := Bottom_Loc ; end if ; -- JENNIFER ! Read This ! If Footer_Loc < 0 then we_have_command_error := true ; Footer_Loc := Bottom_Loc ; If Current_Document_Parameters.Footing_Height > 0 then -- Footing Too Large... err_code := 2 ; Current_Document_Parameters.Footing_Height := 0 ; else -- page number problem err_code := 3 ; Current_Document_Parameters.Page_Numbering_On := false ; end if ; end if ; -- FootNote_And_Footer_Loc is location to start the footer information FootNote_And_Footer_Loc := Footer_Loc - Current_Document_Parameters.FootNote_Height ; Vertical_Page_Limit := Footnote_And_Footer_Loc ; if we_have_command_error then case err_code is when 1 => command_error ("Bottom Margin larger than Paper Length. Margin Zeroed." , true ); when 2 => command_error ( "Paper not long enough for Footer. Footing Zeroed." , true ) ; when 3 => command_error ( "Paper not long enough for page number. Turned Off." , true ); when others => null ; -- can't get here end case ; end if ; end reset_vertical_physical_page_limits ; Procedure Move_Before_Current_Line ( allow_one_extra : boolean := false ; allow_one_less : boolean := false ) is -- perform any necessary movement required before the current line -- allow one extra if this is the last line of a paragraph -- allow one less if this is the first line of a paragraph which -- has more lines following. The_Vertical_Page_Limit : Vertical_Measurement := Vertical_Page_Limit ; begin -- move_before_current_line if need_to_start_page then start_a_page ; end if ; case kind_of_move_before_line is when stay_on_this_line => null ; -- don't do anything when move_forward_on_page => if amount_waiting_to_move_vertically_before_line > 0 then -- we must do the movement... if allow_one_less then The_Vertical_Page_Limit := The_Vertical_Page_Limit - current_vertical_motion_index ; elsif allow_one_extra then The_Vertical_Page_Limit := The_Vertical_Page_Limit + current_vertical_motion_index ; end if ; if printer_vertical_position + amount_waiting_to_move_vertically_before_line >= The_Vertical_Page_Limit then -- new page... end_a_page ; reset_vertical_physical_page_limits ; start_a_page ; -- kind_of_move_after_line := -- stay_on_this_line ; -- amount_waiting_to_move_vertically_after_line := -- 0 ; -- no need to move because we have just started a -- new page else -- must do it... move_down_vertically ( amount_waiting_to_move_vertically_before_line ) ; end if ; end if ; when move_backward_on_page => if amount_waiting_to_move_vertically_before_line > 0 -- we must do the movement... and then printer_vertical_position - amount_waiting_to_move_vertically_before_line >= 0 then -- we can move... move_to_vertical_position ( printer_vertical_position - amount_waiting_to_move_vertically_before_line ) ; end if ; when move_to_absolute_position => move_to_vertical_position ( amount_waiting_to_move_vertically_before_line ) ; end case ; kind_of_move_before_line := kind_of_move_after_line ; amount_waiting_to_move_vertically_before_line := amount_waiting_to_move_vertically_after_line ; -- if we are waiting on some motion....do the movement... -- 1st: determine how much room is left on page... -- 2nd: add one line of room if requested -- 3rd: if end of page then put in bottom information -- 4th: & then if double column move to top of second col -- and then set new horizontal -- if real_center_right > 0 then -- we have two columns -- 5th: & then if not double column start a new page -- 6th: else if not eop then simply put in any requested lines -- set any necessary horizontal bounds before we process a line -- which will be output... end move_before_current_line ; procedure finish_current_text( vert_request : vertical_movement_request_type := move_forward_on_page; vert_number : integer := 0 ) is -- we have a request to change an option which will have far reaching -- effects. Therefore, finish any output which might be pending -- then, the vert request should be processed... -- allow_abort : boolean ; begin -- finish_current_text if ( vert_request = move_forward_on_page ) and then ( vert_number = 0 ) and then ( not text_waiting_inside_filled_paragraph ) then -- we don't need to do a thing... return ; end if ; -- First do any saved up vertical movement kind_of_move_after_line := vert_request ; amount_waiting_to_move_vertically_after_line := vert_number * Current_Vertical_Motion_Index ; if text_waiting_inside_filled_paragraph then amount_waiting_to_move_vertically_after_line := amount_waiting_to_move_vertically_after_line + Current_Vertical_Motion_Index ; -- because we put in one <lf> no matter what..... end if ; move_before_current_line ( text_waiting_inside_filled_paragraph ) ; -- does movement and allows this last line of paragraph on -- page if filling is on... -- moves after settings to before settings. if text_waiting_inside_filled_paragraph then -- we need to finish the current paragraph.... tidy_up_and_output_filled_line ( true ) ; -- that's it, when we try to merge a new line and don't find any -- text, then we will set correctly for a new paragraph... end if ; end finish_current_text ; procedure reset_horizontal_physical_page_limits is -- physical boundries were changed....re set any other information begin -- reset_horizontal_physical_page_limits -- note that this must check to make sure that we have some room -- between the margins for text rightmost_text_position := current_physical_parameters.paper_width - current_physical_parameters.right_margin - current_formatting_parameters.Right_Indentation ; leftmost_edge_position := current_physical_parameters.left_margin ; leftmost_normal_position := leftmost_edge_position + current_formatting_parameters.Left_Indentation ; leftmost_para_text_position := leftmost_normal_position + current_formatting_parameters.Paragraph_Indent ; leftmost_text_position := leftmost_normal_position + current_formatting_parameters.Subsequent_Line_Ind ; end reset_horizontal_physical_page_limits ; procedure horizontal_control_values_changed is -- physical boundries were changed....re set any other information begin -- horizontal_control_values_changed reset_horizontal_physical_page_limits ; end horizontal_control_values_changed ; Function New_Value ( old_value : integer ; smallest : integer ; largest : integer ; factor : integer ) return integer is -- old_value is in real units -- smallest and largest are in user's entered units -- factor tells how to convert old_value to user's units, and -- then how to turn the resulting number into an internal number new_val : integer ; old_val : integer ; begin -- new_value -- we get here knowing that we have some type of numeric contents if modifier_one = default_modifier then -- we simply set the default value.... new_val := user_command_number ; elsif modifier_one = on_modifier then new_val := largest ; elsif modifier_one = off_modifier then new_val := 0 ; elsif numeric_contents = absolute_numeric then -- we must determine the new value .... new_val := numeric_value ; elsif numeric_contents = positive_rel_numeric then old_val := old_value / factor ; -- to change into user units... if largest - old_val < numeric_value then -- old_val + numeric_value > largest command_error ( "Relative Numeric Parameter Results In Invalid Number." , true ); else new_val := old_val + numeric_value ; end if ; elsif numeric_contents = negative_rel_numeric then -- negative old_val := old_value / factor ; -- to change into user units... if numeric_value > old_val - smallest then -- old_val - numeric_value < smallest command_error ( "Relative Numeric Parameter Results In Invalid Number." , true ); else new_val := old_val - numeric_value ; end if ; else -- no modifier or numeric....defaults to zero new_val := 0 ; -- for such commands as ".add" meaning ".add 0" or ".newp" end if ; -- we get here with new_val as the new value to use... if new_val > largest then -- number command_error ("Numeric Parameter Is Too Large." , true ); elsif new_val < smallest then command_error ("Numeric Parameter Is Too Small." , true ); else return new_val * factor ; end if ; exception when numeric_error => command_error ( "Numeric Parameter Results In Invalid Number." , true ) ; end new_value ; procedure load_input_line ( skip_blank_lines : boolean := false ) is eof : boolean ; begin -- load_input_line loop read_next_line ( temp_input_pstring , eof ) ; exit when length ( temp_input_pstring ) > 0 or else ( not skip_blank_lines ) or else eof ; end loop ; physical_input_lines := physical_input_lines + 1 ; -- convert to input line... input_line_length := length ( temp_input_pstring ) ; for posn in 1 .. input_line_length loop input_line ( posn ) := extended_character ( character'pos ( temp_input_pstring.data ( posn ) ) ) ; end loop ; if input_line_length < max_line_length then input_line ( input_line_length + 1 ) := extended_space ; end if ; if eof then if where_to_read = alternate_input_file then if length ( temp_input_pstring ) = 0 then -- end of a secondary file select_for_read ( main_input_file ) ; load_input_line ( skip_blank_lines ) ; -- else work this line as is before returning to main file end if ; else if length ( temp_input_pstring ) = 0 then end_of_main_input_file := true ; -- else work this line as is before returning to main file end if ; end if ; end if ; -- -- here is where the soft hyphen recovery would go -- innxt := 1 ; -- if ( length(instring) > 3 ) then -- -- this is the soft hyphen recover routine -- for w in reverse length(in_string)-2 .. length(in_string) loop -- if in_string.data(w) = soft_hyphen then -- if filling then -- in_string.data(w) := character'val(1) ; -- -- because filling will bring in next line -- else -- in_string.data(w) := '-' ; -- end if ; -- set_length(in_string , w) ; -- end if ; -- end loop ; -- end if ; end load_input_line ; procedure force_into_input_stream ( s : pstring ; Input_Line_Contains_Text : out boolean) is begin -- force_into_input_stream for posn in 1 .. length ( s ) loop input_line(posn) :=extended_character ( character'pos ( s.data(posn) ) ) ; end loop ; Input_Line_Length := length ( s ) ; Input_Line_Contains_Text := Input_Line_Length > 0 ; end force_into_input_stream ; procedure param_error ( op : an_allowed_option ) is -- error. They have put the op in a command which does not -- allow that option temp_string : string ( 1 .. 21 ) ; begin -- param_error case op is when o_any_numeric => temp_string := "Numeric " ; when o_abs_numeric => temp_string := "Absolute Numeric " ; when o_rel_numeric => temp_string := "Relative Numeric " ; when o_on_off => temp_string := "On " ; when o_off => temp_string := "Off " ; when o_toggle => temp_string := "Toggle " ; when o_top_bottom => temp_string := "Top and Bottom " ; when o_l_r_c_alt => temp_string := "Left/Right/Center/Alt" ; when o_text_param => temp_string := "String " ; when o_none => null ; -- cannot get here anyway end case ; command_error ( ps_to_s ( compress( temp_string ) & " Parameters not allowed with this command." ) , true ); end param_error ; procedure allow_options ( exactly_one_allowed : boolean ; op_1 , op_2 , op_3 , op_4 , op_5 , op_6 , op_7 , op_8 : an_allowed_option := o_none ) is -- examine the current options to determine if any have been set -- which are not allowed for this command cur_allowed : array ( an_allowed_option ) of boolean := ( an_allowed_option'first .. an_allowed_option'last => false ) ; op_count : integer := 0 ; begin -- allow_options cur_allowed ( op_1 ) := true ; cur_allowed ( op_2 ) := true ; cur_allowed ( op_3 ) := true ; cur_allowed ( op_4 ) := true ; cur_allowed ( op_5 ) := true ; cur_allowed ( op_6 ) := true ; cur_allowed ( op_7 ) := true ; cur_allowed ( op_8 ) := true ; if numeric_contents /= no_numeric_contents then op_count := op_count + 1 ; if cur_allowed ( o_any_numeric ) then null ; -- we have a numeric and we allow any numeric elsif ( numeric_contents = absolute_numeric ) then if cur_allowed ( o_abs_numeric ) then null ; -- again, we have a good one... else -- error, absolute numeric not allowed for this command param_error ( o_abs_numeric ) ; end if ; elsif cur_allowed ( o_rel_numeric ) then null ; -- good, we have a relative else -- error, we have relative but it is not allowed param_error ( o_rel_numeric ) ; end if ; end if ; if modifier_one /= no_modifier then op_count := op_count + 1 ; if modifier_one = on_modifier then if not cur_allowed ( o_on_off ) then param_error ( o_on_off ) ; end if ; elsif modifier_one = off_modifier then if not ( cur_allowed ( o_on_off ) or cur_allowed ( o_off ) ) then param_error ( o_off ) ; end if ; elsif modifier_one = toggle_modifier then if not cur_allowed ( o_toggle ) then param_error ( o_toggle ) ; end if ; elsif modifier_one = top_modifier or else modifier_one = bottom_modifier then if not cur_allowed ( o_top_bottom ) then param_error ( o_top_bottom ) ; end if ; elsif modifier_one = default_modifier then null ; -- it has to be ok... else -- it is left/right/center/alt if not cur_allowed ( o_l_r_c_alt ) then param_error ( o_l_r_c_alt ) ; end if ; end if ; if modifier_two /= no_modifier then op_count := op_count + 1 ; if modifier_two = on_modifier then if not cur_allowed ( o_on_off ) then param_error ( o_on_off ) ; end if ; elsif modifier_two = off_modifier then if not ( cur_allowed ( o_on_off ) or cur_allowed ( o_off ) ) then param_error ( o_off ) ; end if ; elsif modifier_two = toggle_modifier then if not cur_allowed ( o_toggle ) then param_error ( o_toggle ) ; end if ; elsif modifier_two = top_modifier or else modifier_two = bottom_modifier then if not cur_allowed ( o_top_bottom ) then param_error ( o_top_bottom ) ; elsif modifier_one = top_modifier or modifier_one = bottom_modifier then command_error ("Cannot have multiple vertical parameters." , true ); end if ; elsif modifier_two = default_modifier then null ; -- it has to be ok... else -- it is left/right/center/alt if not cur_allowed ( o_l_r_c_alt ) then param_error ( o_l_r_c_alt ) ; elsif modifier_one = left_modifier or modifier_one = right_modifier or modifier_one = center_modifier or modifier_one = alternating_modifier then command_error ("Cannot have multiple horizontal parameters.",true); end if ; end if ; end if ; end if ; if length( text_parameters ) > 0 then op_count := op_count + 1 ; if not cur_allowed ( o_text_param ) then param_error ( o_text_param ) ; end if ; end if ; if exactly_one_allowed and then op_count /= 1 then command_error("Exactly One Parameter must be given with this command." , true ); end if ; end allow_options ; procedure initialize_printer_commands_globally is procedure add ( cmd : text_formatter_command ; name : string ; default : integer ) is begin -- add insert_name ( name , cmd , default , command_tree ) ; end add ; procedure build_command_tree_1 is -- put the information into the tree so that we can get the -- data back later -- e - extra command added to do the same thing as an old command -- c - this command conflicts with old commands. Old commands will -- need to be spelled out further -- n - new command added -- x - old command changed begin -- build_command_tree_1 -- First, to get the basic tree set up add ( mult_line_spacing_command , "multiple_line_spacing",000 ); add ( fill_command , "filling" , 000 ) ; add ( center_command , "center" , 000 ) ; add ( shadow_printing_command , "italic_printing" , 000 ) ; --e add ( subpara_command , "subparagraph" , 000 ) ; --4 add ( right_margin_command , "right_margin_in_tenths",000 ); --e add ( underline_chars_command , "underline_characters", 000 ) ; -- Now, fill in ... add ( add_command , "add_blank_line" , 000 ) ; add ( bold_command , "bold" , 000 ) ; add ( backward_add_command , "backward_add" , 000 ) ; --e add ( backward_add_command , "badd" , 000 ) ; add ( binding_command , "binding_edge" , 000 ) ; add ( bottom_margin_command , "bottom_margin_in_sixths",000); --e add ( bottom_margin_command , "bmargin_in_sixths" , 000 ) ; -- add ( center_command , "center" , 000 ) ; add ( dot_lead_command , "c_dot_leader" , 000 ) ; --e add ( char_spacing_command , "character_spacing" , 000 ) ; add ( prop_spacing_command , "change_to_font" , 000 ) ; --x add ( underline_cont_command , "continuous_underline", 000 ) ; --e add ( comments_command , "comments" , 000 ) ; --x add ( date_dmy_command , "dmy" , 000 ) ; add ( dot_lead_command , "dlead" , 000 ) ; add ( justify_numbers_command , "dots" , 000 ) ; add ( end_page_command , "endpage" , 000 ) ; --4 add ( else_command , "else" , 000 ) ; add ( end_page_command , "end_page" , 000 ) ; --e5 add ( finish_command , "end_if" , 000 ) ; --ec add ( envelope_feed_command , "envelope_feed" , 000 ) ; end build_command_tree_1 ; procedure build_command_tree_2 is begin -- build_command_tree_2 -- add ( fill_command , "filling" , 000 ) ; add ( fancy_print_command , "fancy_printing" , 000 ) ; add ( finish_command , "finish" , 000 ) ; add ( prop_spacing_command , "font" , 000 ) ; --e add ( footers_command , "footer" , 000 ) ; --5 add ( footnote_command , "foot_note" , 000 ) ; --ec add ( forward_printing_command , "forward_printing" , 000 ) ; add ( footnote_command , "fnote" , 000 ) ; add ( go_left_command , "go_left" , 000 ) ; --e add ( go_left_command , "goleft" , 000 ) ; add ( headers_command , "header" , 000 ) ; add ( underline_foothead_command , "head_foot_underline_char",000); add ( head_foot_space_command , "hfspacing" , 000 ) ; add ( underscore_command , "horizontal_line" , 000 ) ; --e -- add ( shadow_printing_command , "italic_printing" , 000 ) ; --e add ( index_command , "idx" , 000 ) ; add ( if_command , "if" , 000 ) ; --e add ( ifswitch_command , "if_switch" , 000 ) ; --e add ( indexfile_command , "ifile" , 000 ) ; add ( ifswitch_command , "ifswitch" , 000 ) ; add ( insert_command , "include_file" , 000 ) ; add ( indent_command , "indent" , 000 ) ; --5 add ( index_command , "index" , 000 ) ; --ec add ( indexfile_command , "index_file" , 000 ) ; --ec add ( insert_command , "insert_file" , 000 ) ; add ( justify_margins_command , "justify_margins" , 000 ) ; --5 add ( justify_numbers_command , "just_numbers" , 000 ) ; --ec end build_command_tree_2 ; procedure build_command_tree_3 is begin -- build_command_tree_3 add ( left_margin_command , "left_margin_in_tenths",000 ); --e add ( lcrm_command , "lcrm" , 000 ) ; add ( vert_line_spacing_command , "line_point_spacing" , 000 ) ; --ec add ( left_margin_command , "lmargin_in_tenths" , 000 ) ; -- add ( mult_line_spacing_command , "multiple_line_spacing",000 ); add ( date_mdy_command , "mdy" , 000 ) ; add ( date_slash_command , "m/d/y" , 000 ) ; add ( date_dash_command , "m-d-y" , 000 ) ; add ( new_para_command , "new_paragraph" , 000 ) ; add ( indent_neg_command , "negative_indent" , 000 ) ; add ( para_indent_command , "pindent" , 000 ) ; add ( page_numbering_command , "page_numbering" , 000 ) ; --e add ( paper_length_command , "paper_length_in_sixths",000 ); add ( paper_width_command , "paper_width_in_tenths",000 ) ; --ec add ( para_indent_command , "paragraph_indent" , 000 ) ; --e add ( pause_command , "pause" , 000 ) ; add ( char_width_command , "points_per_character", 000 ) ; add ( printer_control_command , "printer_dumb" , 000 ) ; --x -- add ( right_margin_command , "right_margin_in_tenths",000 ); --e add ( rclm_command , "rclm" , 000 ) ; add ( read_command , "read_line_from_keyboard",000); add ( ribbon_color_command , "red_ribbon" , 000 ) ; add ( justify_rtmargin_command , "right_justify" , 000 ) ; --ec add ( justify_rtmargin_command , "rjust" , 000 ) ; add ( right_margin_command , "rmargin_in_tenths" , 000 ) ; end build_command_tree_3 ; procedure build_command_tree_4 is begin -- build_command_tree_4 -- add ( subpara_command , "subparagraph" , 000 ) ; --4 add ( line_save_command , "save_lines" , 000 ) ; add ( same_line_command , "same_line_again" , 000 ) ; add ( page_numbering_command , "set_page_number" , 000 ) ; --x add ( section_page_numbering_command,"section_numbering" , 000 ) ; --e add ( section_page_numbering_command,"set_section_number" , 000 ) ; --x add ( switch_command , "set_switch" , 000 ) ; --ec add ( shadow_printing_command , "shadow_printing" , 000 ) ; add ( bold_character_command , "sig_bold_character" , 000 ) ; add ( dot_lead_command , "sig_dot_leader_character", 000 ); add ( forced_space_character_command,"sig_forced_space_char",000 ); add ( underline_foothead_command ,"sig_head_foot_und_char",000 ); add ( shadow_character_command , "sig_italic_character", 000 ) ; add ( shadow_character_command , "sig_shadow_character", 000 ) ; add ( hypen_command , "sig_soft_hyphen_char", 000 ) ; add ( subscript_command , "sig_subscript_character", 000 ); add ( superscript_command , "sig_superscript_character", 000 ); add ( temporary_font_character_command,"sig_temp_font_character",000 ); add ( underline_character_command,"sig_underline_character",000 ) ; add ( ucontinuous_character_command,"sig_ucont_character" , 000 ) ; add ( hypen_command , "soft_hyphen_character",000 ); add ( subscript_command , "subscript_character" , 000 ) ; add ( superscript_command , "superscript_character", 000 ); add ( switch_command , "switch" , 000 ) ; end build_command_tree_4 ; procedure build_command_tree_5 is begin -- build_command_tree_5 add ( top_margin_command , "tmargin_in_sixths" , 000 ) ; add ( tabs_command , "tab_to_character_position", 000 ); add ( top_margin_command , "top_margin_in_sixths", 000 ) ; --e -- add ( underline_chars_command , "underline_characters", 000 ) ; add ( underline_cont_command , "ucontinuous" , 000 ) ; add ( underline_foothead_command , "ufoot_character" , 000 ) ; add ( underscore_command , "underscore" , 000 ) ; --ec add ( vert_line_spacing_command , "vertical_line_spacing",000 ); -- add ( variable_data_command , "variable_data_insertion", 000 );--x -- the above command is only loaded and available if the variable -- insertion option is requested... add ( tabs_vertical_command , "vertical_tab_to_line", 000 ) ; --ec add ( tabs_vertical_command , "vtab_to_line_number" , 000 ) ; add ( paper_width_command , "width_in_tenths" , 000 ) ; add ( write_command , "write_message_to_console", 000 ); add ( date_ymd_command , "ymd" , 000 ) ; end build_command_tree_5 ; begin -- initialize_printer_commands_globally is build_command_tree_1 ; build_command_tree_2 ; build_command_tree_3 ; build_command_tree_4 ; build_command_tree_5 ; end initialize_printer_commands_globally ; procedure tidy_up_and_output_filled_line ( Last_Line_In_Paragraph : Boolean := False ) is -- we have a line sitting in Filling_Output_Line -- make sure all items are set, and then output it... -- then, clear for the next one... procedure review_underlining is -- work from posn 1 .. filling_output_line.character_count -- look at all positions in reverse order, and if any underlining -- appears under spaces or punctuation before (actually after) it -- appears under text, then turn it off... -- NOTE : underlining punctuation is only possible if und continuous -- is selected and the punctuation is not at its very end, or -- at the end of a line (last characters) we_have_underlined_text : boolean := false ; cc : extended_character ; it_is_text : boolean ; extended_exclam : constant extended_character := extended_character ( character'pos( '!' ) ) ; extended_period : constant extended_character := extended_character ( character'pos( '.' ) ) ; extended_comma : constant extended_character := extended_character ( character'pos( ',' ) ) ; extended_question : constant extended_character := extended_character ( character'pos( '?' ) ) ; begin -- review_underlining for posn in reverse 1 .. filling_output_line.character_count loop if filling_output_line.underline ( posn ) then -- we are working within an underlined area... if we_have_underlined_text then null ; -- it is ok, we already saw underlined text else -- here we either have a underline to turn off or else -- are just now moving into underlined text cc := filling_output_line.the_character ( posn ) ; -- it_is_text := -- ( ( cc >= extended_zero ) and ( cc <= extended_nine ) ) -- or else ( ( cc >= extended_UC_A ) and ( cc <= extended_UC_Z ) ) -- or else ( ( cc >= extended_lc_a ) and ( cc <= extended_lc_z ) ) ; it_is_text := not ( ( cc = extended_space ) or else ( cc = extended_period ) or else ( cc = extended_comma ) or else ( cc = extended_exclam ) or else ( cc = extended_question ) ) ; -- the above implementation just turns it off on trailing -- spaces, periods, exclamation points, and question marks if it_is_text then -- ok, good change to underlining... we_have_underlined_text := true ; else -- we want to modify this back filling_output_line.underline ( posn ) := false ; end if ; end if ; elsif we_have_underlined_text then -- just moved off of underlining ... we_have_underlined_text := false ; end if ; end loop ; end review_underlining ; begin -- tidy_up_and_output_filled_line -- work on it if justify is set... if Current_Formatting_Parameters.Justification_On and then last_line_in_paragraph then -- don't justify... filling_output_line.justify_to := filling_output_line.stop_position; end if ; -- now, if we did any special options, we must review line for correct -- underlining... if filling_output_line.special_options then review_underlining ; end if ; output_a_line ( filling_output_line ) ; filling_output_line.all := blank_output_line ; filling_trailing_spaces := 0 ; -- later we might want to try to set items selectively based upon -- old data values, etc. text_waiting_inside_filled_paragraph := false ; if last_line_in_paragraph then -- we must change the character changes back to the permanent -- settings, and with filling on, that happens when we hit the -- end of a paragraph current_formatting_parameters.current_character_changes := current_formatting_parameters.permanent_character_changes ; end if ; end tidy_up_and_output_filled_line ; Procedure Options ( Return_Input_Line_Contains_Text : out boolean ) is input_line_contains_text : boolean := false ; temp_num : integer ; successfull : boolean ; procedure do_set_page_number ( working_section_number : boolean := false ) is -- 1 Apr 85 -- // .cmd off // -- turns page number display off -- and sets prefix/suffix to blank -- // .cmd on // -- turns page number display on -- // .cmd default // -- sets all values to default values, disp. off -- // .cmd TB LRCA NUM PS -- // where TB is top/bottom or empty, meaning leave at -- the current setting -- // where LRCA is left/right/center/alternate or empty // -- // where NUM is n , +n , or -n for page number -- // where PS is the Prefix/Suffix string for the page -- number. enclosed in -- quotes, with a $ where -- the page number goes -- -- examples: .page top center 1 "Section 2-$" -- .page 1 "Section 3-$" -- .page bottom alternate -- -- minimum value is 0 for envelope feed -- maximum value is 32000 for page 32000 -- DEFAULTS: Top or Bottom => BOTTOM -- Left/Right/Ctr=> CENTER -- Start with => Page 1 -- Prefix/Suffix => None -- Show Page Num => Off orig_page_num : integer ; procedure pg_num ( modif : modifier_type ) is begin -- pg_num case modif is when top_modifier => Current_Document_Parameters .number_page_at_top := true ; when bottom_modifier => Current_Document_Parameters .number_page_at_top := false ; when left_modifier => Current_Document_Parameters .page_number_goes := left_side ; when right_modifier => Current_Document_Parameters .page_number_goes := right_side ; when center_modifier => Current_Document_Parameters .page_number_goes := center ; when alternating_modifier => Current_Document_Parameters .page_number_goes := alternating ; when others => null ; end case ; end pg_num ; begin -- do_set_page_number if ( modifier_one = on_modifier ) or ( modifier_one = off_modifier ) or ( modifier_one = default_modifier ) then if modifier_two /= no_modifier then command_error ( "Cannot have multiple parameters with" & " this first parameter." , true ) ; elsif numeric_contents /= no_numeric_contents then command_error ( "Cannot have numeric parameters with" & " this first parameter." , true ) ; elsif length( text_parameters ) /= 0 then command_error ( "Cannot have Text parameters with" & " this first parameter." , true ) ; else -- we are ok... case modifier_one is when on_modifier => current_document_parameters .page_numbering_on := true ; current_document_parameters .section_numbering_on := working_section_number; when off_modifier => current_document_parameters .page_numbering_on := false ; current_document_parameters .section_numbering_on:= false; set_length ( current_document_parameters .page_prefix_suffix , 0 ) ; when default_modifier => current_document_parameters .page_numbering_on := false ; current_document_parameters .current_page_number := 1 ; current_document_parameters .section_numbering_on:= false; current_document_parameters .current_section_num := 1 ; current_document_parameters .number_page_at_top :=false ; current_document_parameters .page_number_goes := center ; set_length ( current_document_parameters .page_prefix_suffix , 0 ) ; when others => null ; -- can't get here end case ; end if ; else -- first modifier is not on/off/default if ( modifier_two = on_modifier ) or ( modifier_two = off_modifier ) or ( modifier_two = default_modifier ) then command_error ( "Cannot have multiple parameters with" & " this second parameter." , true ) ; else -- we get here knowing that we do not have on/off/default allow_options ( false , o_any_numeric , o_top_bottom , o_l_r_c_alt , o_text_param ) ; -- we get here knowing that we do not have conflicting -- parameters orig_page_num := Current_Document_Parameters.Current_Page_Number ; Current_Document_Parameters.Page_Numbering_On := true ; Current_Document_Parameters.Section_Numbering_On := working_section_number ; -- First: work modifier_one pg_num ( modifier_one ) ; -- Then: work modifier_two pg_num ( modifier_two ) ; -- Then: work numeric if numeric_contents /= no_numeric_contents then If working_section_number then Current_Document_Parameters.Current_Section_Num := new_value ( Current_Document_Parameters.Current_Section_Num, 0 , 32000 , 1 ) ; else Current_Document_Parameters.Current_Page_Number := new_value ( Current_Document_Parameters.Current_Page_Number, 0 , 32000 , 1 ) ; end if ; end if ; -- Then: work Text parameters if length( text_parameters ) > 0 then -- we must check for the placement of the number if position ( '$' , text_parameters ) = 0 then command_error ( "Page number string must contain '$'." , true ) ; end if ; end if ; Current_Document_Parameters.Page_Prefix_Suffix := text_parameters ; -- Finally, check to see what effect this page number change will -- have on our printing request if Current_Environment.First_Page_to_Print > orig_page_num -- we haven't printed anything yet and ( Current_Document_Parameters.Current_Page_Number >= Current_Environment.First_Page_to_Print ) then -- and is at or past the first page to print Current_Environment.First_Page_to_Print := Current_Document_Parameters.Current_Page_Number ; -- then set the first page to print to -- be this page number.... end if ; end if ; end if ; reset_vertical_physical_page_limits ; end do_set_page_number ; Procedure Month_Out ( month_command : text_formatter_command ) is space : constant character := ' ' ; today : basic_io_system.timer ; nmonth : string(1..9) ; subtype str2 is string ( 1 .. 2 ) ; day_str , month_str , year_str : str2 ; Input_String : string ( 1 .. 30 ) ; Input_String_Length : integer ; pos_to_work : integer ; next_place : integer ; Procedure To_Two_Digit_String( number : in integer ; strg : out str2 ) is new_num : integer := number ; ch : character ; Procedure fix( num : in out integer ) is -- this routine takes a number and returns the number / 10 -- and a character which is the last digit in the number begin ch := character'val(48 + (num mod 10)) ; num := num / 10 ; end fix ; begin -- To_Two_Digit_String fix(new_num); strg(2) := ch ; fix(new_num); strg(1) := ch ; end To_Two_Digit_String ; Procedure move( s : in str2 ; c : in character ; place : in integer ) is begin Input_String(place ) := s(1) ; Input_String(place+1) := s(2) ; Input_String(place+2) := c ; end move ; begin -- Month_Out today := basic_io_system.clock ; case today.month is when 1 => nmonth := "January " ; when 2 => nmonth := "February " ; when 3 => nmonth := "March " ; when 4 => nmonth := "April " ; when 5 => nmonth := "May " ; when 6 => nmonth := "June " ; when 7 => nmonth := "July " ; when 8 => nmonth := "August " ; when 9 => nmonth := "September" ; when 10 => nmonth := "October " ; when 11 => nmonth := "November " ; when 12 => nmonth := "December " ; end case ; To_Two_Digit_String ( today.day , day_str ) ; To_Two_Digit_String ( today.month , month_str ) ; To_Two_Digit_String ( today.year , year_str ) ; for posn in 1 .. 30 loop Input_String(posn) := space ; end loop ; case month_command is when date_mdy_command => -- set up Input_String as month day, year for posn in 1 .. 9 loop Input_String(posn) := nmonth(posn) ; end loop ; pos_to_work := 9 ; while Input_String(pos_to_work) = ' ' loop pos_to_work := pos_to_work - 1 ; end loop ; if day_str(1) = '0' then day_str(1) := space ; pos_to_work := pos_to_work + 1 ; -- because it includes the space else pos_to_work := pos_to_work + 2 ; end if ; move(day_str , ',' , pos_to_work) ; Input_String(pos_to_work+4) := '1' ; Input_String(pos_to_work+5) := '9' ; move(year_str , ' ' , pos_to_work+6) ; Input_String_Length := pos_to_work + 7 ; when date_dmy_command => -- set up Input_String as dd mmm yy move(day_str , ' ' , 1) ; for posn in 1 .. 3 loop Input_String(posn+3) := nmonth(posn) ; end loop ; move(year_str , ' ' , 8) ; Input_String_Length := 9 ; when date_ymd_command => -- set up Input_String as yymmdd move(year_str , space , 1) ; move(month_str , space , 3) ; move(day_str, space , 5) ; Input_String_Length := 6 ; when date_slash_command | date_dash_command => -- set up Input_String as mm/dd/yy or mm-dd-yy if month_str(1) = '0' then Input_String(1) := month_str(2) ; next_place := 2 ; else move(month_str , space , 1) ; next_place := 3 ; end if; if month_command = date_slash_command then Input_String(next_place) := '/' ; else Input_String(next_place) := '-' ; end if ; pos_to_work := next_place ; next_place := next_place + 1 ; if day_str(1) = '0' then Input_String(next_place) := day_str(2) ; next_place := next_place + 1 ; else move(day_str , space , next_place) ; next_place := next_place + 2 ; end if ; Input_String(next_place) := Input_String(pos_to_work) ; -- get the last break character move(year_str , space , next_place+1) ; Input_String_Length := next_place + 3 ; when others => null ; -- can't get here end case ; -- now, we need to move it over..... force_into_input_stream ( string_to_pstring ( input_string ( 1 .. input_string_length ) ) , input_line_contains_text ) ; end Month_Out ; procedure do_write_command is begin -- do_write_command -- move text parameters out as a prompt clear_end_of_screen( master_window , 20 , 1 ) ; goto_line_column ( master_window , 20 , 1 ) ; put( text_parameters ) ; end do_write_command ; procedure do_read_command is f_string , s_string , d_string : pstring ; in_length : integer ; begin -- do_read_command set_length(s_string , 76) ; for i in 1 .. 76 loop s_string.data(i) := ' ' ; end loop ; f_string := s_string ; d_string := s_string ; s_string := string_read(f_string , d_string , 76 , 2 , 22 ) ; clear_end_of_screen (master_window , 20 , 1 ) ; s_string := compress ( s_string ) ; force_into_input_stream ( s_string , input_line_contains_text ) ; end do_read_command ; procedure work_character_command is -- we have a character to change a command option md : modifier_type := modifier_one ; procedure c ( item : a_char_type ) is cc : extended_character := extended_character( character'pos( text_parameters.data(1) ) ) ; begin -- c -- first, check to see that no other item uses this character... if cc = extended_space then cc := extended_nul ; -- just a rule, a space maps to a nul for this end if ; if cc /= extended_nul then -- must check it... if char_types ( cc ) = item then return ; -- we are setting to the same old value.... elsif char_types ( cc ) /= Illegal_Character and then char_types ( cc ) /= Text_Character then -- this character is already used. command_error ( "This Command Character is already used by another command." , true ) ; end if ; end if ; -- then, we need to un-map the old value that we used for this item if current_characters_array ( item ) /= extended_nul then char_types ( current_characters_array ( item ) ) := Text_Character ; end if ; -- Now, set the mapping from command to character current_characters_array ( item ) := cc ; -- Finally, set the mapping from character to command char_types ( cc ) := item ; end c ; begin -- work_character_command if length( text_parameters ) /= 1 then command_error ( "Single Character Parameter required." , true ) ; end if ; case command is when hypen_command => c ( Soft_Hyphen ) ; when dot_lead_command => c ( Dot_Leader ) ; when subscript_command => if md = on_modifier then c ( Subscript_Start ) ; elsif md = off_modifier then c ( Subscript_Stop ) ; else -- is toggle modifier c ( Subscript_Toggle ) ; end if ; when superscript_command => if md = on_modifier then c ( Superscript_Start ) ; elsif md = off_modifier then c ( Superscript_Stop ) ; else -- is toggle modifier c ( Superscript_Toggle ) ; end if ; when underline_foothead_command => if md = on_modifier then c ( UFoot_Start ) ; elsif md = off_modifier then c ( UFoot_Stop ) ; else -- is toggle modifier c ( UFoot_Toggle ) ; end if ; when underline_character_command => if md = on_modifier then c ( Underline_Start ) ; elsif md = off_modifier then c ( Underline_Stop ) ; else -- is toggle modifier c ( Underline_Toggle ) ; end if ; when ucontinuous_character_command => if md = on_modifier then c ( UCont_Start ) ; elsif md = off_modifier then c ( UCont_Stop ) ; else -- is toggle modifier c ( UCont_Toggle ) ; end if ; when bold_character_command => if md = on_modifier then c ( Bold_Start ) ; elsif md = off_modifier then c ( Bold_Stop ) ; else -- is toggle modifier c ( Bold_Toggle ) ; end if ; when shadow_character_command => if md = on_modifier then c ( Shadow_Start ) ; elsif md = off_modifier then c ( Shadow_Stop ) ; else -- is toggle modifier c ( Shadow_Toggle ) ; end if ; when temporary_font_character_command => if md = on_modifier then c ( Temp_Font_Start ) ; elsif md = off_modifier then c ( Temp_Font_Stop ) ; else -- is toggle modifier c ( Temp_Font_Toggle ) ; end if ; when forced_space_character_command => c ( Forced_Space ) ; when others => null ; -- cannot get here..... this routine is only -- called with one of the specified params end case ; end work_character_command ; procedure set_formatting( Opt: permanent_and_temporary_character_changes ; check_twice : boolean := true ) is begin -- set_formatting current_formatting_parameters.permanent_character_changes ( opt ) := ( modifier_one = on_modifier ) ; current_formatting_parameters.current_character_changes ( opt ) := ( modifier_one = on_modifier ) ; if check_twice and then modifier_one = off_modifier then -- we need to check for underline on and the wrong type of underlining -- turned off... if opt = underline then set_formatting ( underline_continuous , false ) ; elsif opt = underline_continuous then set_formatting ( underline , false ) ; end if ; end if ; end set_formatting ; Procedure check_file_name ( fname : in out pstring ; Input_File : boolean ; Delete_If_Exists: boolean ; Default_Ending : string ) is -- take in a file name and append the default ending if it -- does not contain the first character in the default ending. -- if it does contain that character, and that character is the -- last character in the name, then delete that last character begin -- check_file_name fname := compress ( fname ) ; if default_ending'length > 0 then if position ( default_ending(1) , fname ) = 0 then fname := fname & Default_Ending ; elsif position ( default_ending(1) , fname ) = length ( fname ) then set_length ( fname , length( fname ) - 1 ) ; end if ; end if ; if Input_File then -- input file if not file_exists ( fname ) then command_error ( "File does not exist." , true ) ; end if ; else -- output file if file_exists ( fname ) then if delete_if_exists then do_purge ( fname ) ; else command_error ( "File already exists." , true ) ; end if ; end if ; end if ; end check_file_name ; function to_ascii ( s : pstring ) return ascii_text_file_name is fname : ascii_text_file_name := no_file ; begin -- to_ascii for posn in 1 .. length(s) loop fname ( posn ) := s.data ( posn ) ; end loop ; return fname ; end to_ascii ; procedure do_insert_command is begin -- do_insert_command if where_to_read = alternate_input_file then command_error ( "An Include File may not call for another include file.", true ); end if ; allow_options ( exactly_one , o_text_param ) ; check_file_name( text_parameters , true , -- input file ? false , -- delete if output file? ".TXT" ) ; -- default ending -- we only get here if we are ok, otherwise command_error -- was called.... alt_in_file_name := to_ascii ( text_parameters ) ; open_for_read ( alternate_input_file , alt_in_file_name , successfull ) ; if not successfull then command_error ( "Cannot Open Include File." , true ) ; end if ; select_for_read( alternate_input_file ) ; If Initial_Environment.Show_Output_Status and then Initial_Environment.Where_To /= To_Screen then -- otsxy( 15 , 4 , "Included File Title" ) ; set_reverse(true); otsxy( 39 , 4 , ' ' & Alt_In_File_Name & ' ' ) ; set_reverse(false); goto_line_column( master_window , 1 , 1 ) ; end if ; end do_insert_command ; procedure do_indexfile_command is begin -- do_indexfile_command allow_options ( exactly_one , o_text_param ) ; check_file_name( text_parameters , false , -- input file ? true , -- delete if output file? ".IDX" ) ; -- default ending -- we only get here if we are ok, otherwise command_error -- was called.... if text_io.is_open(index_output_file) then text_io.close(index_output_file); end if ; index_file_name := to_ascii ( text_parameters ) ; open_for_write ( Index_Output_File , Index_File_Name , successfull ) ; if not successfull then command_error ( "Cannot Create Index File." , true ) ; end if ; Index_File_Is_Open := true ; If Initial_Environment.Show_Output_Status and then Initial_Environment.Where_To /= To_Screen then otsxy( 15 , 6 , "Index File Title " ) ; set_reverse(true); otsxy( 39 , 6 , ' ' & Index_File_Name & ' ' ) ; set_reverse(false); goto_line_column( master_window , 1 , 1 ) ; end if ; end do_indexfile_command ; procedure set_line_modification ( To_What : Line_Modification_Type ; Use_Command_Line : boolean ) is modf : modifier_type ; begin -- set_line_modification -- set line modification to center and use the current -- parsed command line... if use_command_line then allow_options ( exactly_one , o_on_off , o_abs_numeric) ; temp_num := new_value ( 0 , 0 , 32000 , 1 ) ; -- min is 0 ( meaning off ) .. max is 32000 lines finish_current_text ; modf := modifier_one ; else modf := off_modifier ; end if ; if modf = off_modifier then Current_Formatting_Parameters.Line_Modification := Nothing ; If Current_Formatting_Parameters.Modification_Status /= Off then Current_Formatting_Parameters.Filling_On := current_formatting_parameters.Fill_Before_Special ; Current_Formatting_Parameters.Justification_On := current_formatting_parameters.Just_Before_Special ; Current_Formatting_Parameters.Modification_Status := Off ; end if ; else Current_Formatting_Parameters.Line_Modification := To_What ; If Current_Formatting_Parameters.Modification_Status = Off then current_formatting_parameters.Fill_Before_Special := Current_Formatting_Parameters.Filling_On ; current_formatting_parameters.Just_Before_Special := Current_Formatting_Parameters.Justification_On ; Current_Formatting_Parameters.Filling_On := false ; Current_Formatting_Parameters.Justification_On := false ; end if ; if modf = on_modifier then Current_Formatting_Parameters.Modification_Status := Do_Forever ; else Current_Formatting_Parameters.Modification_Status := Do_While_Counting ; Current_Formatting_Parameters.Modify_To_Do := temp_num ; end if ; end if ; end set_line_modification ; procedure process_header_footer_lines ( Header_Footer : boolean ; A_Header : boolean ; Num_Lines : in out integer ; Height : in out vertical_measurement ; Ptr : in out Heading_Or_Footing_line_pointer ) is tmp_ptr : heading_or_footing_line_pointer ; z_ptr : heading_or_footing_line_pointer ; temporary_saved_formatting_parameters : formatting_parameters ; begin -- process_header_footer_lines -- we are processing those lines as specified by the .cmd n command allow_options ( false , o_abs_numeric , o_off ) ; -- also allows no option, defaulting to mean off temp_num := new_value ( 0 , 0 , 66 , 1 ) ; -- min is 0 .. max is 66 lines -- now, we must process the beginning of header/footers vs. foot notes if header_footer then clear_a_list ( ptr ) ; -- if null, does nothing num_lines := temp_num ; Height := 0 ; if num_lines = 0 then return ; else -- finally, set ptr .... Ptr := freelist_heading.get_from_free_list ; Tmp_Ptr := Ptr ; end if ; else if temp_num = 0 then return ; end if ; if num_lines = 0 then -- we must adjust it for the one inch line -- must set height to match the -- that puts in the heading line -- '-----------------' -- also the blank line following it Height := 2 * current_document_parameters.Page_Heading_Footing_VMI ; Ptr := freelist_heading.get_from_free_list ; Tmp_Ptr := Ptr ; else -- height is ok as it stands... -- otherwise, ptr is already ok, but we need to move to the end of -- the list.... Tmp_Ptr := Ptr ; loop z_ptr := next_line_ptr ( Tmp_Ptr ) ; -- that moved us to the next pointer in the list exit when z_ptr = null ; -- found end of list tmp_ptr := z_ptr ; end loop ; -- here with tmp_ptr as the last valid item in list set_next_ptr ( tmp_ptr ) ; tmp_ptr := next_line_ptr ( tmp_ptr ) ; end if ; num_lines := num_lines + temp_num ; end if ; -- set to no special formatting to take place... temporary_saved_formatting_parameters := current_formatting_parameters ; current_formatting_parameters := blank_formatting_parameters ; current_formatting_parameters.line_modification := to_left_margin ; current_formatting_parameters.Modification_Status := Do_Forever ; in_header_or_footer := true ; -- here, tmp_ptr is pointing to an item ready for data for Line_Num in 1 .. temp_num loop load_input_line(false) ; Input_Line_To_Output_Line ; set_line_data ( tmp_ptr , waiting_output_line.all ) ; if Line_Num /= temp_num then set_next_ptr ( tmp_ptr ) ; tmp_ptr := next_line_ptr ( tmp_ptr ) ; end if ; Height := Height + current_document_parameters.Page_Heading_Footing_VMI; end loop ; if header_footer then height := height + current_document_parameters.page_heading_footing_vmi; -- for the blank line following a header and the blank line preceding -- the footer... end if ; -- reset special formatting to the correct setting... current_formatting_parameters := temporary_saved_formatting_parameters ; in_header_or_footer := false ; end process_header_footer_lines ; procedure do_set_head_foot_space is new_val : integer ; begin -- do_set_head_foor_space -- minimum 1 point -- maximum is number of vertical points per inch allow_options ( exactly_one , o_abs_numeric ) ; new_val := new_value( 0, 1, printer_vertical_per_inch, 1 ) ; -- that call simply checks for within limits... -- first, we must modify each of the old heights temp_num := current_document_parameters.Footing_Height ; temp_num := temp_num / current_document_parameters.Page_Heading_Footing_VMI ; temp_num := temp_num * new_val ; current_document_parameters.Footing_Height := temp_num ; temp_num := current_document_parameters.FootNote_Height ; temp_num := temp_num / current_document_parameters.Page_Heading_Footing_VMI ; temp_num := temp_num * new_val ; current_document_parameters.FootNote_Height := temp_num ; temp_num := current_document_parameters.Heading_Height ; temp_num := temp_num / current_document_parameters.Page_Heading_Footing_VMI ; temp_num := temp_num * new_val ; current_document_parameters.Heading_Height := temp_num ; reset_vertical_physical_page_limits ; end do_set_head_foot_space ; Procedure Fix_Up_Line is -- we think that we have text in the input line first_pos : integer ; old_pos : integer ; begin -- fix_up_line -- compress Input_Line -- first right half... loop exit when input_line_length = 0 ; exit when input_line ( input_line_length ) /= extended_space ; input_line_length := input_line_length - 1 ; end loop ; first_pos := 1 ; loop exit when first_pos > input_line_length ; exit when input_line ( first_pos ) /= extended_space ; first_pos := first_pos + 1 ; end loop ; if input_line_length < first_pos then input_line_contains_text := false ; else -- we have text to work -- first, move it over... if first_pos > 1 then for posn in first_pos .. input_line_length loop input_line ( posn - first_pos + 1 ) := Input_Line ( posn ) ; end loop ; input_line_length := Input_Line_Length - first_pos + 1 ; end if ; text_parameters := compress ( text_parameters ) ; if length ( Text_Parameters) > 0 then -- we have to concat the current line and the text parameter if input_line_length > 3 then -- check for 's if map_up ( Input_Line(input_line_length) ) = extended_uc_s then if map_up ( Text_Parameters.data(2) ) = 'S' then if Text_Parameters.data(1) = ''' or else Text_Parameters.data(1) = '`' then for posn in 1 .. length ( Text_Parameters ) - 1 loop Text_Parameters.data(posn) := Text_Parameters.data(posn+1) ; end loop ; set_length ( Text_Parameters , Length(Text_Parameters) - 1 ); end if ; end if ; end if ; end if ; old_pos := 1 ; loop exit when old_pos > length ( text_parameters ) ; exit when input_line_length = max_line_length ; input_line_length := input_line_length + 1 ; Input_Line ( Input_line_length ) := extended_character ( character'pos ( text_parameters.data ( old_pos ) ) ) ; old_pos := old_pos + 1 ; end loop ; end if ; -- xlate(option) ; -- translate if option, else just delete the ^ end if ; -- no text parameter anyway... end fix_up_line ; begin -- options return_input_line_contains_text := false ; Parse_Input_Command_Line ; Input_Line_Contains_Text := false ; case command is when paper_width_command => -- 29 Mar 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd default // -- n measured in 1/10" -- minimum value is 10 for 1 inch -- maximum value is 140 for 14 inches -- default value is 85 for 8.5 inches finish_current_text ; allow_options ( exactly_one , o_any_numeric ) ; temp_num := new_value ( current_physical_parameters .paper_width , 10 , 140 , printer_points_per_inch / 10 ) ; current_physical_parameters.paper_width := temp_num ; reset_horizontal_physical_page_limits ; when paper_length_command => -- 29 Mar 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd default // -- n measured in 1/6" -- minimum value is 0 for no setting -- maximum value is 84 for 14 inches -- default value is 66 for 11 inches finish_current_text ; allow_options ( exactly_one , o_any_numeric ) ; temp_num := new_value ( current_physical_parameters .paper_length , 0 , 84 , printer_vertical_per_inch / 6 ) ; current_physical_parameters.paper_length := temp_num ; execute_printer_command( set_form_length , temp_num ) ; reset_vertical_physical_page_limits ; when left_margin_command => -- 29 Mar 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in 1/10" -- minimum value is 0 for no left margin -- maximum value is 140 for 14 inches -- default value is 10 for 1 inch finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_physical_parameters .left_margin , 0 , 140 , printer_points_per_inch / 10 ) ; current_physical_parameters.left_margin := temp_num ; current_physical_parameters.real_left := temp_num ; reset_horizontal_physical_page_limits ; when right_margin_command => -- 29 Mar 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in 1/10" -- minimum value is 0 for no right margin -- maximum value is 140 for 14 inches -- default value is 10 for 1 inch finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_physical_parameters .right_margin, 0 , 140 , printer_points_per_inch / 10 ) ; current_physical_parameters.right_margin:= temp_num ; current_physical_parameters.real_right := temp_num ; reset_horizontal_physical_page_limits ; when top_margin_command => -- 29 Mar 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in 1/6" -- minimum value is 0 for no top margin -- maximum value is 84 for 14 inches -- default value is 6 for 1 inch finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_physical_parameters .top_margin , 0 , 84 , printer_vertical_per_inch / 6 ) ; current_physical_parameters.top_margin:= temp_num ; reset_vertical_physical_page_limits ; when bottom_margin_command => -- 1 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in 1/6" -- minimum value is 0 for no bottom margin -- maximum value is 84 for 14 inches -- default value is 6 for 1 inch finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_physical_parameters .bottom_margin , 0 , 84 , printer_vertical_per_inch / 6 ) ; current_physical_parameters.bottom_margin:= temp_num ; reset_vertical_physical_page_limits ; when binding_command => -- 1 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in 1/10" -- minimum value is 0 for no binding edge -- maximum value is 140 for 14 inches -- default value is 0 for off finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_physical_parameters .binding_edge , 0 , 140 , printer_points_per_inch / 10 ) ; current_physical_parameters.binding_edge:= temp_num ; reset_horizontal_physical_page_limits ; when subpara_command => -- 1 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in the current font pitch -- minimum value is - 140 for negative 140 characters -- maximum value is 140 for 140 characters -- default value is 0 for off -- finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_formatting_parameters .left_indentation , -140 , 140 , font_width ) ; current_formatting_parameters.left_indentation:=temp_num ; horizontal_control_values_changed ; when go_left_command => -- 1 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in the current font pitch -- minimum value is - 140 for negative 140 characters -- maximum value is 140 for 140 characters -- default value is 0 for off -- finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_formatting_parameters .right_indentation , -140 , 140 , font_width ) ; current_formatting_parameters.right_indentation:=temp_num ; horizontal_control_values_changed ; when indent_command => -- 1 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in the current font pitch -- minimum value is - 140 for negative 140 characters -- maximum value is 140 for 140 characters -- default value is 0 for off -- Indent sets first line indentation, following = 0 finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_formatting_parameters .Paragraph_Indent , -140 , 140 , font_width ) ; current_formatting_parameters.paragraph_indent :=temp_num ; current_formatting_parameters.subsequent_line_ind:= 0 ; horizontal_control_values_changed ; when indent_neg_command => -- 1 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in the current font pitch -- minimum value is - 140 for negative 140 characters -- maximum value is 140 for 140 characters -- default value is 0 for off -- Neg Indent sets - first line indentation, following = 0 finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := - new_value ( - current_formatting_parameters .Paragraph_Indent , -140 , 140 , font_width ) ; current_formatting_parameters.paragraph_indent :=temp_num ; current_formatting_parameters.subsequent_line_ind:= 0 ; horizontal_control_values_changed ; when para_indent_command => -- 1 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- // .cmd default // -- n measured in the current font pitch -- minimum value is - 140 for negative 140 characters -- maximum value is 140 for 140 characters -- default value is 0 for off -- Para Indent sets following indentation, first = 0 finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_formatting_parameters .subsequent_line_ind , -140 , 140 , font_width ) ; current_formatting_parameters.paragraph_indent := 0 ; current_formatting_parameters.subsequent_line_ind:=temp_num ; horizontal_control_values_changed ; when page_numbering_command => -- 1 Apr 85 -- // .cmd off // page number off prefix/suffix blank -- // .cmd on // page number display on -- // .cmd default //sets values to default values, disp. off -- // .cmd TB LRCA NUM PS -- DEFAULTS: Top or Bottom => BOTTOM -- Left/Right/Ctr=> CENTER -- Start with => Page 1 -- Prefix/Suffix => None -- Show Page Num => Off do_set_page_number ; when section_page_numbering_command => -- 1 Apr 85 -- // just like page numbers... do_set_page_number ( true ) ; when date_dmy_command | date_mdy_command | date_slash_command | date_dash_command | date_ymd_command => -- 2 Apr 85 -- // .cmd // -- // .cmd "text" // allow_options ( false , o_text_param ) ; month_out( command ) ; when underscore_command => -- draw a horizontal line -- 3 Apr 85 -- // .cmd n // -- // .cmd n "text" // -- n measured in characters allow_options ( false , o_abs_numeric , o_text_param ) ; temp_num := new_value ( 0 , 1 , 255 , 1 ) ; -- minimum is 1 , maximum is 255 Input_Line_Length := temp_num ; for posn in 1 .. temp_num loop Input_Line ( posn ) := extended_character ( character'pos ( '_' ) ) ; end loop ; Input_Line_Contains_Text := true ; when write_command => -- 2 Apr 85 -- // .cmd prompt // -- moves prompt out to the screen as a prompt for read cmd allow_options ( exactly_one , o_text_param ) ; do_write_command ; when read_command => -- 2 Apr 85 -- // .cmd // -- // .cmd text // -- if "text" is there, it appends it to the read info. allow_options ( false , o_text_param ) ; do_read_command ; when new_para_command => -- 2 Apr 85 -- // .cmd // allow_options ( false ) ; finish_current_text ; -- finishes the paragraph -- and then prepares for a new paragraph when add_command => -- 2 Apr 85 -- // .cmd n // -- n measured in lines allow_options ( false , -- used to be exactly_one , -- but was changed because jennifer uses -- .add <cr> to mean .newp.... o_abs_numeric ) ; temp_num := new_value ( 0 , 0 , 66 , 1 ) ; -- min is 0 .. max is 66 lines finish_current_text ( move_forward_on_page , temp_num ) ; -- finishes the paragraph -- and then prepares for a new paragraph -- also, moves the after line count to the before line when backward_add_command => -- 2 Apr 85 -- // .cmd n // -- n measured in lines allow_options ( exactly_one , o_abs_numeric ) ; temp_num := new_value ( 0 , 0 , 66 , 1 ) ; -- min is 0 .. max is 66 lines finish_current_text ( move_backward_on_page, temp_num ) ; -- finishes the paragraph -- and then prepares for a new paragraph -- also, moves the after line count to the before line when tabs_vertical_command => -- 2 Apr 85 -- // .cmd n // -- n measured in lines allow_options ( exactly_one , o_abs_numeric ) ; temp_num := new_value ( 0 , 1 , 66 , 1 ) ; -- min is 1 .. max is 66 lines finish_current_text ( move_to_absolute_position , temp_num ) ; -- finishes current text and then does an absolute move when same_line_command => -- 2 Apr 85 -- // .cmd // allow_options ( false ) ; if Current_Formatting_Parameters.Filling_On then -- output and then stay on this line finish_current_text ( stay_on_this_line ) ; -- finishes current text and then stays here... else -- filling off, set for staying here before next line kind_of_move_before_line := stay_on_this_line ; amount_waiting_to_move_vertically_before_line := 0 ; end if ; when tabs_command => -- 2 Apr 85 -- // .cmd n // .cmd +n // -- n measured in the current font pitch -- if +n, the n is measured from left margin + sub para -- minimum value is 0 for left edge of page -- maximum value is 255 for 255th char position allow_options ( exactly_one , o_any_numeric ) ; temp_num := new_value ( current_physical_parameters .left_margin + current_formatting_parameters .Left_Indentation , 0 , 255 , font_width ) ; if Current_Formatting_Parameters.Filling_On then -- output and then stay on this line finish_current_text ( stay_on_this_line ) ; -- finishes current text and then stays here... just_did_tab_command := true ; tab_requested_to_position := temp_num ; else null ; -- has no meaning if filling is off... end if ; when comments_command => -- 2 Apr 85 -- // .cmd on // -- turns comment area on -- // .cmd off // -- turns comment area off -- -- however, note that the comment off -- -- to on is really handled elsewhere allow_options ( exactly_one , o_on_off ) ; processing_comment_area := ( modifier_one = on_modifier ) ; when else_command => -- 2 Apr 85 -- // .cmd // -- if comment on, turns off. -- -- if comment off, turns on. -- -- however, note that the comment on -- -- to off is really handled elsewhere allow_options ( false ) ; processing_comment_area := not processing_comment_area ; when finish_command => -- 2 Apr 85 -- // .cmd // -- if comment on, turns off. -- -- however, note that the comment on -- -- to off is really handled elsewhere allow_options ( false ) ; processing_comment_area := false ; when switch_command => -- 2 Apr 85 -- // .cmd n on // -- // .cmd n off // -- // .cmd n toggle // -- minimum value is 1 for first switch -- maximum value is 20 for last switch allow_options ( false , o_on_off , o_toggle , o_abs_numeric); temp_num := new_value ( 0 , 1 , max_switches , 1 ) ; if modifier_two /= no_modifier then -- they had two modifiers, and that is not allowed command_error ( "Invalid Switch Parameters." , true ) ; end if ; if modifier_one = toggle_modifier then switches ( temp_num ) := not switches ( temp_num ) ; else switches( temp_num ) := ( modifier_one = on_modifier ) ; end if ; when ifswitch_command => -- 2 Apr 85 -- // .cmd n on // -- // .cmd n off // -- minimum value is 1 for first switch -- maximum value is 20 for last switch allow_options ( false , o_on_off , o_abs_numeric); temp_num := new_value ( 0 , 1 , max_switches , 1 ) ; if modifier_two /= no_modifier then -- they had two modifiers, and that is not allowed command_error ( "Invalid Switch Parameters." , true ) ; end if ; processing_comment_area := switches( temp_num ) /= ( modifier_one = on_modifier ) ; -- comment area if switch on and looking for off -- or off and looking for on when if_command => -- 4 Apr 85 -- // .cmd n = n // -- processing_comment_area := If_Function ; null ; when bold_command => -- 2 Apr 85 -- // .cmd on // -- // .cmd off // allow_options ( exactly_one , o_on_off ) ; set_formatting ( bold ) ; when shadow_printing_command => -- 2 Apr 85 -- // .cmd on // -- // .cmd off // allow_options ( exactly_one , o_on_off ) ; set_formatting ( shadow ) ; when underline_chars_command => -- 2 Apr 85 -- // .cmd on // -- // .cmd off // allow_options ( exactly_one , o_on_off ) ; set_formatting ( underline ) ; when underline_cont_command => -- 2 Apr 85 -- // .cmd on // -- // .cmd off // allow_options ( exactly_one , o_on_off ) ; set_formatting ( underline_continuous ) ; when fancy_print_command => -- 2 Apr 85 -- // .cmd on // -- // .cmd off // allow_options ( exactly_one , o_on_off ) ; set_formatting ( bold ) ; set_formatting ( shadow ) ; set_formatting ( underline_continuous ) ; when center_command => -- 2 Apr 85 -- // .cmd on // -- turns centering on forever -- // .cmd off // -- turns centering off -- // .cmd n // -- center the next n lines -- Note that the on and n parts of the -- command cause the program to remember -- the settings of the filling and just -- commands. Then, when the n is up or -- the off is given, those two items are -- reset to their previous settings -- note that calling fill or justify on turns off center -- also right justify turns this off... set_line_modification ( Line_Modification_Type'( Center_Mod), True ) ; -- set line modification to center and use the current -- parsed command line... when justify_rtmargin_command => -- 2 Apr 85 -- // .cmd on // -- turns right justification on forever -- // .cmd off // -- turns right justification off -- // .cmd n // -- center the next n lines -- Note that the on and n parts of the -- command cause the program to remember -- the settings of the filling and just -- commands. Then, when the n is up or -- the off is given, those two items are -- reset to their previous settings -- note that calling fill or justify on turns off rjust -- so does center.. set_line_modification ( Right_Justify , True ) ; -- set line modification to right_justify and use the current -- parsed command line... when hypen_command | dot_lead_command | forced_space_character_command => -- 2 Apr 85 -- // .cmd "c" // -- "c" signals special function allow_options ( exactly_one , o_text_param) ; work_character_command ; when subscript_command | superscript_command | underline_foothead_command | underline_character_command | ucontinuous_character_command | bold_character_command | shadow_character_command | temporary_font_character_command => -- 2 Apr 85 -- // .cmd on "c" // -- "c" turns special function on -- // .cmd off "c" // -- "c" turns special function off -- // .cmd toggle "c" // -- "c" changes the setting allow_options ( false , o_on_off , o_toggle , o_text_param) ; if length( text_parameters ) = 0 then command_error ( "You must provide a character for this command." , true ); elsif modifier_two /= no_modifier then command_error ( "Too many command parameters." , true ) ; else work_character_command ; end if ; when insert_command => -- 2 Apr 85 -- // .cmd filename // -- Include the file named here as though it was typed in -- .... note that an include file cannot try to include -- another file... do_insert_command ; when indexfile_command => -- 2 Apr 85 -- // .cmd filename // -- Open the file named here as the index output file. do_indexfile_command ; when index_command => -- 2 Apr 85 -- // .cmd indexinfo // allow_options ( exactly_one , o_text_param ) ; If index_file_is_open then -- put it away text_parameters:= text_parameters & " \" & page_to_pstring ; -- that put a second space at the end... -- and then the dot leader character & then page number text_io.put ( index_output_file , ".idx " ) ; text_io.put_line ( index_output_file , text_parameters.data ( 1 .. length(text_parameters) ) ) ; -- else do nothing...we allow the user to put in index -- entries for later without specifying a file for them -- now end if ; when footers_command => -- 3 Apr 85 -- // .cmd n // -- n lines of footers -- n is from 1 .. 66 process_header_footer_lines ( true , -- this is a head/foot false , -- but not a header current_document_parameters.Footing_Lines , current_document_parameters.Footing_Height , current_document_parameters.Footing_Pointer ) ; reset_vertical_physical_page_limits ; when footnote_command => -- 3 Apr 85 -- // .cmd n // -- n lines of footnotes -- n is from 1 .. 66 process_header_footer_lines ( false , -- not a head/foot false , -- not a header current_document_parameters.FootNote_Lines , current_document_parameters.FootNote_Height , current_document_parameters.FootNote_Pointer ) ; reset_vertical_physical_page_limits ; when headers_command => -- 3 Apr 85 -- // .cmd n // -- n lines of headers -- n is from 1 .. 66 process_header_footer_lines ( true , -- this is a head/foot true , -- and is a header current_document_parameters.Heading_Lines , current_document_parameters.Heading_Height , current_document_parameters.Heading_Pointer ) ; reset_vertical_physical_page_limits ; when head_foot_space_command => -- 3 Apr 85 -- // .cmd n // -- n is points to allocate to each header -- -- footer and footnote line. -- -- point height is different for different -- -- printers. -- minimum 1 point -- maximum is number of vertical points per inch do_set_head_foot_space ; when forward_printing_command => -- 3 Apr 85 -- // .cmd on // -- this can force a unidirectional printer allow_options ( exactly_one , o_on_off ) ; if modifier_one = off_modifier then -- error not caught by allow_options command_error ( "Off Parameters not allowed with this command." , true ); else z_forward := true ; end if ; when justify_numbers_command => -- 3 Apr 85 -- // .cmd on // -- turns dot justification on -- // .cmd off// -- turns dot justification off allow_options ( exactly_one , o_on_off ) ; current_formatting_parameters. Delay_Justification_Till_After_Dots := modifier_one = on_modifier ; when pause_command => -- 3 Apr 85 -- // .cmd // -- pause while printing... allow_options ( false ) ; finish_current_text ; if User_Pause ( "Pause!" , true ) then raise users_requested_abort ; end if ; when variable_data_command => -- 3 Apr 85 -- // .cmd n // -- take and insert the specified variable -- // .cmd n "text" // -- field. append "text" if requested -- minimum n is 1 -- maximum n is 20 allow_options ( false , o_abs_numeric , o_text_param ) ; temp_num := new_value( 0, 1, max_user_variables , 1 ) ; force_into_input_stream ( user_variable_data ( temp_num ) , input_line_contains_text ) ; when user_defined_command => -- 3 Apr 85 -- // .cmd // -- take and insert the specified variable -- // .cmd "text" // -- field. append "text" if requested -- the n is set by the user_command_number... allow_options ( false , o_text_param ) ; if user_command_number > 0 and then user_command_number <= max_user_variables then force_into_input_stream( user_variable_data ( user_command_number ) , input_line_contains_text ) ; end if ; when prop_spacing_command => -- 3 Apr 85 -- // .cmd n // -- load that print font -- minimum n is 1 -- maximum n is 50 allow_options ( false , o_abs_numeric ) ; temp_num := new_value( 0, 1, 50 , 1 ) ; if not select_font ( temp_num ) then command_error ("Invalid Font Number." , true ) ; else -- since this is to change permanent font, then we will -- change the font width permanent_font := current_font ; font_width := current_font.font_width ; end if ; when rclm_command => -- Right Column Left Margin -- 3 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- n measured in 1/10" -- minimum value is 0 for no right margin -- maximum value is 140 for 14 inches -- default value is 0 for off -- -- note that this command just sets up a value in case -- lcrm is called. If it is never called, nothing -- will happen... -- allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_physical_parameters .real_center_left , 0 , 140 , printer_points_per_inch / 10 ) ; current_physical_parameters.real_center_left := temp_num ; when lcrm_command => -- Left Column Right Margin -- 3 Apr 85 -- // .cmd n // .cmd +n // .cmd -n // -- // .cmd off // -- n measured in 1/10" -- minimum value is 0 for no left margin -- maximum value is 140 for 14 inches -- default value is 0 for off finish_current_text ; allow_options ( exactly_one , o_any_numeric , o_off ) ; temp_num := new_value ( current_physical_parameters .real_center_right , 0 , 140 , printer_points_per_inch / 10 ) ; current_physical_parameters.real_center_right := temp_num ; current_physical_parameters.right_margin := temp_num ; reset_horizontal_physical_page_limits ; when char_spacing_command | char_width_command => -- 4 Apr 85 -- // .cmd n // -- char width command is said in printer points -- char spacing command is characters per inch -- for char width , minimum width is 1 point -- maximum width is 1" worth of points -- for char spacing, minimum cpi is 1 cpi -- maximum cpi is number of points in inch -- depending upon printer, between 120 and 300 cpi finish_current_text ; allow_options ( exactly_one , o_abs_numeric ) ; temp_num := new_value ( 0 , 1 , printer_points_per_inch, 1 ); if command = char_spacing_command then -- must reverse temp_num := printer_points_per_inch / temp_num ; end if ; set_fixed_font ( temp_num ) ; reset_horizontal_physical_page_limits ; when mult_line_spacing_command | vert_line_spacing_command => -- 4 Apr 85 -- // .cmd n // -- vert line spacing cmd is said in printer vertical points -- mult line spacing command is 1/6" increments -- minimum is 1 point for vert, 1/6" for mult -- maximum is 1" worth of points for vert , 12 for mult finish_current_text ; allow_options ( exactly_one , o_abs_numeric ) ; if command = mult_line_spacing_command then temp_num := new_value ( 0 , 1 , 12 , 1 ) * printer_vertical_per_inch / 6 ; else temp_num:= new_value ( 0 , 1 , printer_vertical_per_inch,1); end if ; -- get here with absolute points set... execute_printer_command( set_vmi , temp_num ) ; reset_vertical_physical_page_limits ; when fill_command => -- 4 Apr 85 -- // .cmd on // -- turns filling on -- // .cmd off // -- turns filling off -- note that this turns off right justify and center allow_options ( exactly_one , o_on_off ) ; set_line_modification ( Nothing , False ) ; -- turn off center/right justify finish_current_text ; Current_Formatting_Parameters.Filling_On := modifier_one = on_modifier ; when justify_margins_command => -- 4 Apr 85 -- // .cmd on // -- turns justify on -- // .cmd off // -- turns justify off -- note that this turns off right justify and center allow_options ( exactly_one , o_on_off ) ; set_line_modification ( Nothing , False ) ; -- turn off center/right justify finish_current_text ; Current_Formatting_Parameters.Justification_On := modifier_one = on_modifier ; when end_page_command => -- 4 Apr 85 -- // .cmd // allow_options ( false ) ; finish_current_text ; end_a_page ; reset_vertical_physical_page_limits ; kind_of_move_before_line := move_forward_on_page ; amount_waiting_to_move_vertically_before_line := 0 ; kind_of_move_after_line := move_forward_on_page ; amount_waiting_to_move_vertically_after_line := 0 ; when envelope_feed_command => -- NOT IMPLEMENTED -- 4 Apr 85 -- // .cmd // allow_options ( false ) ; finish_current_text ; -- pagemin := 0 ; --allow the envelope -- pagenum := 0 ; when line_save_command => -- 26 Jul 85 -- // .cmd n // -- save n lines at end of page... finish_current_text ; allow_options ( exactly_one , o_abs_numeric ) ; temp_num := new_value ( 0 , 1 , 66 , 1 ) ; if printer_vertical_position + amount_waiting_to_move_vertically_before_line + current_vertical_motion_index * temp_num > Vertical_Page_Limit then -- new page... end_a_page ; -- and skip any vertical requested area... reset_vertical_physical_page_limits ; start_a_page ; end if ; when printer_control_command => -- 4 Apr 85 -- // .cmd // -- turns on for dumb printer ... -- Note that the user has to take care of font himself... if current_environment.ot_format = ot_fancy then printer_accessories := none ; change_printer( z_pdumb ) ; permanent_printer := z_printer ; current_environment.ot_format := ot_plain ; file_out ( ascii.cr ) ; end if ; when ribbon_color_command => -- 4 Apr 85 -- // .cmd on // -- turns red ribbon on -- // .cmd off // -- turns red ribbon off if modifier_one = on_modifier then execute_printer_command( set_red_ribbon ) ; else execute_printer_command( set_black_ribbon ) ; end if ; when illegal_command => command_error ( "Unrecognized Formatter Command." , false ); end case ; Commands_Were_Processed_Just_Now := True ; if input_line_contains_text then fix_up_line ; end if ; return_input_line_contains_text := input_line_contains_text ; exception when bad_user_command => return_input_line_contains_text := false ; -- and return without processing command line end options ; procedure initialize_printer_commands_for_a_new_document is begin -- initialize_printer_commands_for_a_new_document Filling_output_line.all := blank_output_line ; Filling_Trailing_Spaces := 0 ; reset_vertical_physical_page_limits ; reset_horizontal_physical_page_limits ; horizontal_control_values_changed ; end initialize_printer_commands_for_a_new_document ; procedure finish_printer_commands_for_an_old_document is begin -- finish_printer_commands_for_an_old_document null ; end finish_printer_commands_for_an_old_document ; procedure close_printer_commands is begin -- close_printer_commands null ; end close_printer_commands ; begin -- printer_commands Filling_output_line := new output_line_type ; initialize_printer_commands_globally ; end printer_commands ; --$$$- PRNTCMD --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntwork --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTWORK -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Energy Systems Group -- Ada Software Development Project Team -- 2280 U.S. Highway 19 North, Suite 120 -- Clearwater, Florida 33575 -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with text_io ; with string_library ; use string_library ; with crt_windows ; use crt_windows ; with Wordp_Globals ; use Wordp_Globals ; with printer_globals ; use printer_globals ; with name_tree ; use name_tree ; with printf ; use printf ; with print_in_to_out ; use print_in_to_out ; with print_out ; use print_out ; with printer_misc ; use printer_misc ; with printer_commands; use printer_commands; Package PRINT_WORK is work_fatal_error_abort : exception ; procedure initialize_variable_data_file ; procedure initialize_for_new_data ( ok : out boolean ) ; procedure print_a_single_document ; procedure end_output ( printout_aborted_by_user_intervention : boolean ) ; procedure end_an_entire_document ; procedure close_print_work ; end print_work ; package body print_work is filling_trailing_spaces_are_underlined : boolean ; dot_set : array ( extended_character ) of boolean ; first_line_of_filled_paragraph : boolean ; erased_it : boolean := false ; last_line : integer := 0 ; procedure deb ( s : string ; info : integer := 0 ) is begin -- deb if ( s = "PAUSE" ) or ( s = "pause" ) then -- we must pause ... if User_Pause ( "Pause!" , true ) then raise users_requested_abort ; end if ; erased_it := true ; clear_window( master_window ) ; clear_prompt( master_window ) ; last_line := 1 ; else if not erased_it then erased_it := true ; clear_window( master_window ) ; clear_prompt( master_window ) ; last_line := 1 ; elsif ( last_line = 20 ) then -- we must pause ... if User_Pause ( "Pause!" , true ) then raise users_requested_abort ; end if ; erased_it := false ; end if ; -- here ready to go to work last_line := last_line + 1 ; goto_line_column ( master_window , last_line , 2 ) ; put ( s ) ; if s'length < 30 then for posn in s'length + 1 .. 30 loop put ( ' ' ) ; end loop ; end if ; put ( " " ) ; put ( info , 5 ) ; end if ; end deb ; procedure global_initialize_print_work is function e ( c : character ) return extended_character is begin -- e return extended_character ( character'pos( c ) ) ; end e ; begin -- global_initialize_print_work for e_c in extended_character'first .. extended_character'last loop dot_set ( e_c ) := false ; end loop ; dot_set ( e ( '.' ) ) := true ; dot_set ( e ( ':' ) ) := true ; dot_set ( e ( '-' ) ) := true ; dot_set ( e ( ')' ) ) := true ; dot_set ( e ( 'o' ) ) := true ; dot_set ( e ( 'O' ) ) := true ; end global_initialize_print_work ; procedure initialize_variable_data_file is begin -- initialize_variable_data_file -- first, make the variable command a valid command.... insert_name ( "variable_data_insertion" , variable_data_command , 000 , command_tree ) ; -- then, open the file.... -- it is already opened by the goodname routine... -- ok then, we are ready for work..... end ; procedure initialize_for_new_data ( ok : out boolean ) is -- read in the next record's data.... -- separated by .NEW -- ended with .END -- cannot read in lines starting with '?' new_command : string ( 1 .. 3 ) ; old_read : input_file_type := where_to_read ; var_numb : integer ; new_data : pstring ; eof : boolean ; procedure map_up ( s : in out string ) is begin -- map_up for posn in 1 .. s'length loop s(posn) := map_up ( s(posn) ) ; end loop ; end map_up ; begin -- clear old data for ln in 1 .. max_user_variables loop set_length ( user_variable_data ( ln ) , 0 ) ; end loop ; -- select correct input file select_for_read ( variable_input_file ) ; var_numb := 0 ; loop read_next_line ( new_data , eof ) ; exit when eof or else var_numb = max_user_variables ; -- meaning if they have max_var lines of data, we read in that many -- lines and then throw away the following line no matter what.. if length ( new_data ) > 0 then if new_data.data(1) = '?' then -- this throws away environment lines... null ; -- nothing to do... else if new_data.data(1) = '.' and then length ( new_data ) >= 4 then new_command := new_data.data( 1 .. 3 ) ; map_up ( new_command ) ; else new_command := " " ; end if ; exit when new_command = "NEW" or else new_command = "END" ; -- get here with real data... -- since the variable info is a standard pstring and -- the new_data is a standard pstring, we don't have to -- check any constraints before moving over... var_numb := var_numb + 1 ; user_variable_data ( var_numb ) := new_data ; end if ; else var_numb := var_numb + 1 ; -- blank line is already set end if ; end loop ; ok := ( var_numb > 0 ) ; -- meaning we had at least one line of data -- set things back to how they used to be... select_for_read ( old_read ) ; end initialize_for_new_data ; procedure print_a_single_document is Input_Line_Contains_Text : boolean ; procedure initialize_print_work_for_a_new_document is successfull : boolean ; procedure do_font ( new_font_number : font_number ) is -- prepare the program and the output device for the selected font begin -- do_font execute_printer_command( set_font_number , new_font_number ) ; if select_font( new_font_number ) then -- ready to work it permanent_font := current_font ; temporary_font := current_font ; font_width := current_font.font_width ; -- following set in select font... -- space_width := current_font.width ( extended_space ) ; -- half_space_width := space_width / 2 ; else error( " Requested Font # " & int_to_str( new_font_number ) & " is not available." , not_fatal_error , operator_wait , short_beep ) ; raise work_fatal_error_abort ; end if ; end do_font ; begin -- initialize_print_work_for_a_new_document -- execute_printer_command( printer_reset ); -- Get printer ready for OT -- Fonts -- Fonts -- Fonts -- Fonts -- Fonts -- Fonts -- Fonts -- Default_Font is set by printer_globals_initialize if current_environment.where_to = to_screen or else current_environment.ot_format = ot_plain then -- First, PrntGlob public items printer_accessories := none ; change_printer( z_pdumb ) ; permanent_printer := z_printer ; -- no fancy font work... do_font ( 1 ) ; elsif current_environment.font_to_use = 0 then -- First, PrntGlob public items printer_accessories := current_environment.printer_accessories ; change_printer( current_environment.printer_brand ) ; permanent_printer := z_printer ; -- they asked for the default font. And we have a different -- default depending upon the printer... case current_environment.printer_brand is when z_hp_laser_printer => do_font( 12 ) ; when z_cent737 => do_font( 6 ) ; when others => do_font( 1 ) ; end case ; else -- First, PrntGlob public items printer_accessories := current_environment.printer_accessories ; change_printer( current_environment.printer_brand ) ; permanent_printer := z_printer ; -- they specified a font.... and it is their responsibility to -- make sure that that font is legal on their printer... do_font ( current_environment.font_to_use ) ; end if ; -- Fonts -- Fonts -- Fonts -- Fonts -- Fonts -- Fonts -- Fonts -- Physical_Page_Number := 1 ; -- in PrntGlob -- Physical_Input_Lines := 0 ; -- in PrntGlob -- Physical_Output_Lines := 0 ; -- in PrntGlob -- Now, make sure that we are prepared to correctly read the main -- input file. select_for_read( main_input_file ) ; -- open_for_read ( main_input_file , main_in_file_name , successfull ) ; -- above open for read done inside prntmain.. -- ready to continue... -- Now, items which are defined in PrntOut... -- Horizontal Information Current_Physical_Parameters.Paper_Width := ( Current_Font.Horizontal_Points_Per_Inch / 2 ) * 17 ; -- 8.5" Current_Physical_Parameters.Left_Margin := Current_Font.Horizontal_Points_Per_Inch ; Current_Physical_Parameters.Right_Margin := Current_Font.Horizontal_Points_Per_Inch ; Current_Physical_Parameters.Binding_Edge := 0 ; Current_Physical_Parameters.Printing_Left_Side := True ; Current_Physical_Parameters.real_center_right := 0 ; Current_Physical_Parameters.real_center_left := 0 ; Current_Physical_Parameters.real_right := Current_Font.Horizontal_Points_Per_Inch ; Current_Physical_Parameters.real_left := Current_Font.Horizontal_Points_Per_Inch ; -- Vertical Information Current_Physical_Parameters.Paper_Length := Current_Font.Vertical_Points_Per_Inch * 11 ; -- 11" Current_Physical_Parameters.Top_Margin := Current_Font.Vertical_Points_Per_Inch ; -- 1" Current_Physical_Parameters.Bottom_Margin := Current_Font.Vertical_Points_Per_Inch ; -- 1" -- Page Numbering Information Current_Document_Parameters.Page_Numbering_On := False ; Current_Document_Parameters.Current_Page_Number:= 1 ; Current_Document_Parameters.Section_Numbering_On := False ; Current_Document_Parameters.Current_Section_Num:= 1 ; Current_Document_Parameters.Number_Page_At_Top := False ; Current_Document_Parameters.Page_Number_Goes := Center; Current_Document_Parameters.Page_Prefix_Suffix := Blank_Line ; set_length( Current_Document_Parameters.Page_Prefix_Suffix , 1 ) ; Current_Document_Parameters.Page_Prefix_Suffix.data(1) := '$' ; Current_Document_Parameters.Page_Heading_Footing_VMI := Current_Font.Vertical_Points_Per_Inch / 6 ; -- 6 lines/inch -- Heading Information Current_Document_Parameters.Heading_Lines := 0 ; Current_Document_Parameters.Heading_Height := 0 ; Current_Document_Parameters.Heading_Pointer := null ; -- Footing Information Current_Document_Parameters.Footing_Lines := 0 ; Current_Document_Parameters.Footing_Height := 0 ; Current_Document_Parameters.Footing_Pointer := null ; -- Foot Note Information Current_Document_Parameters.FootNote_Lines := 0 ; Current_Document_Parameters.FootNote_Height := 0 ; Current_Document_Parameters.FootNote_Pointer := null ; -- need_to_start_page := True ; Output_Permitted := Current_Environment .First_Page_To_Print <= 1 ; In_Header_Or_Footer := False ; Current_Formatting_Parameters.Left_Indentation := 0 ; Current_Formatting_Parameters.Right_Indentation := 0 ; Current_Formatting_Parameters.Paragraph_Indent := 0 ; Current_Formatting_Parameters.Subsequent_Line_Ind:= 0 ; Current_Formatting_Parameters.Filling_On := False ; Current_Formatting_Parameters.Justification_On := False ; Current_Formatting_Parameters.Fill_Before_Special:= False ; Current_Formatting_Parameters.Just_Before_Special:= False ; Current_Formatting_Parameters.Delay_Justification_Till_After_Dots := False ; Current_Formatting_Parameters.Line_Modification := Nothing ; Current_Formatting_Parameters.Modification_Status:= Off ; Current_Formatting_Parameters.Modify_To_Do := 0 ; Current_Formatting_Parameters.Permanent_Character_Changes := No_Character_Changes ; Current_Formatting_Parameters.Temporary_Character_Changes := No_Character_Changes ; Current_Formatting_Parameters.Current_Character_Changes := No_Character_Changes ; -- Now, special work for interpreting characters... -- Clear to illegal for ext_char in extended_character'first .. extended_character'last loop char_types ( ext_char ) := illegal_character ; end loop ; -- Set Text Characters for ext_char in extended_space .. extended_character ( character'pos( '~' ) ) loop char_types ( ext_char ) := Text_Character ; end loop ; -- Now, recognize special characters... for a_char in a_char_type'first .. a_char_type'last loop if default_characters_array ( a_char ) /= extended_nul then -- must change it... char_types ( default_characters_array ( a_char ) ) := a_char ; end if ; end loop ; Current_Characters_Array := Default_Characters_Array ; character_tab_positions := cleared_bool ; -- PrintF Initialization.... Binding_Edge_Amount := 0 ; -- Now, ACTUAL PHYSICAL INITIALIZATION!!!!!! -- and, note thate even though we call print functions with all types -- of parameters, only those which pertain to the current output -- device are executed..... execute_printer_command( set_hmi , Current_Font.Horizontal_Points_Per_Inch / 10 ) ; -- 10 characters per inch execute_printer_command( set_vmi , Current_Font.Vertical_Points_Per_Inch / 6 ) ; -- 6 lines per inch execute_printer_command( set_black_ribbon ) ; execute_printer_command( set_print_forward ) ; execute_printer_command( set_form_length , Current_Physical_Parameters.Paper_Length ) ; end initialize_print_work_for_a_new_document ; Procedure Get_Line is bb : boolean ; cc : character ; begin -- get_line commands_were_processed_just_now := false ; Input_Line_Contains_Text := false ; loop if end_of_main_input_file then if ready_to_stop then execute_printer_command(end_last_page) ; return ; else force_into_input_stream( string_to_pstring ( ".endp " ) , bb ) ; ready_to_stop := true ; end if ; else load_input_line(Current_Formatting_Parameters.Filling_On); if Input_Line_Length = 0 then Input_Line_Length := 1 ; Input_Line(1) := extended_space ; end if ; if end_of_main_input_file then -- this is for blank char last line Input_Line_Contains_Text := false ; for posn in 1 .. Input_Line_Length loop Input_Line_Contains_Text := ( Input_Line_Contains_Text or (Input_Line(posn) /= extended_space )) ; end loop ; if not Input_Line_Contains_Text or else processing_comment_area then force_into_input_stream( string_to_pstring ( ".endp " ) , bb ) ; ready_to_stop := true ; end if ; Input_Line_Contains_Text := false ; processing_comment_area := false ; end if ; -- critical...........switches..... if processing_comment_area then if input_line ( 1 ) = extended_character(character'pos('.')) then -- possibly a command to reverse it... -- we need to know the first character of the commands -- which can affect this cc := map_up( character'val( Input_Line(2) ) ) ; if ( cc = 'C' ) or ( cc = 'E' ) or ( cc = 'F' ) then parse_input_command_line ; -- to find out real meanings case command is when comments_command => processing_comment_area :=not (modifier_one = on_modifier); when else_command => processing_comment_area := false ; when finish_command => processing_comment_area := false ; when others => null ; -- doesn't matter what it is end case ; end if ; -- else skip this line.... end if ; else if Input_Line(1) = extended_character(character'pos('.')) then options( Input_Line_Contains_Text ) ; else Input_Line_Contains_Text := ( Input_Line(1) /= extended_character ( character'pos( '?' ) ) ) ; end if ; end if ; end if ; exit when Input_Line_Contains_Text ; end loop ; end get_line ; procedure add_this_line_to_paragraph is -- we have an input line and filling is on -- -- Important variables -- -- Paragraph & Shape Variables -- -- text_waiting_inside_filled_paragraph : boolean -- tab_requested_to_position : horizontal_measurement -- just_did_tab_command : boolean -- rightmost_text_position : horizontal_measurement -- leftmost_para_text_position : horizontal_measurement -- leftmost_text_position : horizontal_measurement -- Current_Formatting_Parameters.Justification_On : boolean -- Current_formatting_parameters. -- Delay_Justification_Till_After_Dots : boolean -- -- New Line Variables -- -- waiting_output_line : output_line_pointer -- waiting_output_invalid_breaks : boolean_array -- -- Filled Line Variables -- -- filling_output_line : output_line_pointer -- Filling_Trailing_Spaces : Integer -- -- Important Routines -- -- tidy_up_and_output_filled_line -- --------------------------------------------------------------------- -- -- The goal of this routine is to move as many full words over -- from the waiting output line into filling_output_line. The only -- place the line can be broken is at posn 1 or else a character -- which follows a space which did not have the invalid break value -- set. -- --------------------------------------------------------------------- -- line_start_position : output_line_index := 1 ; -- Next Char to move over. last_successfull_position : output_line_index := 0 ; -- The last character with trailing -- spaces which was moved over for -- output was this position last_successfull_length : horizontal_measurement := 0 ; -- length of that area so far ending_position_so_far : output_line_index := 0 ; -- The last printable character moved -- over. Ending_Position_Length : horizontal_measurement := 0 ; -- no points long yet for ending posn work_position : output_line_index := 0 ; -- position to work on now Work_Position_Length : horizontal_measurement := 0 ; -- same for working position work_without_space_position : output_line_index := 0 ; work_without_space_length : horizontal_measurement := 0 ; last_char_breakable_space : boolean := false ; -- last char not a space for break room_in_filling_line : horizontal_measurement ; c : extended_character ; w : horizontal_measurement ; number_of_words : integer := 0 ; waiting_width : horizontal_measurement ; temporary_waiting_filling_spaces : integer ; procedure prepare_for_adding_line is c : extended_character ; w : horizontal_measurement ; position : output_line_index ; added_width : horizontal_measurement ; begin -- prepare_for_adding_line -- need to append the trailing space(s) c := extended_space ; w := current_font.width ( extended_space ) ; position := filling_output_line.character_count + 1 ; added_width := 0 ; loop filling_output_line.the_character ( position ) := c ; filling_output_line.the_width ( position ) := w ; filling_output_line.font_number ( position ) := filling_output_line.font_number ( position - 1 ) ; if filling_output_line.special_options then filling_output_line.underline ( position ) := filling_trailing_spaces_are_underlined ; filling_output_line.sub_or_supers ( position ) := filling_output_line.sub_or_supers ( position - 1 ) ; end if ; added_width := added_width + w ; position := position + 1 ; filling_trailing_spaces := filling_trailing_spaces - 1 ; exit when filling_trailing_spaces <= 0 ; end loop ; filling_output_line.character_count := position - 1 ; filling_output_line.stop_position := filling_output_line.stop_position + added_width ; if not current_formatting_parameters.justification_on then filling_output_line.justify_to := filling_output_line.stop_position ; end if ; end prepare_for_adding_line ; function look_for_dots return output_line_index is place : output_line_index := 1 ; cc : character ; good : boolean ; begin -- look_for_dots -- return the place where the first word starts following a -- line starting with a dot type word. Else, return 1 while ( place < filling_output_line.character_count ) and then ( filling_output_line.the_character ( place ) /= extended_space ) loop place := place + 1; end loop ; place := place - 1 ; if place = 0 then return 1 ; -- blank line elsif not dot_set ( filling_output_line.the_character ( place ) ) then return 1 ; -- not ending in dot_set else -- ended in correct character cc := character'val ( filling_output_line.the_character ( place ) ); if ( cc = 'o' ) or ( cc = 'O' ) then good := place = 1 ; -- only dot if single character... else good := place <= 5 ; -- only up to 5 characters before dot char end if ; if not good then return 1 ; -- no dots... else -- must refigure it out filling_output_line.wordspace_count := filling_output_line.wordspace_count - 1 ; place := place + 2 ; -- one for current char, one for space while ( place < filling_output_line.character_count ) and then ( filling_output_line.the_character ( place ) = extended_space ) loop place := place + 1; end loop ; return place ; -- that is where we will now start justification end if ; end if ; end look_for_dots ; procedure Move_Over_Current_Text is fill_start : output_line_index ; work_start : output_line_index ; work_stop : output_line_index ; old_font : font_number ; font_numb : font_number ; begin -- Move_Over_Current_Text if ending_position_so_far < 1 then -- we are forcing out an old line which is just waiting for output return ; end if ; -- note, if it is a single word, we let it fit anyway! -- move line_start_position .. work_without_space_position over -- starting at filling_output_line.character_count + 1 -- -- First, move over the current text which might be waiting fill_start := filling_output_line.character_count + 1 ; work_start := line_start_position ; work_stop := ending_position_so_far ; -- following to be used to set if any font changes if fill_start = 1 then -- new line old_font := waiting_output_line.font_number ( work_start ) ; else old_font := filling_output_line.font_number ( fill_start - 1 ) ; end if ; loop exit when work_start > work_stop ; filling_output_line.the_character ( fill_start ) := waiting_output_line.the_character ( work_start ) ; filling_output_line.the_width ( fill_start ) := waiting_output_line.the_width ( work_start ) ; font_numb := waiting_output_line.font_number ( work_start ) ; filling_output_line.font_number ( fill_start ) := font_numb ; if font_numb /= old_font then filling_output_line.font_changes := true ; -- once set true we don't care, so don't set old_font to -- anything else... end if ; if waiting_output_line.special_options then filling_output_line.special_options := true ; -- note that this might set special options when we really don't -- have any, but this is just to save processing time, and we -- will save the most time by setting it no matter what. filling_output_line.double_strike ( fill_start ) := waiting_output_line.double_strike ( work_start ) ; filling_output_line.offset_strike ( fill_start ) := waiting_output_line.offset_strike ( work_start ) ; filling_output_line.underline ( fill_start ) := waiting_output_line.underline ( work_start ) ; filling_output_line.sub_or_supers ( fill_start ) := waiting_output_line.sub_or_supers ( work_start ) ; end if ; work_start := work_start + 1 ; fill_start := fill_start + 1 ; end loop ; -- now, set all other items -- filling_output_line.start_position is already set filling_output_line.stop_position := filling_output_line.stop_position + ending_position_length ; if Current_Formatting_Parameters.Justification_On then filling_output_line.justify_to := rightmost_text_position ; else filling_output_line.justify_to := filling_output_line.stop_position; end if ; -- now, we must check for dots.... -- note that we might do this a few times for a line, but it is to -- ensure that the other routines always get a clean copy of the -- text line filling_output_line.character_count := fill_start - 1 ; if filling_output_line.wordspace_count = 0 then -- adding to blank line filling_output_line.wordspace_count := number_of_words - 1 ; else -- adding to line with other text... filling_output_line.wordspace_count := filling_output_line.wordspace_count + number_of_words ; end if ; if Current_formatting_parameters.Delay_Justification_Till_After_Dots and then filling_output_line.start_position = leftmost_para_text_position then -- dots on and we are starting a paragraph... filling_output_line.first_justify := look_for_dots ; else filling_output_line.first_justify := 1 ; end if ; -- That is it! Everything is set.... text_waiting_inside_filled_paragraph := true ; end Move_Over_Current_Text ; procedure Output_Filling_Line is begin -- Output_Filling_Line kind_of_move_after_line := move_forward_on_page ; amount_waiting_to_move_vertically_after_line := current_vertical_motion_index ; move_before_current_line ( false , first_line_of_filled_paragraph ) ; -- not last line of para, but first line of para (possibly) ... tidy_up_and_output_filled_line ; first_line_of_filled_paragraph := false ; -- now that we have output the first line of this paragraph, and -- we have overflowed, meaning that we have a paragraph of at least -- two lines, then we are no longer on the first line of the parag. end Output_Filling_Line ; procedure clear_up_filling_line is -- reset back to correct values for blank line begin -- clear_up_filling_line filling_output_line.start_position := leftmost_text_position ; filling_output_line.stop_position := leftmost_text_position ; just_did_tab_command := false ; room_in_filling_line := rightmost_text_position - filling_output_line.stop_position ; -- that is how much room is available -- to add to the current line. waiting_width := 0 ; end clear_up_filling_line ; procedure move_over_a_word is -- a word has ended, move correct amount over.... begin number_of_words := number_of_words + 1 ; last_char_breakable_space := false ; If work_without_space_length > room_in_filling_line and then ( ( number_of_words > 1 ) or else ( filling_output_line.character_count > 0 ) ) then -- if we have a word which will overflow the output line -- and then we will move a single word over and not the others -- or else the line containing the text waiting for filling output -- is not blank, then output it. If the new word is too long for -- the margins, but no words are on the current line, add it to -- the current line anyway.....because otherwise we will loop -- forever. Finally, if the word fits, just keep working and -- skip this area of code.... if number_of_words > 1 then number_of_words := number_of_words - 1 ; end if ; move_over_current_text ; -- move current text to output area output_filling_line ; -- and output that text. clear_up_filling_line ; -- and set up for new line. -- note, if it is a single word, we let it fit anyway! -- move line_start_position .. work_without_space_position over -- starting at filling_output_line.character_count + 1 number_of_words := 1 ; -- for current word line_start_position := last_successfull_position + 1 ; work_position_length := work_position_length - last_successfull_length ; -- because even though we did not put spaces into the last -- line (at the end), they are thrown away... work_without_space_length := work_without_space_length - last_successfull_length ; elsif waiting_width > 0 then prepare_for_adding_line ; waiting_width := 0 ; end if ; -- now, we can just prepare to move over... last_successfull_position := work_position - 1 ; last_successfull_length := work_position_length ; Ending_position_so_far := work_without_space_position ; Ending_Position_Length := work_without_space_length ; end move_over_a_word ; begin -- add_this_line_to_paragraph if text_waiting_inside_filled_paragraph then waiting_width := filling_trailing_spaces * current_font.width ( extended_space ) ; if just_did_tab_command then -- must move to correct position -- for now, we cannot get here because we always end a para. null ; end if ; else waiting_width := 0 ; -- we need to set the line boundries first_line_of_filled_paragraph := true ; if just_did_tab_command then -- must move to correct position filling_output_line.start_position := tab_requested_to_position ; filling_output_line.stop_position := tab_requested_to_position ; else filling_output_line.start_position := leftmost_para_text_position ; filling_output_line.stop_position := leftmost_para_text_position ; end if ; end if ; just_did_tab_command := false ; room_in_filling_line := rightmost_text_position - filling_output_line.stop_position - waiting_width ; -- that is how much room is available -- to add to the current line. -- first, eat leading spaces while ( line_start_position <= waiting_output_line.character_count ) and then waiting_output_line.the_character ( line_start_position ) = extended_space loop line_start_position := line_start_position + 1 ; end loop ; if line_start_position > waiting_output_line.character_count then -- no text on this line....Skip entire operation return ; end if ; -- line start position is where the next set of chararacters will start -- to come from to move over into output stream... last_successfull_position := line_start_position - 1 ; -- last good output position is the line start position - 1 ; work_position := line_start_position - 1 ;--last worked char loop exit when work_position >= waiting_output_line.character_count ; -- exit this loop when we have worked the last valid character -- we don't use a for loop because we want to know what work_position -- is after leaving the loop work_position := work_position + 1 ; c := waiting_output_line.the_character ( work_position ) ; w := waiting_output_line.the_width ( work_position ) ; -- we get here knowing that the last char was or was not a possible -- break chararacter. If it was, and the new chararacter is not a -- space, then process for end of a work... If not, just move on to -- the next character, adding to lengths... if last_char_breakable_space and then c /= extended_space then -- end of trailing spaces after word, work it... move_over_a_word ; -- rsc!!! waiting_width := 0 ; elsif c = extended_space and then not last_char_breakable_space and then not waiting_output_invalid_breaks ( work_position ) then -- must set up as start of trailing space work_without_space_position := work_position - 1 ; work_without_space_length := work_position_length ; last_char_breakable_space := true ; end if ; -- now, in any case, move over the current character.... Work_Position_Length := Work_Position_Length + w ; end loop ; -- move over the remainder .. if not last_char_breakable_space then -- no trailing_spaces on this line... if waiting_output_line.the_character ( work_position ) = extended_character ( character'pos ( '-' ) ) then -- a hyphenated word ending at line end... temporary_waiting_filling_spaces := 0 ; else temporary_waiting_filling_spaces := 1 ; end if ; work_without_space_position := work_position ; work_without_space_length := work_position_length ; work_position := work_position + 1 ; -- to pretend that a ' ' is there else temporary_waiting_filling_spaces := work_position - work_without_space_position ; end if ; work_position := work_position + 1 ; -- to pretend that we have moved to the first char of a new word move_over_a_word ; -- really forces out a line if the word before -- this ends a line... if waiting_width > 0 then prepare_for_adding_line ; waiting_width := 0 ; end if ; last_successfull_position := work_position - 1 ; last_successfull_length := work_position_length ; Ending_position_so_far := work_without_space_position ; Ending_Position_Length := work_without_space_length ; -- and now, do the current word... move_over_current_text ; -- Now, to remember for later.... filling_trailing_spaces := temporary_waiting_filling_spaces ; filling_trailing_spaces_are_underlined := current_formatting_parameters.current_character_changes ( Underline_Continuous ) ; end add_this_line_to_paragraph ; Procedure compress_input_line ( only_right : in boolean ) is start_ind : integer := 1 ; ending_ind : integer := input_line_length ; begin if not only_right then -- we are to compress both sides... While start_ind <= ending_ind and then Input_Line(start_ind) = extended_space loop start_ind := start_ind + 1 ; end loop ; end if ; while ending_ind >= start_ind and then Input_Line(ending_ind) = extended_space loop ending_ind := ending_ind - 1 ; end loop ; if start_ind > ending_ind then Input_Line_Length := 0 ; else if start_ind > 1 then for posn in start_ind .. ending_ind loop Input_Line ( posn - start_ind + 1 ) := Input_Line ( posn ) ; end loop ; end if ; Input_Line_Length := ending_ind - start_ind + 1 ; end if ; end compress_input_line ; procedure finish_print_work_for_an_old_document is begin -- finish_print_work_for_an_old_document finish_printer_globals_for_an_old_document ; finish_print_out_for_an_old_document ; finish_printer_misc_for_an_old_document ; finish_printer_commands_for_an_old_document ; if Index_File_Is_Open then text_io.close(index_output_file); end if ; end finish_print_work_for_an_old_document ; begin -- -- Initialize -- current_environment := initial_environment ; alt_in_file_name := no_file ; initialize_printer_globals_for_a_new_document ; initialize_print_out_for_a_new_document ; initialize_printer_misc_for_a_new_document ; initialize_print_work_for_a_new_document ; -- Note that the printer commands must be initialized after print_work initialize_printer_commands_for_a_new_document ; -- -- now, ready to go to work on the document -- loop get_line ; -- get the next line... exit when not input_line_contains_text ; -- must be done... exit when user_interrupt ; -- or is an exception raised ? if Current_Formatting_Parameters.Filling_On then input_line_to_output_line ; add_this_line_to_paragraph ; else -- work the movement kind_of_move_after_line := move_forward_on_page ; amount_waiting_to_move_vertically_after_line := current_vertical_motion_index ; move_before_current_line ; -- now, we need to do a little compression work on the input line case current_formatting_parameters.line_modification is when nothing => compress_input_line ( true ) ; when center_mod => compress_input_line ( false ) ; when right_justify => compress_input_line ( false ) ; when to_left_margin=> null ; -- this is only for page numbers, etc. end case ; if input_line_length > 0 then -- we have to do something ... input_line_to_output_line ; -- now, need to reset the character changes back to what it was when -- this routine was called, because with filling off, temporary -- changes are only kept for the current line.... current_formatting_parameters.current_character_changes := current_formatting_parameters.permanent_character_changes ; -- end of work with character changes... modify_a_line ( waiting_output_line ) ; send_input_text_to_output_device ; end if ; end if ; end loop ; -- -- and finish any loose ends -- finish_print_work_for_an_old_document ; -- -- done with a document -- exception -- when users_requested_abort => if not Need_To_Start_Page then end_a_page ; end if ; execute_printer_command(end_last_page) ; finish_print_work_for_an_old_document ; raise users_requested_abort ; -- when last_selected_page_printed => execute_printer_command(end_last_page) ; finish_print_work_for_an_old_document ; -- and we end normally, because we might want -- several copies of a selected range of pages -- when fatal_output_error => finish_print_work_for_an_old_document ; raise fatal_output_error ; -- end print_a_single_document ; procedure end_output ( printout_aborted_by_user_intervention : boolean ) is c : character ; ok : boolean ; begin -- end_output -- first step in ending - tell them we're done if not printout_aborted_by_user_intervention and then Initial_Environment.Show_Output_Status then clear_end_of_screen ( master_window , 22 , 1 ) ; otsxy(20,22,"Complete....Hit space to continue!"); bell ; end if ; -- next, if not going to screen, we might have to do some work if Initial_Environment.Where_To /= to_screen then -- we have a file or printer out there -- stall, to preceed printer reset Execute_Printer_Command(printer_reset) ; if Initial_Environment.Where_To = to_file then -- we must close the file we were going to close_output_file ( ok ) ; elsif Initial_Environment.Where_To = to_printer then null ; -- release_printer ; end if ; end if ; if not printout_aborted_by_user_intervention and then Initial_Environment.Show_Output_Status then wait_for_character(' '); end if ; -- if variable, then delete that command from command table... end end_output ; procedure end_an_entire_document is begin -- end_an_entire_document if Initial_Environment.Inp_Source = fm_database then -- we must take that variable command name out of the tree.... DELETE_NAME ( "variable_data_insertion" , command_tree ) ; end if ; end end_an_entire_document ; procedure close_print_work is begin -- close_print_work close_printer_globals ; close_print_out ; close_printer_misc ; close_printer_commands ; end close_print_work ; begin -- print_work global_initialize_print_work ; end print_work ; --$$$- PRNTWORK --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntmain --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTMAIN -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Energy Systems Group -- Ada Software Development Project Team -- 2280 U.S. Highway 19 North, Suite 120 -- Clearwater, Florida 33575 -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- -- This is the master Print Routine... with text_io ; with direct_IO ; with string_library ; use string_library ; with basic_io_system ; with crt_customization ; use crt_customization ; with crt_windows ; use crt_windows ; with Wordp_Globals ; use Wordp_Globals ; with printer_globals ; use printer_globals ; with print_in_to_out ; with print_out ; with print_work ; use print_work ; Package PRINT_MAIN is procedure TEXT_FORMATTER(SOURCE_FILE : in ASCII_TEXT_FILE_NAME ; -- := wp_globals.no_file ; DESTINATION_FILE : in ASCII_TEXT_FILE_NAME ; -- := wp_globals.no_file ; STARTING_ENVIRONMENT : in FORMATTER_ENVIRONMENT ) ; -- := default_environment); -- This tool formats the SOURCE_FILE according to the default format -- and imbedded formatting commands. The output is sent to the destination -- device or file. end ; Package body PRINT_MAIN is type printer_save_block is record printer : printer_type ; accessy : printer_accessories_type ; end record ; package save_block_io is new direct_IO(printer_save_block); procedure TEXT_FORMATTER(SOURCE_FILE : in ASCII_TEXT_FILE_NAME ; -- := wp_globals.no_file ; DESTINATION_FILE : in ASCII_TEXT_FILE_NAME ; -- := wp_globals.no_file ; STARTING_ENVIRONMENT : in FORMATTER_ENVIRONMENT ) is -- := default_environment) is -- This tool formats the SOURCE_FILE according to the default format -- and imbedded formatting commands. The output is sent to the destination -- device or file. Save_Block_File_name : constant ascii_text_file_name := "PRINTDEF.ENV " ; Ot_Option : character ; -- what is the current selected output option? Was_Successfull , Please_Quit : boolean ; procedure restore_printer_settings is file_handle : save_block_io.file_type ; final_name : ascii_text_file_name ; p_save_block: printer_save_block ; it_exists : boolean ; begin -- restore_printer_settings -- sok_to_read(save_block_file_name, final_name , it_exists ) ; -- we want to use local file... -- if it_exists then -- save_block_io.open(file_handle,save_block_io.in_file, -- no_blanks(final_name)); -- save_block_io.read(file_handle,p_save_block); -- permanent_printer := p_save_block.printer ; -- printer_accessories := p_save_block.accessy ; -- else -- must do defaults -- permanent_printer := z_xerox ; -- printer_accessories := none ; -- end if ; save_block_io.open(file_handle,save_block_io.in_file, no_blanks( save_block_file_name ) ) ; save_block_io.read(file_handle,p_save_block); permanent_printer := p_save_block.printer ; printer_accessories := p_save_block.accessy ; exception -- here only if the file exists but we were unable to read it when others => permanent_printer := z_qume ; printer_accessories := none ; end restore_printer_settings ; procedure save_printer_settings is file_handle : save_block_io.file_type ; final_name : ascii_text_file_name ; p_save_block: printer_save_block ; it_exists : boolean ; begin -- save_printer_settings p_save_block.printer := permanent_printer ; p_save_block.accessy := printer_accessories ; sok_to_read(save_block_file_name, final_name , it_exists ) ; -- ok, here we can let it mess with us.... if it_exists then save_block_io.open(file_handle,save_block_io.out_file, no_blanks(final_name)); else save_block_io.create(file_handle,save_block_io.out_file, no_blanks(save_block_file_name)); end if ; save_block_io.write(file_handle,p_save_block); save_block_io.close(file_handle); exception -- here only if the file exists but we were unable to read it when others => error( " Unable to correctly save printer settings " , not_fatal_error , operator_wait , short_beep ) ; end save_printer_settings ; procedure print_package_initialize is -- initialize by reading a file somewhere that keeps us -- posted to the current printer... begin -- print_package_initialize Initial_Environment := starting_environment ; if Initial_Environment.printer_brand = z_unknown then -- we need to find out about the printer defaults restore_printer_settings ; Initial_Environment.printer_brand := permanent_printer ; Initial_Environment.printer_accessories := printer_accessories ; else permanent_printer := Initial_Environment.printer_brand ; printer_accessories := Initial_Environment.printer_accessories ; end if ; change_printer( Initial_Environment.Printer_Brand ) ; end print_package_initialize ; procedure get_options ( please_quit : out boolean ) is -- ask the user all of the appropriate questions , and then -- return please_quit as the signal to quit if they requested it -- this sets the current requested input and output files and -- the starting environment done_with_get_ready , ready_for_printing : boolean ; procedure set_printer is --###--RSC02 start tot_ps : constant integer := 8 ; -- total printers half_ps : constant integer := 8 ; -- max in first column line_ps : constant integer := 7 ; -- first line for printers tot_as : constant integer := 4 ; -- total accessories half_as : constant integer := 4 ; -- max in first column line_as : constant integer := 19 ; -- first line for accessories --###--RSC02 stop ch : character ; i : integer ; temp : boolean ; good_options : character_set ; Procedure get_xy ( current_entry : in integer ; x,y : out integer ) is temp_entry : integer ; begin -- 1..29 are printers -- 30..40 are options if current_entry < 30 then -- is a printer if current_entry <= half_ps then x := 2; else x := 44 ; end if ; y := ( (current_entry - 1) mod half_ps ) + line_ps ; -- this does lines 7..15 for half_ps=8 and line_ps=7 else -- this is an accessory temp_entry := current_entry - 30 ; if temp_entry <= half_as then x := 2 ; else x := 44 ; end if ; y := ( (temp_entry - 1) mod half_as ) + line_as ; end if ; end get_xy ; Procedure pname(current_entry : in integer ; name : in string ; value : in boolean ) is x , y : integer ; begin -- pname get_xy(current_entry,x,y) ; -- convert to x,y coordinates otsxy(x,y,name) ; if value then otsxy( x+31,y,"True") ; end if ; end pname ; Procedure Long is begin clear_window( master_window ) ; clear_prompt( master_window ) ; goto_prompt_line_column ( master_window , 1 , 2 ) ; put("Enter option to select or change (<space> to quit) ? "); --###--RSC02 start otsxy(3,2,"This is the routine to set up the computer for different types of"); otsxy(3,3,"printers and accessories. Possible choices are grouped together."); otsxy(3,4,"Only one option of a group may be selected at one time."); pname( 1,"A : Draft Copy Printer" , permanent_printer = z_pdumb ) ; pname( 2,"B : Qume Printer" , permanent_printer = z_qume ) ; pname( 3,"C : Xerox 630 / Diablo 630" , permanent_printer = z_xerox ) ; pname( 4,"D : Centronics 737 Printer" , permanent_printer = z_cent737 ) ; pname( 5,"E : Dataproducts" , permanent_printer = z_dataproducts) ; pname(31,"1 : No Accessories" , printer_accessories = none ) ; pname(32,"2 : Tray Loader" , printer_accessories = trayloader ) ; pname(33,"3 : Dual Tray Loader " , printer_accessories = dual_tray ) ; pname(34,"4 : Mechanical Tray Loader" , printer_accessories = mech_tray ) ; --###--RSC02 stop end long ; Procedure do_this ( current_entry , estart , enum : in integer ) is ii : integer ; x , y : integer ; begin -- do_this for ii in estart .. estart-1+enum loop get_xy(ii,x,y) ; x := x + 31 ; -- to offset past line of prompt if ii = current_entry then otsxy(x,y,"True ") ; else otsxy(x,y," ") ; end if ; end loop ; end do_this ; begin -- set_printer long ; clear_set(good_options) ; good_options('0') := true ; good_options(' ') := true ; for cc in 'A' .. 'P' loop good_options(cc) := true ; end loop ; for cc in '1' .. '4' loop good_options(cc) := true ; end loop ; loop goto_prompt_line_column( master_window , 1 , 59 ) ; crt_windows.put(' ') ; goto_prompt_line_column( master_window , 1 , 59 ) ; ch := goodchar(good_options , ' ') ; case ch is --###--RSC02 starts when 'A' => do_this(1,1,tot_ps) ; permanent_printer := z_pdumb ; when 'B' => do_this(2,1,tot_ps) ; permanent_printer := z_qume ; when 'C' => do_this(3,1,tot_ps) ; permanent_printer := z_xerox ; when 'D' => do_this(4,1,tot_ps) ; permanent_printer := z_cent737 ; when 'E' => do_this(5,1,tot_ps) ; permanent_printer := z_dataproducts ; --###--RSC02 stops when '1' => do_this(31,31,tot_as) ; printer_accessories := none ; when '2' => do_this(32,31,tot_as) ; printer_accessories := trayloader ; when '3' => do_this(33,31,tot_as) ; printer_accessories := dual_tray ; when '4' => do_this(34,31,tot_as) ; printer_accessories := mech_tray ; when others => null ; end case ; exit when ch = ' ' ; end loop ; Initial_Environment.printer_brand := permanent_printer ; Initial_Environment.printer_accessories := printer_accessories ; change_printer ( permanent_printer ) ; save_printer_settings ; end set_printer ; Procedure Show_options is made_changes : boolean ; s : string(1 .. 8) ; procedure put ( d : basic_io_system.timer ) is begin -- put case d.day_of_week is when basic_io_system.sunday => put( "Sun" ) ; when basic_io_system.monday => put( "Mon" ) ; when basic_io_system.tuesday => put( "Tue" ) ; when basic_io_system.wednesday => put( "Wed" ) ; when basic_io_system.thursday => put( "Thu" ) ; when basic_io_system.friday => put( "Fri" ) ; when basic_io_system.saturday => put( "Sat" ) ; end case ; put(" "); case d.month is when 1 => put( "Jan" ) ; when 2 => put( "Feb" ) ; when 3 => put( "Mar" ) ; when 4 => put( "Apr" ) ; when 5 => put( "May" ) ; when 6 => put( "Jun" ) ; when 7 => put( "Jul" ) ; when 8 => put( "Aug" ) ; when 9 => put( "Sep" ) ; when 10 => put( "Oct" ) ; when 11 => put( "Nov" ) ; when 12 => put( "Dec" ) ; end case ; put(" "); put( d.day , 2 ) ; put(" "); put( d.year , 4 ) ; put(" "); put( d.hour , 2 ) ; put(":"); if d.minute < 10 then put("0"); put( d.minute , 1 ) ; else put( d.minute , 2 ) ; end if ; end put ; Procedure dateout is begin -- dateout put("["); put(basic_io_system.clock); put("]"); end ; Procedure printout is begin crt_windows.put("[Current Printer is "); case z_printer is --###--RSC02 starts when z_pdumb => crt_windows.put("Draft Copy Printer"); when z_qume => crt_windows.put("Qume"); when z_xerox => crt_windows.put("Xerox/Diablo 630"); when z_cent737 => crt_windows.put("Centronics 737"); when z_dataproducts => crt_windows.put("Dataproducts"); when others => crt_windows.put("HELP! Printer Unknown"); --###--RSC02 stops end case ; crt_windows.put(']'); end printout ; Procedure show_status ( s : string ) is begin clear_window ( master_window ) ; clear_prompt ( master_window ) ; otsxy(20,11,"Please Wait - "); crt_windows.put(s) ; end show_status ; begin -- show_options change_printer( permanent_printer ) ; clear_prompt( master_window ) ; clear_window( master_window ) ; goto_line_column( master_window , 23 , 1 ) ; -- put( -- "SAIC Text Formatter modified from Program " & -- "Copyright (c) 1984, R. S. Cymbalski" -- ); goto_line_column( master_window , 23 , 1 ) ; printout; goto_line_column( master_window , 23 , 54 ) ; dateout; otsxy(26,3,"SAIC Text Formatter Print Menu"); otsxy(20,8,"Options:"); otsxy(22,10,"P : Print Documents or Form Letters"); otsxy(22,11,"V : Variable Data List Merge"); otsxy(22,12,"S : Set Printer Type "); otsxy(22,14,"Q : Quit") ; otsxy(20,16,"Enter Option: "); Ot_Option := char_or_abort( 'Q' , 'P' , 'V' , 'S' , 'Q' ) ; clear_window( master_window ) ; clear_prompt( master_window ) ; if Ot_Option = 'S' then set_printer ; elsif Ot_Option = 'Q' then null ; elsif Ot_Option = 'P' then Initial_Environment.Inp_Source := fm_text ; else Initial_Environment.Inp_Source := fm_database ; end if ; end show_options ; Procedure goodname(the_file_to_check : input_file_type ; line_number_to_use: window_line_number ; prompt_to_use : string ; the_file_name : out ascii_text_file_name ; file_is_ok_to_read: out boolean ) is form , default : ascii_text_file_name := no_file ; fname : ascii_text_file_name ; ok_to_read : boolean ; begin -- goodname ok_to_read := false ; loop clear_end_of_screen( master_window , line_number_to_use , 1 ) ; goto_line_column( master_window , line_number_to_use , 2 ) ; put("Enter "); put(compress(prompt_to_use)); put(" File Name ( or <return> to abort ) "); -- bell ; fname := get_input_filename_or_return ; exit when fname = no_file ; open_for_read( the_file_to_check , fname , ok_to_read ) ; exit when file_is_ok_to_read ; error( " Invalid File Name, Try Again. " , not_fatal_error , operator_wait , short_beep ) ; end loop ; the_file_name := fname ; file_is_ok_to_read := ok_to_read ; end goodname ; Procedure Get_Ready_For_Printing ( done_with_get_ready : out boolean ; ready_for_printing : out boolean) is new_file_name : ascii_text_file_name ; re_try_get_ready : exception ; howout : character ; ok : boolean ; procedure get_output_file_name is done : boolean ; begin -- get_output_file_name done := false ; loop clear_end_of_screen( master_window , 21 , 2 ) ; goto_line_column ( master_window , 21 , 2 ) ; put(" Enter Output File Name ( or <return> to abort ) => ") ; new_file_name := get_output_filename_or_return ; if new_file_name = no_file then done := true ; -- fall through elsif new_file_name( 1 ) = ascii.esc then -- an error, the file name did not exist error(" File """ & compress(new_file_name ( 2 .. new_file_name'length ) ) & """ is an invalid name." , not_fatal_error , operator_wait , short_beep ) ; elsif file_exists ( new_file_name ) then -- we must confirm that they want to save it clear_end_of_screen( master_window , 23 , 2 ) ; goto_line_column( master_window , 23 , 2 ) ; put(" File """ & compress(new_file_name) & """ already exists. "); put(" Delete and continue (Y/N) ? "); done := char_or_abort( 'N' , 'Y' , 'N' ) = 'Y' ; else done := true ; -- because it does not exist... end if ; -- need to set the default environment exit when done ; end loop ; end get_output_file_name ; Procedure set_up_for_the_output is begin -- first, do we output fancy or plain? if (howout = 'A') or (howout = 'B') or ( howout = 'E' ) then -- E is test option... Initial_Environment.Ot_Format := ot_fancy ; else Initial_Environment.Ot_Format := ot_plain ; change_printer(z_pdumb) ; end if ; -- then where does the output go ? if ( howout = 'A' ) or ( howout = 'E' ) then Initial_Environment.Where_To := to_printer ; if howout = 'A' then new_file_name := default_printer ; else new_file_name := "CON2: " ; end if ; elsif howout = 'C' then Initial_Environment.Where_To := to_screen ; new_file_name := default_console ; else Initial_Environment.Where_To := to_file ; end if ; -- finally are we doing a natural spool ? if Initial_Environment.Where_To = to_printer and then howout /= 'E' then -- not testing... -- do we have continuous forms ? goto_line_column ( master_window , 21 , 2 ) ; put("Print on Continuous Forms ( Y or N ) ? "); Initial_Environment.continuous_forms := char_or_abort( 'Y' , 'N' , 'Y' ) = 'Y' ; else Initial_Environment.continuous_forms := true ; end if ; if (howout = 'B') or (howout = 'D') then -- find a file name get_output_file_name ; if new_file_name = no_file then raise re_try_get_ready ; end if ; end if ; formatter_requested_output_file_name := new_file_name ; end set_up_for_the_output ; begin -- get_ready_for_printing loop show_options ; -- show the options and get a response exit when ( Ot_Option = 'V' ) or ( Ot_Option = 'P' ) or ( Ot_Option = 'Q' ) ; end loop ; If Ot_Option = 'Q' then done_with_get_ready := true ; ready_for_printing := false ; else -- (Ot_Option = 'P') or (Ot_Option = 'V') --get a file name for working into output clear_window( master_window ) ; clear_prompt( master_window ) ; goodname(main_input_file , 2 , "Text Input" , new_file_name , ok ) ; if not ok then raise re_try_get_ready ; end if ; formatter_requested_input_file_name := new_file_name ; -- we might later take any leading disk name and save it so that -- inserted files can check the same disk if Ot_Option = 'V' then -- variable data list insertion goodname( variable_input_file , 4 , "Variable Data" , new_file_name , ok ) ; if not ok then raise re_try_get_ready ; end if ; Initial_Environment.Database_File_Name := New_File_Name ; Initial_Environment.Number_Of_Copies_to_print := 1 ; elsif Ot_Option = 'P' then -- how many copies ? goto_line_column ( master_window , 4 , 2 ) ; put("Enter total number of copies desired => "); Initial_Environment.Number_Of_Copies_to_print := get_number( 4, 50, 0, 999, 3, 1 ) ; if Initial_Environment.Number_Of_Copies_to_print = 0 then Initial_Environment.Number_Of_Copies_to_print := 1 ; end if ; -- else condition can never be met end if ; -- next, find the first and last pages to print goto_line_column( master_window , 6 , 2 ) ; put("Enter First Page To Print (<return> for all pages) ?"); Initial_Environment.First_Page_To_Print := get_number( 6 , 65 , 0 , 999 , 3 , 0 ) ; if Initial_Environment.First_Page_To_Print = 0 then Initial_Environment.First_Page_To_Print := 1 ; Initial_Environment.Last_Page_To_Print := 9999 ; goto_line_column ( master_window , 6 , 65 ) ; put( 1 , 3 ) ; -- put a 1 in position using 3 columns else goto_line_column( master_window , 8 , 2 ) ; put( "Enter Last Page To Print (<return> for all remaining pages) ?"); Initial_Environment.Last_Page_To_Print := get_number( 8 , 65 , 0 , 999 , 3 , 0 ) ; if Initial_Environment.Last_Page_To_Print = 0 then Initial_Environment.Last_Page_To_Print := integer'last ; end if ; end if ; otsxy(5,10,"Output Options:"); otsxy(7,12,"A : Print Output on Printer Immediately"); otsxy(7,13,"B : Save Output into a File for Printing Later"); otsxy(7,14,"C : Display Output on Screen"); otsxy(7,15,"D : Put Output into a File for later editing"); otsxy(7,17,"Q : Quit Printout and Return to Print Menu"); otsxy(5,19,"Option ? "); howout := char_or_abort( 'E' , 'A' , 'B' , 'C' , 'D' , 'E', 'Q' ) ; -- -- E added for CON2: output TEST -- RSC -- RSC -- Default should be changed back to 'A' after testing... -- if howout = 'Q' then done_with_get_ready := false ; ready_for_printing := false ; else set_up_for_the_output ; done_with_get_ready := true ; ready_for_printing := true ; end if ; end if ; exception when re_try_get_ready => done_with_get_ready := false ; ready_for_printing := false ; end get_ready_for_printing ; begin -- get_options loop get_ready_for_printing ( done_with_get_ready , ready_for_printing ) ; exit when done_with_get_ready ; end loop ; please_quit := not ready_for_printing ; end get_options ; procedure try_printing ( was_successfull : out boolean ) is -- try printing using the starting environment and -- requested input and output files -- return was_successfull as false if we can't operate with -- the selected options/files/devices final_name : ascii_text_file_name ; successfull : boolean ; unsuccessfull : exception ; printout_aborted_by_user_intervention : boolean := false ; ok : boolean ; printout_completed : boolean := false ; begin -- try_printing copies_printed_so_far := 0 ; ot_file_name := formatter_requested_output_file_name ; if Initial_Environment.Inp_Source = fm_database then -- we have a database reference initialize_variable_data_file ; end if ; do_purge(formatter_requested_output_file_name) ; create_output_file ( formatter_requested_output_file_name , successfull ) ; if not successfull then -- error because unable to open the output file.... error( " File """ & string_library.compress (formatter_requested_output_file_name) & """ cannot be opened." , not_fatal_error , operator_wait , short_beep ) ; raise unsuccessfull ; end if ; loop open_for_read(main_input_file,formatter_requested_input_file_name,ok); if not ok then error( " File """ & string_library.compress (formatter_requested_input_file_name) & """ does not exist." , not_fatal_error , operator_wait , short_beep ) ; raise unsuccessfull ; end if ; if Initial_Environment.Inp_Source = fm_database then Initialize_For_New_Data ( ok ) ; else ok := true ; end if ; if ok then print_a_single_document ; -- now, we have one of two situations : -- 1) We are coming from a database (and need a new record) -- 2) We are just doing a regular file if (Initial_Environment.Inp_Source /= fm_database) then -- if this is not a database access, of if Test, then test for end copies_printed_so_far := copies_printed_so_far + 1 ; -- increment the copy counter if (copies_printed_so_far >= Initial_Environment.Number_Of_Copies_to_print ) then -- we have completed each asked for copy end_output ( false ) ; printout_completed := true ; end if ; -- otherwise, we want to end at the next part end if ; else end_output ( false ) ; printout_completed := true ; end if ; was_successfull := true ; exit when printout_completed ; end loop ; end_an_entire_document ; exception when work_fatal_error_abort => -- we get here because we cannot -- print a document ... it is only -- raised by print_work. In fact, -- we cannot even get started -- trying to print the document... was_successfull := false ; end_an_entire_document ; when unsuccessfull => was_successfull := false ; end_an_entire_document ; when print_in_to_out.users_requested_abort => end_output ( true ) ; end_an_entire_document ; was_successfull := true ; printout_completed := true ; when print_out.fatal_output_error => end_output ( false ) ; end_an_entire_document ; was_successfull := false ; printout_completed := true ; end try_printing ; procedure err( s : string ) is begin close_print_work ; text_io.new_line; text_io.new_line; text_io.put_line( "Exception: " & s ) ; text_io.new_line; text_io.new_line; text_io.put ( " Type <space> to continue.... "); wait_for_character(' '); end err ; begin -- text_formatter print_package_initialize ; -- find out the type of printer attached Initial_Environment.printer_brand := permanent_printer ; Initial_Environment.printer_accessories := printer_accessories ; formatter_entry_input_file_name := source_file ; formatter_entry_output_file_name := destination_file ; formatter_requested_input_file_name := source_file ; formatter_requested_output_file_name := destination_file ; if formatter_requested_input_file_name /= no_file then -- if we can't confirm the entry parameters, then fall through -- to the loop underneath try_printing( was_successfull ) ; else loop get_options ( please_quit ) ; exit when please_quit ; try_printing ( was_successfull ) ; end loop ; end if ; close_print_work ; exception -- when user_abort => null ; when constraint_error => err("Constraint Error"); when numeric_error => err("Numeric Error"); when program_error => err("Program Error"); when storage_error => err("Storage Error"); when tasking_error => err("Tasking Error"); when others => err("Unknown Error"); end text_formatter ; begin -- print_main ; null ; end print_main ; --$$$- PRNTMAIN --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --print --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRINT with crt_customization ; with Wordp_Globals ; with printer_globals ; with print_main ; procedure print is begin print_main.text_formatter ( wordp_globals.no_file , wordp_globals.no_file , printer_globals.default_environment ) ; crt_customization.crt.do_crt(crt_customization.crt.program_termination); end print ; --$$$- PRINT --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --prntfont --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ PRNTFONT -- -- File 0xx -- -- Formatter Written By Robert S. Cymbalski -- Science Applications International Corporation -- Energy Systems Group -- Ada Software Development Project Team -- 2280 U.S. Highway 19 North, Suite 120 -- Clearwater, Florida 33575 -- -- Print Routines Revised from text Copyright (c) 1984 , R.S.Cymbalski -- with direct_io ; with text_io ; use text_io ; -- use integer_io ; -- from wicat with string_library ; use string_library ; with crt_customization ; use crt_customization ; use crt ; use editor_customization ; with crt_windows ; use crt_windows ; with Wordp_Globals ; use Wordp_Globals ; with printer_globals ; use printer_globals ; Package Print_Font_Package is subtype data_file_name is ascii_text_file_name ; procedure ADD_TYPE_FONT( NEW_TYPE_FONT_FILE : in ASCII_TEXT_FILE_NAME ; FONT_FILE : in out Data_FILE_NAME ); -- in out because it updates to complete name -- This tool adds new type font definitions to the text formatter's -- font table. It is for use by the system's manager to define new -- fonts when new device capabilities are added at a site. -- -- This routine to be implemented later, for now, use the menu... -- given in font_options Procedure Font_Options ; -- allow a menu driven selection of appropriate options end Print_Font_Package ; Package body Print_Font_Package is package Font_IO is new direct_io( Font_Type ) ; package int_io is new integer_io(integer) ; -- not for wicat use int_io ; -- not for wicat Total_Font_Numbers : constant integer := 20 ; ASCII_Font_Definition_File : text_io.file_type ; Font_Output_File : Font_IO.file_type ; Display_Status_Output_File : text_io.file_type ; print_name : constant string := "PRINTER:" ; cons_name : constant string := "CONSOLE:" ; Show_Processing_Status : constant boolean := false ; Blank_Font_Name : constant Font_Name_Type := " " ; subtype Line_Place is Integer range 0 .. 200 ; in_line : string ( Line_Place range 1 .. 200 ) ; line_length : Line_Place ; double_widths : boolean ; no_maps : map_array ; procedure put_a_line is begin crt_windows.put( ascii.cr ) ; end ; procedure put_a_line ( s : in string ) is begin crt_windows.put(s); crt_windows.put(ascii.cr); end ; Procedure Font_Initialization ( Print_Font : in out Font_Type ) is -- initialize the Print_Font record values temp_str : a_map_string ; begin Print_Font.Name := Blank_Font_Name ; Print_Font.Number := 0 ; Print_Font.vertical_points_per_inch := 0 ; Print_Font.horizontal_points_per_inch := 0 ; Print_Font.Font_Width := 0 ; Print_Font.Font_Height:= 0 ; for ind in extended_character loop -- set each character's width and hammer intensity to 0 Print_Font.width(ind) := 0 ; Print_Font.hammer_intensity(ind) := 0 ; end loop ; temp_str(2) := extended_character ( 0 ) ; temp_str(3) := extended_character ( 0 ) ; for ind in 0 .. 127 loop -- map each character to itself temp_str(1) := extended_character(ind) ; Print_Font.map_string(ind) := temp_str ; end loop ; no_maps := Print_Font.Map_String ; -- No_Maps is an item which is a standard one to one mapping.... -- we compare before saving to check to see if that has been -- modified... Print_Font.Mappings_Necessary := false ; end ; procedure put_font( Print_Font : in out Font_Type ; RecN : in integer ) is begin Font_IO.write(Font_Output_File,Print_Font,font_io.positive_count(recn)); end put_font ; procedure get_font( Print_Font : in out Font_Type ; RecN : in integer ) is begin Font_IO.Read(Font_Output_File,Print_Font,font_io.positive_count(recn)); end get_font ; Procedure CHECK_Font_FILE_EXISTS is -- check if Font_file exists , if not create a new Font_file -- in any case, open the font output file Print_font : Font_Type ; begin If not file_exists( Font_File ) then -- need to create it put_a_line ; put_a_line ; crt_windows.put(" Creating The Font File """ ) ; crt_windows.put( Font_File ) ; crt_windows.put('"'); put_a_line ; put_a_line ; Font_Initialization( Print_Font ) ; crt_windows.put(':'); Font_IO.create ( Font_Output_File , Font_IO.out_file , Font_file ) ; crt_windows.put(':'); for fontnum in 1 .. Total_Font_Numbers loop Print_Font.Number := fontnum ; put_font( Print_Font , fontnum ) ; end loop ; crt_windows.put(':'); Font_IO.close ( Font_Output_File ) ; end if ; Font_IO.open ( Font_Output_File , Font_IO.inout_file , Font_file ) ; end ; Procedure PAUSE is charin:character ; begin crt_windows.put(" Enter Space to Continue "); charin := char_or_abort(' ' , ' ') ; end ; procedure read_next_line is -- read until non-empty line or else end of file begin GET_LINE(ASCII_Font_Definition_File , in_line , line_length ) ; end; Procedure SCAN ( char : in character ; place : in out line_place ; ok_to_fail : in boolean := false ) is -- search through in_line for given char starting at place postion -- and returning found position in place found : boolean ; begin found := false ; while (not found) and (place <= line_length) loop if in_line(place) = char then found := true ; else place := place + 1 ; end if ; end loop ; If not Found then place := 0 ; if not ok_to_fail then crt_windows.put("*** error - character '") ; crt_windows.put(char) ; put_a_line("' was not found in the line being processed : ") ; for posn in 1 .. line_length loop crt_windows.put( in_line(posn) ) ; end loop ; put_a_line ; put_a_line ; end if ; end if; end ; Procedure PAST_SPACES ( place : in out Line_Place ) is -- move place in in_line past the preceeding spaces -- leaving place at the first non-space begin while ( in_line(place) = ' ' ) and ( place < line_length ) loop place := place + 1 ; end loop ; end ; Procedure Chars_To_Num ( Place : in out Line_Place ; New_Number : out Integer ) is -- change the following characters in in_line to their -- integer value num , char_value : integer ; begin past_spaces ( place ) ; num := 0 ; while ( in_line(place) >= '0' and in_line(place) <= '9' ) and ( place <= line_length ) loop char_value := character'pos(in_line(place)) - character'pos('0') ; num := ( num * 10 ) + char_value ; place := place + 1 ; end loop ; New_Number := Num ; end ; Procedure PROCESS_MAPPINGS( Print_Font : in out Font_Type ) is char1 , char2 , char3 , char4 : character ; num1 , num2 , num3 , num4 : integer ; place : Line_Place ; Procedure INITIALIZE_VARS is begin num1 := 0 ; num2 := 0 ; num3 := 0 ; num4 := 0 ; char1 := ascii.nul ; char2 := ascii.nul ; char3 := ascii.nul ; char4 := ascii.nul ; end ; Procedure PROCESS_LINE is Function READ_CHAR return character is -- return the current character in in_line and update the place return_char : character ; begin -- move past " before the character place := place + 1 ; return_char := in_line(place) ; -- move place past " after character place := place + 2 ; return return_char ; end ; Procedure CHECK_CORRES( numb : in integer ; char : in out character ) is -- check to make sure the number correspond to its -- associated character begin if (char /= ascii.nul) and ( numb /= 0 ) then if character'val(numb) /= char then -- error in correspondance skip_line; crt_windows.put("*** ASCII") ; crt_windows.put(num1 , 4 ) ; crt_windows.put(" has illegal correspondence of") ; crt_windows.put(numb , 4 ); crt_windows.put(" to"); crt_windows.put('"') ; crt_windows.put(char) ; crt_windows.put('"') ; put_a_line ( "***"); end if ; elsif (char = ascii.nul) then -- no character was in the input file for the -- associated number so find that character value char := character'val(numb) ; -- else (numb = 0 and char /= ascii.nul) -- character value already in char end if ; end ; function e ( c : character ) return extended_character is begin return extended_character ( character'pos ( c ) ) ; end e ; Procedure DO_MAP is char_temp : character ; inside_quote : boolean := false ; begin -- form the map_string entry for num1 check_corres(num2 , char2 ) ; Print_Font.map_string(num1)(1) := e ( char2 ) ; if (num3 /= 0) or (char3 /= ascii.nul) then check_corres(num3 , char3) ; Print_Font.map_string(num1)(2) := e ( char3 ) ; if (num4 /= 0) or (char4 /= ascii.nul) then check_corres(num4 , char4) ; Print_Font.map_string(num1)(3) := e ( char4 ) ; end if ; end if ; if Show_Processing_Status then crt_windows.put(" ASCII : "); crt_windows.put(num1 , 3 ); if num1 >= 32 and num1 <= 126 then crt_windows.put(" '"); crt_windows.put( character'val( num1 ) ) ; crt_windows.put("'"); end if ; crt_windows.put(" Maps to : "); for i in 1 .. 3 loop if Print_Font.map_string(num1)(i) in 32 .. 126 then -- is just a character... if not inside_quote then if i > 1 then crt_windows.put(" & "); end if ; crt_windows.put('"'); inside_quote := true ; end if ; crt_windows.put(character'val(Print_Font.map_string(num1)(i))) ; else if inside_quote then crt_windows.put('"'); inside_quote := false ; end if ; if Print_Font.map_string(num1)(i) > 0 then if i > 1 then crt_windows.put(" & "); end if ; crt_windows.put('#'); crt_windows.put(Print_Font.map_string(num1)(i)) ; end if ; end if ; end loop ; if inside_quote then crt_windows.put('"'); end if ; end if; end ; Procedure PROCESS_HAMMER_AND_WIDTH is -- obtain the hammer_intensity and width from in_line begin chars_to_num ( place , Print_Font.hammer_intensity(num1) ) ; chars_to_num ( place , Print_Font.width(num1) ) ; if double_widths then Print_Font.width(num1) := Print_Font.width(num1) * 2 ; end if ; if Show_Processing_Status then crt_windows.put( " Intensity : "); crt_windows.put(Print_Font.hammer_intensity(num1) , 2 ) ; crt_windows.put( " Width : ") ; crt_windows.put(Print_Font.width(num1) , 2 ); end if; end ; begin -- process_line place := 1 ; chars_to_num ( place , num1 ) ; past_spaces(place) ; if in_line(place) = '/' then -- skip past value between the /s place := place + 1 ; scan ( '/' , place ) ; place := place + 1 ; else char1 := read_char ; end if ; past_spaces(place) ; if in_line(place) /= '"' then chars_to_num ( place , num2 ) ; if in_line(place) = '/' then place := place + 1; chars_to_num ( place , num3 ) ; if in_line(place) = '/' then place := place + 1; chars_to_num ( place , num4 ) ; end if ; end if ; past_spaces(place) ; end if ; if in_line(place) = '"' then char2 := read_char ; past_spaces(place) ; if in_line(place) = '"' then char3 := read_char ; past_spaces(place) ; if in_line(place) = '"' then char4 := read_char ; end if ; end if ; end if ; do_map ; past_spaces(place) ; process_hammer_and_width ; if Show_Processing_Status then put_a_line ; end if ; end ; -- process_line begin -- process_mappings -- First, we need to move to a good line.... loop exit when end_of_file( ascii_font_definition_file ) ; read_next_line ; if line_length > 1 then place := 1 ; scan( '3' , place , true ) ; -- looks for 1st digit in 32 exit when place > 0 ; end if ; end loop ; loop exit when line_length <= 1 ; initialize_vars ; process_line ; read_next_line ; end loop ; Print_Font.Mappings_Necessary := Print_Font.Map_String /= No_Maps ; -- If Map_String has changed, then mappings are necessary end ; -- process_mappings Procedure READIN_Print_Font_INFORMATION is Print_Font : Font_Type ; New_File_Name : Ascii_Text_File_Name ; ok : boolean ; function get_input_file_name return ascii_text_file_name is ok : boolean ; requested_source_file : ascii_text_file_name ; begin loop clear_window( master_window ) ; goto_line_column ( master_window , 5 , 1 ) ; crt_windows.put( " Enter Font Input File Name ( or <return> to abort ) => ") ; requested_source_file := get_input_filename_or_return ; if requested_source_file = no_file then ok := true ; elsif requested_source_file( 1 ) = ascii.esc then -- an error, the file name did not exist error(" File Name """ & compress(requested_source_file ( 2 .. requested_source_file'length ) ) & """ is invalid." , not_fatal_error , operator_wait , short_beep ) ; elsif not file_exists ( requested_source_file ) then -- an error, the file name did not exist error(" File """ & compress(requested_source_file ( 2 .. requested_source_file'length ) ) & """ does not exist." , not_fatal_error , operator_wait , short_beep ) ; else ok := true ; -- because it does not exist... end if ; -- need to set the default environment exit when ok ; end loop ; return requested_source_file ; end get_input_file_name ; Procedure Get_Font_Name_And_Points_Per_Inch(Print_Font : in out Font_Type) is otplace : integer ; place : Line_Place ; num : integer ; char_value : integer ; begin -- get the print Font name from in_line found between the "s loop read_next_line ; place := 1 ; scan ( '"' , place , true ) ; exit when end_of_file( ascii_font_definition_file ) or place > 0 ; end loop ; if place > 0 then place := place + 1 ; otplace := 1 ; while in_line(place) /= '"' loop Print_Font.name(otplace) := in_line(place) ; place := place + 1 ; otplace := otplace + 1 ; exit when otplace > Font_Name_Type'Last ; end loop ; -- store the length of the name -- if Show_Processing_Status then put_a_line ; put_a_line ; crt_windows.put(" Font Name = """); crt_windows.put(Print_Font.Name); put_a_line(""""); -- end if ; -- get the points per inch for the Print_Font , found after -- the = in in_line scan ( '=' , place ) ; place := place + 1 ; chars_to_num ( place , num ) ; Print_Font.horizontal_points_per_inch := num ; Print_Font.Font_Width := num / 10 ; -- font width is 1/10" scan ( '=' , place ) ; place := place + 1 ; chars_to_num ( place , num ) ; Print_Font.Vertical_Points_Per_Inch := num ; read_next_line ; place := 1 ; scan ( '=' , place ) ; place := place + 1 ; chars_to_num ( place , num ) ; Print_Font.Number := num ; -- if Show_Processing_Status then crt_windows.put(" Horizontal Points Per Inch = ") ; crt_windows.put(Print_Font.Horizontal_points_per_inch) ; put_a_line ; crt_windows.put(" Vertical Points Per Inch = ") ; crt_windows.put(Print_Font.Vertical_points_per_inch) ; put_a_line ; crt_windows.put(" Font Number = "); crt_windows.put(Print_Font.Number); put_a_line ; put_a_line ; -- end if ; -- now working double_widths scan ( '*' , place , true ) ; double_widths := place /= 0 ; -- if a '*' is found, the double the widths when they are read in end if ; end ; Procedure SAVE_DATA ( Print_Font : in out Font_Type ) is -- save data on print Font in Font_file checking first if the -- print Font is already in the file and if so storing the new -- data over the old data rec_number : Integer := 1 ; cur_Font : Font_Type ; ok : boolean ; begin ok := false ; -- search through the file to see if print Font is already in file loop crt_windows.put('/'); get_font( Cur_Font , Rec_Number ) ; if Print_Font.name = cur_Font.name then -- put at current position where print Font was already in file put_font( Cur_Font , Rec_Number ) ; if Show_Processing_Status then put_a_line(" saving data in file "); put_a_line(" storing print Font over old Font data in file"); put_a_line ; put_a_line ; end if ; ok := true ; else rec_number := rec_number + 1 ; end if ; exit when ( cur_Font.name = blank_Font_Name ) or ok ; end loop; if not ok then -- put at end of file and make new end put_font( Print_Font , Rec_Number - 1 ) ; Print_Font.name := Blank_Font_Name ; put_font( Print_Font , Rec_Number ) ; if Show_Processing_Status then crt_windows.put(" saving data at end of file -"); put_a_line(" print Font not already in file"); put_a_line(" wrote new end to file "); put_a_line; put_a_line ; end if ; end if ; end ; begin -- readin_Print_Font_information New_File_Name := Get_Input_File_Name ; If New_File_Name /= No_File then open_for_read( ASCII_Font_Definition_File , New_File_Name , Ok ) ; If Ok Then reset(ASCII_Font_Definition_File) ; while not end_of_file( ASCII_Font_Definition_File ) loop Font_Initialization(Print_Font) ; Get_Font_Name_And_Points_Per_Inch(Print_Font) ; exit when end_of_file( ascii_font_definition_file ) ; PROCESS_MAPPINGS(Print_Font) ; -- SAVE_DATA(Print_Font) ; put_font ( Print_Font , Print_Font.Number ) ; end loop ; close ( ASCII_Font_Definition_File ) ; end if ; end if ; end ; Procedure LIST_Font_NAMES ( go_to_printer : boolean ) is rec_num : Integer := 1 ; cur_Font : Font_Type ; linenum : integer := 1 ; begin if go_to_printer then open(Display_Status_Output_File , out_file , print_name ) ; for linn in 1 .. 6 loop new_line( display_status_output_file ) ; linenum := linenum + 1 ; end loop ; else clear_window(master_window); clear_prompt(master_window); open(Display_Status_Output_File , out_file , cons_name ) ; end if ; put_line(Display_Status_Output_File , " Number Print Font Name Points"); new_line(Display_Status_Output_File) ; linenum := linenum + 2 ; for rec_num in 1 .. Total_Font_Numbers loop get_font( Cur_Font , rec_num ) ; if cur_Font.name /= Blank_Font_Name then put(Display_Status_Output_File , integer(rec_num) , 5 ) ; put(Display_Status_Output_File , " ") ; put(Display_Status_Output_File , cur_Font.name ) ; put(Display_Status_Output_File , " " ) ; put(Display_Status_Output_File,cur_Font.horizontal_points_per_inch,3); put(Display_Status_Output_File , " " ) ; put(Display_Status_Output_File,cur_Font.vertical_points_per_inch, 3) ; new_line(Display_Status_Output_File) ; linenum := linenum + 1 ; end if ; end loop ; if go_to_printer then while linenum <= 66 loop new_line ( display_status_output_file ) ; linenum := linenum + 1 ; end loop ; else for i in 1 .. 3 loop new_line(Display_Status_Output_File) ; end loop ; end if ; close ( Display_Status_Output_File ) ; new_line ; if not go_to_printer then pause ; end if ; end ; Procedure LISTFont ( Physical_Font_Number : integer ; go_to_printer : boolean ) is Print_Font : Font_Type ; linenum : integer ; print_line : integer := 1 ; Procedure DOHEADING is begin if go_to_printer then for linn in 1 .. 6 loop new_line( display_status_output_file ) ; print_line := print_line + 1 ; end loop ; else new_line(Display_Status_Output_File ) ; new_line(Display_Status_Output_File ) ; end if ; put(Display_Status_Output_File , " Print Font Name = """ ) ; put(Display_Status_Output_File , Print_Font.name ) ; put(Display_Status_Output_File , """ Points="); put(Display_Status_Output_File , Print_Font.Horizontal_points_per_inch ) ; put(Display_Status_Output_File ," "); put(Display_Status_Output_File , Print_Font.Vertical_points_per_inch ) ; new_line(Display_Status_Output_File ) ; new_line(Display_Status_Output_File ) ; print_line := print_line + 2 ; put(Display_Status_Output_File , "ASCII CHARACTER MAP-ASCII MAP-CHARACTER "); put_line(Display_Status_Output_File , "HAMMER WIDTH"); new_line(Display_Status_Output_File) ; print_line := print_line + 2 ; linenum := 7 ; end ; Procedure SHOWLINE( c_num : in integer ) is begin put(Display_Status_Output_File , " " ) ; put(Display_Status_Output_File , c_num , 3 ) ; put(Display_Status_Output_File , " """ ) ; put(Display_Status_Output_File , character'val(c_num)) ; put(Display_Status_Output_File , """ " ) ; put(Display_Status_Output_File , " " ) ; put(Display_Status_Output_File , Print_Font.map_string(c_num)(1) ) ; put(Display_Status_Output_File , " " ) ; put(Display_Status_Output_File , '"' ) ; put(Display_Status_Output_File , character'val( Print_Font.map_string( c_num)(1) ) ) ; put(Display_Status_Output_File , """ " ) ; put(Display_Status_Output_File , Print_Font.hammer_intensity(c_num) ) ; put(Display_Status_Output_File , " " ) ; put(Display_Status_Output_File , Print_Font.width(c_num) ) ; new_line( Display_Status_Output_File ) ; print_line := print_line + 1 ; end ; begin if go_to_printer then open(Display_Status_Output_File , out_file , print_name ) ; else open(Display_Status_Output_File , out_file , cons_name ) ; end if ; get_font( Print_Font , Physical_Font_Number ) ; DOHEADING ; FOR CHARNUM in 32 .. 126 loop showline(charnum) ; linenum := linenum + 1 ; if go_to_printer then -- do printer line number work if print_line > 60 then while print_line < 67 loop new_line ( display_status_output_file ) ; print_line := print_line + 1 ; end loop ; print_line := 1 ; doheading ; end if ; elsif ( linenum > 24 ) then PAUSE ; DOHEADING ; end if ; end loop ; if go_to_printer then while print_line < 67 loop new_line ( display_status_output_file ) ; print_line := print_line + 1 ; end loop ; else for i in linenum .. 24 loop new_line(Display_Status_Output_File) ; end loop ; end if ; close(Display_Status_Output_File) ; if not go_to_printer then pause ; end if ; end ; Procedure DELETE_Font( Fontnum : in integer ) is index : integer ; Print_Font : Font_Type ; begin get_font( Print_Font , Fontnum ) ; if Print_Font.name = Blank_Font_Name then raise end_error ; end if ; clear_window( master_window ) ; clear_prompt( master_window ) ; goto_line_column ( master_window , 5 , 3 ) ; crt_windows.put(" Deleting """) ; crt_windows.put( Print_Font.Name ) ; crt_windows.put(""" which is Physical Font # "); crt_windows.put(Fontnum); index := Fontnum ; Loop get_font( Print_Font , Index + 1 ) ; exit when Print_Font.name = blank_font_name ; goto_line_column( master_window , 10 , 3 ) ; crt_windows.put( "Moving """) ; crt_windows.put( Print_Font.Name ) ; crt_windows.put(""" which was Physical Font # "); crt_windows.put(Index+1); crt_windows.put(" to Font # "); crt_windows.put(Index); Put_Font( Print_Font , Index ) ; index := index + 1 ; end loop ; -- Lastly, put end of file marker on... put_font( Print_Font , Index ) ; pause ; exception when end_error => new_line ; crt_windows.put( " no print Font exits with the number : "); crt_windows.put( Fontnum ) ; new_line ; pause ; end ; procedure ADD_TYPE_FONT( NEW_TYPE_FONT_FILE : in ASCII_TEXT_FILE_NAME ; FONT_FILE : in out Data_FILE_NAME ) is -- This tool adds new type font definitions to the text formatter's -- font table. It is for use by the system's manager to define new -- fonts when new device capabilities are added at a site. begin -- add_type_font check_font_file_exists ; Font_IO.close(font_output_file ) ; end add_type_font ; procedure err( s : string ) is c : character ; begin put_a_line; put_a_line; crt_windows.put( "Exception: " & s ) ; put_a_line; put_a_line; put_a_line; crt_windows.put ( " Type <space> to continue.... "); c := char_or_abort( ' ' , ' ' ) ; end err ; procedure print_all is -- print a copy of all information ... Print_Font : Font_Type ; begin -- print_all List_Font_Names ( True ) ; for fontnum in 1 .. total_font_numbers loop get_font ( Print_Font , fontnum ) ; If Print_Font.Name /= Blank_Font_Name then -- we want to show it... listfont( fontnum , true ) ; end if ; end loop ; end print_all ; Procedure Font_Options is -- allow a menu driven selection of appropriate options User_Option : character ; Physical_Font_Number : Font_Number ; begin -- Font_Options check_font_file_exists ; loop clear_window( master_window ) ; clear_prompt( master_window ) ; goto_line_column( master_window , 2 , 1 ) ; put_a_line(" Print Font Information Set-up and Listing Program ") ; put_a_line ; put_a_line(" I : Input new information on Print Fonts "); put_a_line(" P : Print Information on a Font "); put_a_line(" L : List Information on a Font "); put_a_line(" V : View Print Font List "); put_a_line(" Y : Print Print Font List "); -- put_a_line(" D : Delete a Specific Font "); put_a_line(" C : Print Complete List of All Information "); put_a_line; put_a_line(" Q : Quit "); put_a_line; crt_windows.put( " Enter Option ? ") ; User_Option:=char_or_abort('Q', 'I' , 'P' , 'L' , 'V' , 'Y' , 'Q' -- , 'D' , 'C' ); if User_Option /= 'Q' then if User_Option = 'D' or User_Option = 'L' or User_Option = 'P' then put_a_line ; crt_windows.put(" Enter Number of Print Font => ") ; physical_font_number := get_number( 0 , 0 , 1 , 50 , 2 , 0 ) ; end if ; case User_Option is when 'V' | 'Y' => LIST_Font_NAMES(User_Option = 'Y' ) ; when 'I' => READIN_Print_Font_INFORMATION ; when 'P' | 'L' => LISTFont(Physical_Font_Number, User_Option = 'P' ) ; when 'D' => DELETE_Font(Physical_Font_Number) ; when 'C' => Print_All ; when others => null ; end case ; end if ; exit when User_Option = 'Q' ; end loop ; Font_IO.close( font_output_file ); exception -- when user_abort => null ; when constraint_error => err("Constraint Error"); when numeric_error => err("Numeric Error"); when program_error => err("Program Error"); when storage_error => err("Storage Error"); when tasking_error => err("Tasking Error"); when others => err("Unknown Error"); end Font_Options ; begin -- Print_Font_Package null ; end Print_Font_Package ; --$$$- PRNTFONT --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --font --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --$$$+ FONT with crt_customization ; use crt_customization ; with print_font_package ; use print_font_package ; procedure font is begin font_options ; crt.do_crt(crt.program_termination); end font ; --$$$- FONT