⟦a14f8c30e⟧

TextFile

integer procedure næste_symbol(tegn_værdi);
integer tegn_værdi;
begin
integer tegn_klasse;
tegn_klasse := readchar(in,tegn_værdi);
næste_symbol := tegn_værdi;
if test(1) then write(out,<:<10>*****T1 (næste symbol) = ':>,
                      false add tegn_værdi,1,"'",1);
end næste_symbol;

real procedure næste_tal(værdi);
<******************************>
real værdi;
begin
integer tegn_værdi,tegn_klasse;         
real akumulation, position;
akumulation := 0.0;
position := 10;
for tegn_klasse := readchar(in,tegn_værdi) while tegn_klasse = 2 do
  begin
  akumulation := akumulation* position + (tegn_værdi - '0'); 
  end;

if tegn_klasse = 4 then
  begin
  position := 0.1;
  for tegn_klasse := readchar(in,tegn_værdi) while tegn_klasse = 2 do
    begin
    akumulation := akumulation + (position * (tegn_værdi - '0'));
    position := position * 0.1;
    end;
  end;
værdi := akumulation;
repeatchar(in);
næste_tal := værdi;
if test(1) then write(out,<:<10>*****T1: (næste_tal) = :>,
                          <<-ddddd.ddd>,værdi);
end næste_tal;

long procedure næste_ord_6(navn);
<********************************>
long navn;
begin
integer tegn_index_shift,tegn_værdi,tegn_klasse;
long pakke_navn;
pakke_navn := 0;
tegn_index_shift := 5;
for tegn_klasse := read_char(in,tegn_værdi) while tegn_klasse = 6
  or ( tegn_klasse = 2 and tegn_index_shift <> 5)   
  or tegn_værdi = 126 do
  begin
  if tegn_index_shift >= 0 and tegn_værdi <> 126 then
    pakke_navn := pakke_navn + (extend (tegn_værdi extract 8)
                  shift (8*tegn_index_shift));
  if tegn_værdi <> 126 then tegn_index_shift := tegn_index_shift - 1;
  end;
næste_ord_6 := navn := pakke_navn;
repeatchar(in);
if test(1) then
  begin
  long array test_navn(1:2);
  test_navn(1) := pakke_navn;
  test_navn(2) := 0;
  write(out,<:<10>****T1 (næste ord ) = :>,test_navn);
  end;
end næste_ord_6;

integer procedure se_fremad(næste_art);
<*************************************>
integer næste_art;
begin
<* næste_art = 0 for ny liniee(<afleveresmikkekaf se_fremad);
   næste_art = 1 for tal
   næste_art = 2 for symbol
   næste_art = 3 for ord
   næste_art = 4 bruges ikke
   næste_art = 5 for end medium *>
integer tegn_værdi,tegn_klasse;
<* standard tegn tabel *>
tegn_klasse := readchar(in,tegn_værdi);
se_fremad := tegn_værdi;
case tegn_klasse+1 of
  begin
  <* klasse 0 skip *>
  se_fremad := se_fremad(næste_art);
  
  <* illegal opfattes som 'em' *>
  begin
  næste_art := 5;
  end;

  <* klasse 2 tal *>
  begin
  næste_art := 1;
  repeat_char(in);
  end;

  <* klasse 3 symbol *>
  begin
  næste_art := 2;
  repeat_char(in);
  end;

  <* klasse 4 symbol *>
  begin
  næste_art := 2;
  repeat_char(in);
  end;

  <* klasse 5  symbol *>
  begin
  næste_art := 2;
  repeatchar(in);
  end;

  <* klasse 6 navn *>
  begin
  næste_art := 3;
  repeatchar(in);
  end;

  <* klasse 7 symbol *>
  begin
  if tegn_værdi = 'sp' then
    se_fremad := se_fremad(næste_art) 
   else
    begin
    næste_art := 2;
    repeatchar(in);
    end;
  end;

  <* klasse 8 end medium eller skip *>
  begin
  if tegn_værdi = 'em' then 
    begin
    næste_art := 5;
    repeat_char(in);
    end
   else
    se_fremad := se_fremad(næste_art);
  end;
  end alle case situationer;
