⟦cbd746e89⟧

TextFile

program rtp35022p6(input,output,code);\r
uses rtpunit, dos;\r
\r
(* if used as an asembler the call is:\r
\r
<code file> = rtp35022p6 <option list> <source file>\r
\r
<code file>        object file, default name is rtppass6.cod\r
<source file>      default name is rtppass5.cod\r
\r
.                                                     *\r
<option list> ::= ( <option> . <yes or no or number> )\r
\r
.                              default         meaning\r
\r
<option> ::= list              ( no )      list the input\r
.          ! test              ( no )      generate test output\r
.          ! codesize          ( 512 )     size of a program page\r
.          ! print             ( no )      print the generated code\r
.          ! errormess         ( no )      list erroneus lines\r
.          ! nametable         ( no )      list the nametable at blockends\r
.          ! spacing           ( 52 )      line table spacing\r
.          ! statistics        ( no )      generate op-code statistics\r
.          ! lineinfo          ( yes )     generate line information\r
.          ! preserve          ( no )      preserve pass5code\r
\r
\r
<yes or no or number> ::= yes  ! no  ! <number>\r
\r
\r
\r
\r
*)\r
\r
(*$M 25000,0,655360*)\r
(*$R+*)\r
\r
type\r
text_buf_type = array[1..1024] of char;\r
\r
var exitsave: pointer;\r
in_buf_ptr: ^text_buf_type;\r
\r
(*$I p6init *)\r
(*$I p6rest *)\r
\r
\r
(******************************************************************)\r
(******************************************************************)\r
(***************       main program of pass6 **********************)\r
(******************************************************************)\r
(******************************************************************)\r
\r
\r
\r
begin\r
\r
initialization;\r
\r
init_between_code_blocks;\r
\r
read_environment;\r
\r
readcall;\r
\r
if test then\r
writeln(output, cur_date, cur_time, version: 50, ' (', pass6_version, ')');\r
\r
token:= get_next_token;\r
\r
while token <> endprogram do\r
begin\r
\r
while token <> blockbegin do    (*  ---->------------> start block --->  *)\r
  case token of                 (*      !            !                  *)\r
    source_line_number : handle_line; (*!<-- nl <----!                  *)\r
    comment : token:= get_next_token;(*!            !                  *)\r
    option : read_options;      (*      !<- option <--                  *)\r
