⟦44ccc7d25⟧

TextFileVerbose

job jaba 9 600 size 92000 time 11 0 output 200000 perm mini 100 1
(
  platonenv = set bs bblenv
  pascal80 codelist.no stack.512 codesize.12000 spacing.12000 , 
     debugenvir ioenvir
   bprintexcep = set 1 mini
   bprintexcep = move pass6code
  if ok.yes
    scope project bprintexcep
  finis
)


process printexcept;


type
line_number_table = record
line_chain : addr;
start_line : integer;
first_delta, second_delta : byte;
end;


descriptor = record
compilation_date : coded_date;
compilation_time : coded_time;
length_of_code   : integer;
length_of_last   : integer;
last_line        : integer;
line_spacing     : integer;
start_of_chain   : addr;
end;

routine_ident = record
routine_name   : alfa;
descriptor_ptr : ^ descriptor;
end;

activation_record = record
static_link  : ^ activation_record;
dynamic_link : addr;
return_point : addr;
routine_name_ptr : ^ routine_ident;
end;




function asgnptraddr ( address_to_convert : addr ) : ^  routine_ident;
(* convert  own.plinetable from addr to pointer *)
external;


function asgnptradr  ( address_to_convert : addr ) : ^ line_number_table;
(* convert  line_number_table.line_chain from addr to pointer *)
external;


function asgnpntradr ( address_to_convert : addr ) : ^ activation_record;
(* covnert dynamic link from addr to pointer *)
external;




function ult ( a, b : integer ) : boolean;
(* compare a and b as unsigned integers *)
external;

 function getoflowmask : boolean;
(* returns the current value of suppress overflow flag *)
external;

procedure setoflowmask ( overflow : boolean );
(* assigns the new  suppress overflow mask *)
external;

const
no_overflow = true;
doomsday = false;
op_top = 5; (* number of words from stack to reserve *)
addr_length = 2; (* words !! *)
nul_address = addr(base_type(0, 0, 0, 0, 0), 0);



var
lf, lf_help, gf : addr;
routine_id : alfa;
temp_addr,
ic : addr;
descriptor_pointer : ^ descriptor;
routine_name_pointer : ^ routine_ident;
stack : reference;
cause_text : alfa;
tto_level : byte;
operands : array ( 0 .. op_top ) of integer; (* four topmost stack words after exception *)
last_used : integer; (* index of stacktop in operands, temporary !!!! *)
(* last_used may be a constant = op_top in the next revision of the microprogram !!!!!!!!!!! *)
opcode : byte;
step, excode : integer;






function usub ( a, b : integer ) : integer;
var
overflow : boolean;
begin
overflow := getoflowmask;
setoflowmask( no_overflow );
usub := a - b;
setoflowmask( overflow );
end;


function uadd ( a, b : integer ) : integer;
var
overflow : boolean;
begin
overflow := getoflowmask;
setoflowmask( no_overflow );
uadd := a + b;
setoflowmask( overflow );
end;


procedure printtext24 ( str24 : array ( 1 .. 24 ) of char );
var
step : integer;

begin
step := 1;
while str24 ( step ) <> '#' do
begin
printchar ( str24 ( step ) );
if step = 24 then str24 ( 24 ) := '#' else step := step + 1;
end;
end; (* printtext24 *)




procedure print_called_from( routine_name : alfa; where : addr );

const
max_line = 255; (* pass6 dependent !!!! *)

var
first_addr, top_addr, top_of_next : addr;
old_first_addr_disp, top_addr_disp : integer;
found : boolean := false;
last_page : boolean := false;
line_tab_ptr : ^ line_number_table;
line, line_increment, spacing : integer;

begin
printtext('called from:');
printchar(' ');
printtext( routine_name );
printtext(', ic = #    ');
printaddr( where );
printtext(', line #    ');

(* now compute the line interval *)

with descriptor_pointer ^ do
begin
top_addr := start_of_chain;
spacing := line_spacing;
end; (* with *)

repeat
line_tab_ptr := asgnptradr ( top_addr );
top_of_next := line_tab_ptr ^ . line_chain;

first_addr.base := top_addr.base;

if top_of_next = top_addr then
begin (* last page of code *)
first_addr.disp := usub ( top_addr.disp, descriptor_pointer^.length_of_last);
last_page := true;
end
else
first_addr.disp := usub ( top_addr.disp, descriptor_pointer^.length_of_code );

if (ult( first_addr.disp, where.disp ) and ult( where.disp, top_addr.disp )
and (first_addr.base = where.base))
or (first_addr = where) then
begin (* the page has been found *)
found := true;

line := line_tab_ptr^. start_line;
top_addr_disp := top_addr.disp;

old_first_addr_disp := first_addr.disp;