<* TEST *>
if test(1) then write(out,<:<10>****T1: (næste art ) = :>,næste_art);
end procedure sefremad;

long array var_navn(1:var_max);
real array var_value(1:var_max);
<* variabel tabel navn,værdi,art
   ( art endnu ikke brugt )
   var_max angiver tabellens størelse,
   var_top sidst indsatte variabel,
   var_top vil forsvinde ved en mere avanceret
   lagrings struktur. *>
integer var_top;
integer array var_art(1:var_max);


boolean procedure ny_var(navn,værdi);
<*********************************>
value navn,værdi; long navn; real værdi;
begin
if var_top + 1 > var_max then
  ny_var := false
 else
  begin
  var_top := var_top + 1;
  var_navn(var_top) := navn;
  var_value(var_top) := værdi;
  ny_var := true;
  end;
end  ny_var;

boolean procedure find_var(navn,værdi,tab_index);
<**********************************************>
value navn; long navn; real værdi; integer tab_index;
begin
boolean fundet; integer index;
fundet := false;
for index := 0, index+1 while index < var_top  and -, fundet do
  fundet := if navn = var_navn(index+1) then true else false;
find_var := fundet;
tab_index := index;
værdi := var_value(index);
end find_var;
 
boolean procedure set_var(navn,værdi);
<************************************>
value navn,værdi; long navn; real værdi;
begin
real dummy; integer tab_index;
if find_var(navn,dummy,tab_index) then
  var_value(tab_index) := værdi
 else
   set_var := ny_var(navn,værdi);    
end set_var;

real procedure aritmetik(error_nr);                           
<*********************************>
integer error_nr;
begin
aritmetik := tildeling(error_nr);
end aritmetik;

real procedure tildeling(error_nr);
<**********************************>
integer error_nr;
begin
integer næste_art,symbol; real udtryks_værdi; long tildelings_navn;


boolean procedure find_assignment;
<********************************>
begin
find_assignment := false;
error_nr := 1;
se_fremad(næste_art);
if næste_art =  2 <* symbol_art *> then
  begin
  næste_symbol(symbol);
  if symbol = ':' <* tegn værdi 58 *> then
    begin
    se_fremad(næste_art);
    næste_symbol(symbol);
    if symbol = '=' <* tegn værdi 61 *> then
      begin
      find_assignment := true;
      error_nr := 0;
      end;
    end;
  end;
end find_assignment;

<* læs venstre siden af tildelings sætningen
   ventre siden skal have formen 
   <varnavn> := <aritmetrisk udtryk>
   hvis der ikke er nogen fejl i det <aritmetriske udtryk
   tildeles <varnavn> værdien af det <aritmetriske udtryk>
                                                          *>

error_nr := 0;
se_fremad(næste_art);
if næste_art = 3 <*navne_art *> then
  begin
  næste_ord_6(tildelings_navn);
  if find_assignment then
    begin
    udtryks_værdi := aritmetrisk_udtryk(error_nr);
    set_var(tildelings_navn,udtryks_værdi);
    end
   else
    error_nr := 7;
  end
 else
  error_nr := 1;
end tildeling;


real procedure aritmetrisk_udtryk(error_nr);
<******************************************>
integer error_nr;
begin
integer op_top, revr_top, næste_art,
        func_max, op_max, operator, gl_type, ny_type,
        val_max, op_type, symbol, index, tab_index;