endprogram: goto 9998;  (* no more sources *)\r
else\r
begin\r
markerror( 16 ); (* syntax error *)\r
token:= get_next_token ;\r
end;\r
end; (* case *)\r
\r
if generate_line_info then\r
emit_start_of_line_table;\r
\r
\r
read_declaration;    (* start block *)\r
\r
\r
while token = source_line_number do handle_line;\r
\r
if token = option then\r
read_options;   (* maybe option( open routine )    *)\r
\r
if program_kind = closed_routine then\r
begin\r
\r
while token <> startdescr do\r
\r
case token of\r
\r
blockbegin : read_declaration;\r
\r
blockend   : unstack_level;\r
\r
constbegin : handle_constant;\r
\r
line_table  : handle_linetable;\r
\r
source_line_number : handle_line;\r
\r
labeldef   : update_symbol;\r
\r
constdef   : update_symbol;\r
\r
comment    : (* do nothing *) token:= get_next_token;\r
\r
symbol     : (* must be an op_code *) handle_code;\r
\r
option     : read_options;\r
\r
other:\r
begin\r
if eof(input) then\r
begin\r
markerror( 13 ) ; (* premature end of file *)\r
token:= startdescr;  (* exit code handling *)\r
end;\r
end; (* other *)\r
\r
\r
end; (* case *)\r
\r
\r
(* prepare internal linking of short jumps out of the segment *)\r
fill_in_jumps;\r
\r
if generate_line_info then\r
begin\r
\r
(* move the last line table to end-of-code *)\r
if current_offset <> start_of_line_table then\r
begin\r
help:= current_offset;\r
for step:= start_of_line_table to next_line_table_entry - 1 do\r
begin\r
code_buffer [ current_offset ]:= code_buffer [ step ];\r
current_offset:= current_offset + 1;\r
end;\r
start_of_line_table:= help;\r
next_line_table_entry:= current_offset;\r
\r
(* initialize current line record before the internal linking is performed *)\r
with current_line_record ^ do\r
begin\r
def_segment:= current_segment;\r
def_offset:= start_of_line_table;\r
kind:= label_def;\r
\r
(* prepare add_unsatisfied_node ... *)\r
current_offset:= start_of_line_table;\r
(* let the successor of last line record be itself *)\r
use_chain:= add_unsatisfied_node ( use_chain, false,addrsize );\r
\r
end;\r
\r
end;\r
(* adjust current offset to be first byte after the line table *)\r
code_buffer [next_line_table_entry+1 ]:= 0; (* zero fill possible dummy byte  *)\r
(* code buffer [ next line table entry ] will be assigned a terminating line\r
add in procedure outcode !!!!  *)\r
(*$R-*)\r
current_offset:= next_line_table_entry div 2 * 2 + 2; (* start of next word *)\r
\r
last_page:= true;\r
\r
(* in case of alignment rem_buffer_size is not correct, therefore *)\r
rem_buffer_size:= segment_size + 1 - current_offset - longjump_size;\r
(*$R+*)\r
\r
(* initialize the constants length_of_last_segment and last_line_number *)\r
\r
with length_of_last_segment ^ do\r
begin\r
def_segment:= 1; (* defined *)\r
def_offset := start_of_line_table;\r
kind:= constant_def;\r
next_name:= internal_link_list;\r
internal_link_list:= length_of_last_segment;\r
end;\r
\r
with last_line_number ^ do\r
begin\r
def_segment:= 1; (* defined *)\r
def_offset := current_source_line;\r
kind:= constant_def;\r
next_name:= internal_link_list;\r
internal_link_list:= last_line_number;\r
end;\r
\r
end; (* line table handling *)\r
\r
end (* closed routine or process *)\r
else\r
begin\r
(* open routine *)\r
(* room for jump to next page and a line table is not needed *)\r
rem_buffer_size:= rem_buffer_size + longjump_size + line_table_size;\r
start_of_line_table:= 0; (* emitcode will not reserve room for linetables *)\r
while token <> startdescr do\r
\r
case token of\r
\r
option: read_options;\r
\r
comment,\r
source_line_number: begin\r
(* skip the line *)\r
lineindex:= linelength;\r
token:= get_next_token;\r
end;\r
\r
other: begin\r
markerror( 13 );  (* premature end of code *)\r
token:= startdescr; (* force exit of  while  <> startdescr ... *)\r
end;\r
\r
\r
else\r
\r
begin\r
if token = symbol then\r
begin\r
check_open_code:= find_code;  (* check legal opcode *)\r
lineindex:= linelength; (* skip paramerters and comments *)\r
end\r
else\r
if (token = blockbegin) or (token = constdef) then\r
lineindex:= linelength; (* skip the remaining part of the line,\r
it is not checked if the declaration is terminated correct *)\r
if not printed then\r
begin\r
printed:= true;\r
line [ linelength + 1 ]:= ';';\r
(* always an even number of characters per line *)\r
step:= -1;\r
repeat\r
step:= step + 2;\r
if rem_buffer_size < 2 then\r
begin\r
emitcode(false);\r
rem_buffer_size:= rem_buffer_size + longjump_size\r
end;\r
rem_buffer_size:= rem_buffer_size - 2;\r
if line [ step - 1 ] = ' ' then  (* nb line [ 0 ] = ' '  *)\r
begin (* state :  after space(s) *)\r
while line [ step ] = ' ' do step:= step + 1; (* skip *)\r
if line [ step ] = ';' then goto 9997; (* drop trailing blanks *)\r
end\r
else\r
if line [ step ] = ' ' then\r
(* state : start of space(s)  *)\r
begin\r
while line [ step + 1 ] = ' ' do step:= step + 1; (* skip *)\r
if line [ step + 1 ] = ';' then (* drop trailing blanks *)\r
goto 9997; (* end of line action, buffer room has been reserved *)\r
end;\r
outword( ord( line [ step ] ) * maxbyte +\r
ord( line [ step + 1 ] ) );\r
until (line [ step + 1 ] = ';') or (line [ step + 2 ] = ';') ;\r
\r
\r
if rem_buffer_size < 2 then\r
begin\r
emitcode(false);\r
rem_buffer_size:= rem_buffer_size + longjump_size;\r
end;\r
\r
rem_buffer_size:= rem_buffer_size - 2;\r
9997: outword( ord(' ') * maxbyte + 10 );\r
end; (* copy line *)\r
\r
token:= get_next_token;\r
\r
end; (* otherwise *)\r
end; (* case *)\r
\r
\r
end; (* open routines *)\r
\r
handle_descriptor_block;\r
\r
insert_constants;\r
init_between_code_blocks; (* prepare next code block  *)\r
\r
while token = source_line_number do handle_line;\r
\r
end;   (* while token <> endprogram *)\r
9998:  (* no more input modules, terminate pass6 *)\r
\r
if codelist and not printed then printline; (* output the last line *)\r
\r
blockwrite( code, end_of_code, 2 ); (* end of code mark *)\r
\r
if object_code_file_opened then\r
begin\r
close(code);\r
end;\r
\r
if not preserve_option then\r
begin\r
close(input);\r
erase(input);\r
close(codefile);\r
assign(codefile, concat(path1_name, o_pass6_workname));\r
erase(codefile)\r
end;\r
\r
end; (* rtp pass6 *)\r
\r
\r
(*$F+*) procedure myexit; (*$F-*)\r
begin\r
\r
exitproc := exitsave;\r
\r
if exitcode = 0 then\r
begin\r
\r
if errorcount > 0 then printerrors else writeln;\r
\r
end;\r
\r
runtime_error('end of REAL-TIME PASCAL compilation for RC3502/2');\r
\r
end;\r
\r
procedure survey_out;\r
var cur_clock: datetime;\r
    cur_packed_time, start_packed_time: longint;\r
    heapfree: longint;\r