while ult( first_addr.disp, where.disp ) 
and not ult(first_addr.disp, old_first_addr_disp ) do
begin (* find lower line number of interval *)
with first_addr do
begin
old_first_addr_disp := disp;
disp := uadd ( disp, spacing );
end; (* with *)

line := line + line_tab_ptr^.first_delta;

(* now move the line table pointer in order to let first_delta be next delta *)
with top_addr do
disp := uadd( disp, 1 );
line_tab_ptr := asgnptradr ( top_addr );

end;

printnumber ( line, 1 );
printchar ('-');

(* find upper line number *)

repeat (* find first delta less than max line *)
line_increment := line_tab_ptr^.first_delta;
line := line + line_increment;
with first_addr do
begin
old_first_addr_disp := disp;
disp := uadd( disp, spacing);
end; (* with *)

(* advance line_tab_ptr, i.e. let first_delta be next delta *)
with top_addr do
disp := uadd( disp, 1 );
line_tab_ptr := asgnptradr ( top_addr );

until (line_increment <> max_line)  (* i.e. 'real' linenumber ' *)
or not ult (first_addr.disp, top_addr_disp) (* i.e. passed top *)
or ult (first_addr.disp, old_first_addr_disp) (* i.e. wrap-around... *)
;

if line_increment = max_line then
begin (* upper line number is first line of next page ! *)
if last_page then
line := descriptor_pointer^.last_line
else
line := asgnptradr( top_of_next ) ^ . start_line;

end;

printnumber( line, 1 );

end  (* printing interval *)


else


(* try the next page *)
top_addr := top_of_next;


if last_page and not found then
begin
printtext('not found, i'); printtext('c = #       ');
printaddr(where);
found := true;
end;

until found;

end; (* print called from *)






procedure print_date( date : coded_date );

begin
with date do
begin
printnumber( year_after_1900 + 1900, 7);
printchar('.');
if month < 10 then printchar('0');
printnumber( month, 1);
printchar('.');
if day < 10 then printchar('0');
printnumber( day, 1 );
end;
end;



procedure print_time ( time : coded_time );
begin
with time do
begin
printchar( ' ' );
if hour < 10 then printnumber( 0 , 1 );
printnumber ( hour , 1 );
printchar( '.' );
if minute < 10 then printnumber( 0, 1 );
printnumber( minute , 1 );
end; (* with *)
end;








begin


repeat
wait ( stack, own.secret_pointer^ ( exceptionsem ) ^ );

readram( tto_level, 1 );  (* remember interrrupt level *)
writeram( 1, 0 ); (* clear interrupt level *)

lock stack as own : ext_incarnation_descriptor do
begin

gf := stack ^ . start; (* even displacement !! *)
lf.base := gf.base; (* local frame and global frame is in the same memory module *)
lf.disp := own.dumpsf (* odd displacement *)  - 1; (* even displacement !! *)


(* detect how the procedure was entered, i.e. find out
whether the call was caused by an exception or it was
a programmed activation of the trace procedure *)

if (stack^ . u1 <> 0) or (own . exic = nul_address) then
(* trace *)
begin
ic := asgnpntradr ( lf ) ^ . return_point;
cause_text := 'trace #     ';
last_used := op_top - 1; (* optop is the parameter of trace *)
end
else
begin
ic := own.exic;
cause_text := 'exception # ';
last_used := op_top - 2; (* nb the parameter and the resume bit is pushed on top before call 
of the exception procedure !!!!!! *)

lf_help := asgnpntradr( lf ) ^ . dynamic_link;
lf_help . disp := lf_help . disp - 1; (* even address *)
if lf_help <> gf then
if asgnpntradr( lf_help ) ^ . routine_name_ptr ^ . routine_name = 'exception' then
begin (* system exception activated from user defined exception procedure *)
(* i.e. unstack routine level for exception procedure *)
lf := lf_help;
end;

end;

(* print process name and cause *)
printnl;
printtext ( asgnptraddr ( own.plinetable ) ^ . routine_name );
printtext ( '>> #        ' );
printtext ( cause_text );
printtext ( ', excode = #' );
with stack ^ do
if u2 >= 128 then
excode := (u2 - 128) * 256 + (- 32768) + u3
else
excode := u2 * 256 + u3;
printhex( excode );
printchar(':'); printchar(' ');

(* get the opcode and the op_top top operands *)
temp_addr := lf; (* lf is a pointer to the bottom of the frame
pushed on the frame which caused the exception, i.e.
lf.disp - 2 is address of topoperand ... *)

for step := op_top downto 0 do
begin
with temp_addr do
disp := usub ( disp, 2 );
getinteger ( operands ( step ), temp_addr );
end; (* for ... *)

getbyte ( opcode, ic );   (* 'revsb 0 ' *)




if cause_text = 'exception # ' then

case excode of
1: printtext24 ( 'signal: reference = nil ');

5: begin
   printtext24 ( ' reference = nil ' );
end;

6: printtext24 ( 'not channel message #   ');

8: printtext24 ( 'not data message #      ');

9: printtext24 ( 'size too small#         ');

#ha: printtext24 ( 'last < first #          ');

#hb: begin
printtext24 ( 'arithmetic overflow : # ');

if (opcode <> #h50) and (opcode <> #h51) then
printnumber ( operands ( last_used - 1 ) , 1 );
case opcode of
#h50: (* monadic minus *) printchar ( '-' );
#h51: (* abs           *) printtext ( 'abs #       ' );
#h44, #h42: (* add, uadd     *) printchar ( '+' );
#h45, #h43: (* sub, usub     *) printchar ( '-' );
#h49, #h46: (* mul, umul     *) printchar ( '*' );
#h4a, #h47: (* div, udiv     *) printtext ( ' div #      ' );
#h4b, #h48: (* mod, umod     *) printtext ( ' mod #      ' );
otherwise 
printchar ( "'" );
printhex ( opcode );
printchar ( "'" );
end; (* otherwise *)
printnumber ( operands ( last_used ), 1 );
end; (* #hb ... *)

#hc: (* index exception *)
begin
printtext24 ( 'index out of bounds: #  ' );
(* top of stack: index value, addr_of ( dope vector ) *)
(*         note: when after 'store in packed array': also 'value' to be stored *)
printnumber ( operands ( last_used - addr_length - ord ( opcode = #h6f (* inpss *) ) ), 1 );
end; (* #hc ... *)

#h10: printtext24 ( 'stack overflow #        ' );

#h11: (* range exception *)
begin
printtext24 ( 'subrange out of bounds: ');
(* top of stack: range value, addr_of ( range descriptor ) *)
printnumber ( operands ( last_used - addr_length ), 1 );
end; (* #h11 ... *)

#h12: printtext24 ( 'pointer = nil #         ' );

#h20..#h23: printtext24 ( 'shadow = nil #          ' );

#h15: printtext24 ( 'identical arguments #   ' );

#h7: printtext24( 'block i/o at level 0 #');

#h1a: printtext24( 'wait : reference <> nil #');

#h1f: printtext24 ( 'no core #               ' );

#h16, #h19: printtext24 ( 'second param locked  ' );

#h17: printtext24 ( 'first param <> nil      ' );

#h18: printtext24 ( 'second param = nil      ' );

#h13: printtext24 ( 'first param = nil       ' );

#h14: printtext24 ( 'first param not empty   ' );

#h1b: printtext24 ( 'reference locked' );

#h1c: printtext24 ( 'not data message #      ' );

#h1d: printtext   ( 'size error #' );

#h1e: begin
printtext24 ( 'multible wait on locked' );
printtext ( ' semaphore' );
end;

#h24: begin
      printtext24 ( 'illegal switch in case c' );
printtext ( 'onstruction ' );
end;

#h25: begin
      printtext24 ( 'upper limit in call of s' );
printtext ( 'ucc #       ' );
end;

#h26 : begin
      printtext24 ( 'lower limit in call of p' );
printtext ( 'red #       ' );
end;


#h29: begin
      printtext24 ( 'local reference variable' );
      printtext24 ( ' not nil at routine exit' );
end;

otherwise
if (excode > 0) and (excode <= #h2f) then
printtext ( 'system error' );
end; (* case excode of ... *)


printnl;
printtext ( 'gf = #      ' );  printaddr ( gf );
printtext ( ' , top = #   ' );  printaddr ( lf );
printtext ( ' , code = # ' );  printhex ( opcode );


printnl; printnl;



while lf <> gf do
begin
lf := asgnpntradr ( lf ) ^ .dynamic_link; (* odd displacement *)
lf.disp := lf.disp - 1; (* even displacement !!! *)

if lf = gf then
begin
routine_id := own.incname;
descriptor_pointer := asgnptraddr( own.plinetable) ^ .descriptor_ptr;
end
else
begin
routine_name_pointer := asgnpntradr( lf ) ^ . routine_name_ptr;
with routine_name_pointer ^ do
begin
routine_id := routine_name;
descriptor_pointer := descriptor_ptr;
end;
end;


print_called_from ( routine_id, ic );
print_date ( descriptor_pointer^.compilation_date );
print_time ( descriptor_pointer^.compilation_time );
printnl;

ic := asgnpntradr ( lf ) ^ .return_point;

end; (* while lf <> gf *)


end; (* lock *)

printnl;

writeram( 1, tto_level ); (* reestablish interrupt level *)
printchar ( nul ); (* force interrupt *)

return ( stack );

until doomsday;


end (* process printexcept *)


.
«eof»
DataMuseum.dk

RC3500

⟦44ccc7d25⟧ TextFileVerbose

Derivation

TextFileVerbose