integer array op_stak(1:20);
long array func_tab(1:6);
real array                reverse_polish(1:2,1:20);
long ord, assignment_ord;
integer dyadisk_plus_type, monadisk_plus_type, dyadisk_minus_type,
        monadisk_minus_type,division_type, mult_type, power_type,
        sidste_før_func_type,sin_type,cos_type,tang_type,atan_type,
        sqrt_type, abs_type, første_monadiske_type, 
        operator_type, værdi_type,
        start_niveau_type, slut_niveau_type,
        navne_art,symbol_art,tal_art;

real grad_rad_factor,værdi;
boolean fundet,slut;

procedure push_operator;
<***********************>
begin
ny_type := operator_type;
if gl_type <> operator_type or op_type > sidste_før_func_type then
  begin
  for operator := pop_op_stak while    
                 (op_type <= monadisk_minus_type and operator > 0 ) or
                 (optype = power_type and operator > mult_type ) or
                 (optype < power_type and operator > monadisk_minus_type ) do
    begin
    make_reverse_polish;
    end;
  push_op_stak(operator);
  push_op_stak(op_type);
  se_fremad(næste_art);
  end
 else
  error_nr := 2;
end  push_operator;     

procedure make_reverse_polish;
<****************************>
begin
push_revr_polish(operator,1);
end make_reverse_polish;


real procedure beregn;
<********************>
begin
integer type; real værdi, operand2;
type := pop_revr_polish(værdi);
if type < 1 <* operator type *> then
  beregn := værdi
 else
  begin
  case type of
    begin

    <* case 1 dyadisk plus *>
    beregn := beregn + beregn;

    <* case 2 monadisk plus *>
    beregn := beregn;

    <* case 3 dyadisk minus *>
    begin
    operand_2 := beregn;
    beregn := beregn - operand_2;
   end;

    <* case 4 monadisk minus *>
    beregn := - beregn;

    <* case 5 division *>
    begin
    operand_2 := beregn;
    beregn := beregn / operand_2;
    end;

    <* case 6 multiplikation *>
    beregn := beregn * beregn;

    <* case 7 potensoplyftning *>
    begin
    operand_2 := beregn;
    beregn := beregn ** operand_2;
    end;

    <* case 8 sinus *>
    beregn := sin(grad_rad_factor*beregn);

    <* case 9 cosinus *>
    beregn := cos(grad_rad_factor*beregn);

    <* case 10 tangens *>
    beregn := tan(grad_rad_factor*beregn);

    <* case 11 arctangens *>
    beregn := arctan(grad_rad_factor*beregn);

    <* case 12 kvadrstrod *>
    beregn := sqrt(beregn);
  
    <* case 13 abs *>
    beregn := abs(beregn);
    end alle case situationer;
  end;
end beregn;


integer procedure pop_op_stak;
<****************************>
begin
pop_op_stak := op_stak(op_top);
op_top := op_top - 1;
if test(3) then
  test_print_op_stak(<:<10>^^^^**** POP::>);
end pop_op_stak;

procedure push_op_stak(værdi);
<****************************>
integer værdi;
begin
op_top := op_top + 1;
opstak(optop) := værdi;
if test(3) then
  test_print_op_stak(<:<10>üüüü**** PUSH::>);
end push_op_stak;


procedure push_revr_polish(art,værdi);
<*************************************>
value art,værdi;  integer art; real værdi;
begin
revr_top := revr_top + 1;
reverse_polish(1,revr_top) := art;
reverse_polish(2,revr_top) := værdi;
if test(2) then
  test_print_revr_polish_stak(<:<10>üüüüü***** PUSH::>);
end push revr_polish;

integer procedure pop_revr_polish(værdi);
<***************************************>
real værdi;
begin
værdi := reverse_polish(2,revr_top);
pop_revr_polish := reverse_polish(1,revr_top);
revr_top := revr_top - 1;
if test(2) then 
  test_print_revr_polish_stak(<:<10>*****^^^^^ POP :>);
end pop_revr_polish;