begin\r
\r
getclock(cur_clock);\r
packtime(cur_clock, cur_packed_time);\r
packtime(start_clock,start_packed_time);\r
unpacktime(cur_packed_time - start_packed_time, cur_clock);\r
\r
writeln(output);\r
writeln(output, 'Information survey from ', version);\r
writeln(output, 'Max number of active labels:                 ',\r
survey_name_nodes);\r
writeln(output, 'Max number of labels at one instruction:     ',\r
survey_cur_label_nodes);\r
writeln(output, 'Max number of unsolved interdependencies:    ',\r
survey_dependence_nodes);\r
writeln(output, 'Deepest block nesting:                       ',\r
survey_level_nodes);\r
writeln(output, 'Max number of unsolved jumps:                ',\r
survey_jump_nodes);\r
writeln(output, 'Max number of unsolved references:           ',\r
survey_unsat_nodes);\r
writeln(output, 'Greatest case table or structured constant:  ',\r
survey_greatest_const);\r
write  (output, 'Elapsed time (hours.minutes.seconds):        ');\r
if cur_clock.hour < 10 then write(output, '0');\r
write  (output, cur_clock.hour: 1, '.');\r
if cur_clock.min  < 10 then write(output, '0');\r
write  (output, cur_clock.min : 1, '.');\r
if cur_clock.sec  < 10 then write(output, '0');\r
writeln(output, cur_clock.sec : 1);\r
heapfree := memavail;\r
release(heaporg);\r
writeln(output, 'Heep space used in bytes:                    ',\r
                memavail - heapfree);\r
\r
writeln(output);\r
\r
end;\r
\r
begin\r
\r
exitsave    := exitproc;\r
exitproc    := @myexit;\r
\r
close(input);\r
new(in_buf_ptr);\r
\r
end_of_code := 0;\r
\r
assign(codefile, concat(path1_name, o_pass6_workname));\r
new(code_buffer_ptr);\r
\r
date(cur_date);\r
time(cur_time);\r
\r
pass6(code_buffer_ptr^);\r
\r
\r
if survey_info then\r
begin (* output information about use of dynamic structures *)\r
survey_out;\r
end; (* survey information *)\r
\r
\r
\r
writeln;\r
writeln(output,' code: ', descr1 [ 1 ] - 1 : 1, ' . ', descr1 [ 3 ] : 1,\r
                '  = ', ( descr1 [ 1 ] - 1 ) * (segment_size + 1)\r
                        + descr1 [ 3 ] : 1, ' bytes');\r
\r
\r
end.\r
«eof»
DataMuseum.dk

DANOSI

⟦cbd746e89⟧ TextFile

Derivation

TextFile