procedure test_print_revr_polish_stak(text);
<******************************************>
string text;
begin
integer i;
write(out,text,<:<10>***T2: contents or reverse polish stak::>,
<:<10>niveau     værdi     type:>);
if revr_top > 0 then
  begin
  for i:= revr_top step -1 until 1 do
    write(out,<:<10>:>,<<__-dd__>,i,
          <<___-dddd.dd>,reverse_polish(2,i),
          <<____-ddd>,reverse_polish(1,i));
  end
 else
  write(out,<:<10> REVERSE POLISH EMPTY:>);
end test_print_revr_polish_stak;
procedure test_print_op_stak(text);
<**********************************>
string text;
begin
write(out,text,<:<10>***T3: indhold af operator stak ::>,
<:<10>  operator :>);
if op_top > 0 then
  begin
  for i := op_top step 1 until 0 do
    write(out,<:<10>:>,<<___-dd>,op_stak(i));
  end
 else
  write(out,<:<10> EMPTY :>);
end test_print_op_stak;



boolean procedure find_assignment;
<********************************>
begin
find_assignment := false;
error_nr := 1;
se_fremad(næste_art);
if næste_art = symbol_art then
  begin
  næste_symbol(symbol);
  if symbol = ':' <* tegn værdi 58 *> then
    begin
    se_fremad(næste_art);
    næste_symbol(symbol);
    if symbol = '=' <* tegn værdi 61 *> then
      begin
      find_assignment := true;
      error_nr := 0;
      end;
    end;
  end;
end find_assignment;


  
<* initialisering *>

<* initialisering af operator typer *>
dyadisk_plus_type := 1; monadisk_plus_type := 2; dyadisk_minus_type := 3;
power_type := 7;
første_monadiske_type := 6;
monadisk_minus_type := 4; division_type:= 5; mult_type := 6;
sidste_før_func_type := 7;
sintype := 8; cos_type := 9; tang_type := 10; atan_type := 11;
sqrt_type := 12; abs_type := 13;

<* initialisering af næste tegnfølges arter *>
tal_art := 1; symbol_art := 2; navne_art := 3;

<* initialisering af operator og operand typer *>
operator_type := 1; værdi_type := 2 ; <* kan være tal eller variabel *>
start_niveau_type := 3; <* start på sætning eller venstre parantes *>
slut_niveau_type := 4; <* højre parantes *>
func_max := 6;
for index := 1 step 1 until func_max do
  func_tab(index) := long ( case index of (<:sin:>,
      <:cos:>,<:tan:>,<:atan:>,<:sqrt:>,<:abs:>));
op_max := func_max + sidste_før_func_type;

grad_rad_factor := arctan(1.0)/45.0;


<* init. af stak pointere *>
op_top := 1;
revr_top := 0;
opstak(1) := 0;

ny_type := start_niveau_type;
slut := false;

error_nr := 0;
    
    <* bestemmelse af næste tegn følges art *>
    se_fremad(næste_art);
    repeat
      gl_type := ny_type;
      case næste_art of
        begin

        <* i den oprindelige version tages højde for
           at 'næste_art' kan få værdien 0, det kan den
           faktisk ikke da 'nnx' læser indtil 
           'næste_art' <> 0. tvertimod tages ikke højde
           for at 'næste_art' kan få værdien 5, end medium *>

        begin <* case næste_art = 1 behandling af tal *>
        <* i den oprindelige version tages højde for at et tal
           kan have et foranstillet minus eller plus, det
           kan ikke mere forekomme, da disse alle fanges af 
           symbol behandlingen. *>
        næste_tal(værdi);
        if gl_type <> værdi_type and gl_type <> slut_niveau_type then
          begin
          ny_type := værdi_type;
          push_revr_polish(-1,værdi);
          se_fremad(næste_art);
          end
         else
          error_nr := 6;
        end <* behandling af tal *>;

        begin <* case næste_art = 2 behandling af symboler *>
        næste_symbol(symbol);
        if symbol = ';' <* tegnværdi 49 *> then
          slut := true
         else
        if symbol = '+' <* tegnværdi 43 *> then
          begin
          op_type := if gl_type = start_niveau_type then
                         monadisk_plus_type 
                       else
                         dyadisk_plus_type;
          push_operator;
          end
         else
        if symbol = '-' <* tegnværdi 45 *> then
          begin
          op_type := if gl_type = start_niveau_type then
                        monadisk_minus_type
                       else
                        dyadisk_minus_type;
          push_operator;
          end
         else
        if symbol = '/' <* tegnværdi 47 *> then
          begin
          op_type := division_type;
          push_operator;     
          end
         else
        if symbol = '*' <* tegnværdi 42 *> then
          begin
          if se_fremad(næste_art) = '*' <* tegnværdi 42 *> then
            begin
            næste_symbol(symbol);
            op_type := power_type;
            end
           else
            op_type := mult_type;
          push_operator;
      
          end
         else
        if symbol = ')' <* tegnværdi 41 *> then
          begin
          if gl_type <> operator_type and gl_type <> start_niveau_type then
            begin
            ny_type := slut_niveau_type;
            for operator := pop_op_stak while operator > 0 do
              begin
              make_reverse_polish;
              end;
            if operator = 0 then
              error_nr := 3
             else
              se_fremad(næste_art);
            end
           else
            error_nr := 3;
          end
         else
        if symbol = '(' <* tegnværdi 40 *> then
          begin
          if gl_type <> værdi_type and gl_type <> slut_niveau_type then
            begin
            ny_type := start_niveau_type;
            push_op_stak(-1);
            se_fremad(næste_art);
            end
           else
            error_nr := 3;
          end
         else
        if symbol = '&' <* tegnværdi 38 *> then
          begin
          se_fremad(næste_art);
          if næste_art = navne_art then
            begin
            næste_ord_6(ord);
            if find_var(ord,værdi,tab_index) then
              begin
              if gl_type <> værdi_type and gl_type <> slut_niveau_type then
                begin
                push_revr_polish(-1,værdi);
                se_fremad(næste_art);
                end
               else
                error_nr := 6;
              end 
             else
              error_nr := 5;
            ny_type := værdi_type;
            end
           else
            error_nr := 5;
          end
         else
          begin
          outchar(out,symbol);
          error_nr := 4; <* ingen tilladte symboler *>;
          end;
        end <* case næste_art = 2 behandling af symboler *>;

        begin <* case næste_art = 3 behandling af functions navne *>
        næste_ord_6(ord);
        fundet := false;
        for index := 0, index + 1 while -, fundet and index  < func_max do
          fundet := if ord = func_tab(index+1) then true else false;
        if fundet then
          begin
          optype := index + sidste_før_func_type;
          push_operator;
          end
         else
          if find_var(ord,værdi,tab_index) then
            begin
            if gl_type <> værdi_type and gl_type <> slut_niveau_type then
              begin
              push_revr_polish(-1,værdi);
              ny_type := værdi_type;
              se_fremad(næste_art);
              end
             else
              error_nr := 5;
            end
           else
          error_nr := 5;
        end; <* case næste_art = 3 behandling af functioner *>

        begin <* case næste_art = 4 tom *>
        end;

        begin <* case næste_art = 5 end medium *>
        slut := true;
        error_nr := 160 <* skal rettes til noget
                           begavet *>
        end;
      end alle case situationer;
   
    until slut or error_nr <> 0;

    <* udtrykket er nu på omvent polsk form og kan beregnes *>
    if error_nr = 0 then
      begin
      for operator := pop_op_stak while operator > 0 do
        begin
        make_reverse_polish;
        end;

      if operator = 0 then
        
        begin
        if test(4) then
        test_print_revr_polish_stak(<:<10>=========== BEREGN:>);
        aritmetrisk_udtryk := beregn;
        end
       else error_nr := 3;
      end;
end aritmetik;
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦a14f8c30e⟧ TextFile

Derivation

TextFile
