ADA Programming Guide/ADA Programming Guide.iso/ada_pcdp/adas/interp.pas

Pascal/Delphi Source File | 1996-01-30 | 19.9 KB | 634 lines

unit interp;

  { AdaS interpreter }

interface
uses crt,global,util;
procedure interpret;

implementation

procedure interpreter;
const
  stepmax  = 4;   { maximum steps executed between scheduler calls }
  tru      = 1;   { internal representation of boolean values }
  fals     = 0;
  inactive = 999; { code for inactive process }

var
  ps: (run, fin, divchk, inxchk, stkchk, redchk, deadlock);
                     { processor status codes }
  s: array[1..stmax] of integer;
                     { the stack }

  ptab: array[ptype] of          { process table }
         record
          t:          integer;   { top of stack }
          b:          integer;   { bottom of stack }
          pc:         integer;   { program counter }
          stacksize:  integer;   { size of stack segment }
          display:    array[1..lmax] of integer;
                                 { display of static links }
          suspend:    integer;   { suspension pointer }
          priority:   integer;   { priority }
          timecalled: integer;   { time called for entry queues }
          p1, p2:     integer;   { parameters of entry call }
         end;

  ir:        order;     { current instruction being executed }
  chrcnt:    integer;   { counter of characters in line }
  npr:       ptype;     { number of active processes }
  curpr:     ptype;     { current process }
  stepcount: integer;   { count of steps in this time slice }
  steps:     integer;   { number of steps until break }
  selflag:   boolean;   { select is being executed }
  pflag:     boolean;   { processes being activated }
  selloop:   integer;   { loop count in select statement }
  selrandom: integer;   { for random choice of alternative in select }
  seltask:   ptype;     { task containing select statement }
  deltaproc: integer;   { process index increment for scheduling }
  stamp:     integer;   { internal clock for time stamp }
  curent:    integer;   { current entry table index }
  glovar: array[1..10] of integer;
                        { global variable indices for watch }
  numglo:    integer;   { number of entries in glovar }
  ch:        char;      { temporary variables }
  h1, h2, h3, h4: integer;

function itob(i: integer): boolean;
  { integer to boolean }
begin
  itob := i=tru
end;

function btoi(b: boolean): integer;
  { boolean to integer }
begin
  if b then btoi := tru else btoi := fals
end;

procedure getsteps;
  { get command from break }
begin
  clreol;
  deltaproc := 1;  { choose next active process in table }
  stepcount := 0;
  steps := 1;      { one step before next break }
  write('Command: ');
  ch := readkey;
  if      ch = '+' then
  else if ch = '*' then deltaproc := 0   { don't change process }
  else if ch = '-' then steps := maxint  { execute indefinitely }
  else if ch = '/' then ps := fin        { terminate interpretation }
  else                                   { choose number of steps }
{$I-}
    repeat
      write('Steps: ');
      readln(steps);
    until (ioresult = 0) and (steps > 0)
{$I+}
end;

procedure dump;
  { called upon break and upon abnormal termination }
var i,j: integer;
    x,y: byte;
begin
  x := wherex; y := wherey;  { save program window coordinates }
  window(1,13,40,25);        { write in dump window }
  writeln;
  with ptab[curpr] do
    write('halt in process ', curpr:1, ' ');
  clreol;
  case ps of
    run:       writeln('break');
    deadlock:  writeln('deadlock');
    divchk:    writeln('divsion by zero');
    inxchk:    writeln('invalid index');
    stkchk:    writeln('storage overflow');
    redchk:    writeln('reading past eof');
  end;
  writeln('process suspend pc  instruction');
  for i := 0 to pmax do
    with ptab[i] do
      begin
      write(i:4, suspend:9, pc:5, code[pc].f:6, '  ');
      printinst(output, code[pc].f);
      writeln;
      end;
  writeln('entries');
  for i := 1 to entries do
   with entry[i] do
      begin
      write(name);
      clreol;
      if open <> 0 then write(' acceptor ', open:1,'/', waiting:1)
      else
        begin
        write(' callers ');
        for j := 1 to pmax do
        if ptab[j].suspend = i then
          write(j:1,'/',ptab[j].timecalled:1,'  ')
        end;
      writeln
      end;
  getsteps;            { get user command }
  window(1,1,80,12);   { restore program window }
  gotoxy(x,y)
end;

procedure chooseproc;
  { Scheduler:
      starting with highest priority, search for a process
      that is not suspended, then choose a time slice }
var found: boolean;
begin
  h3 := pmax;  { highest priority }
  h2 := (curpr + deltaproc) mod (pmax+1); { start search from here }
  h1 := h2;
  repeat
    repeat
      found := (ptab[h2].suspend = 0) and (ptab[h2].priority = h3);
      h4 := h2;
      h2 := (h2 + 1) mod (pmax + 1);
    until found or (h2 = h1);
    if not found then h3 := h3 - 1;  { next lower priority }
  until found or (h3 = 0);
  if h3 = 0 then ps := deadlock else curpr := h4;
  stepcount := random(stepmax)   { choose random time slice }
end;

procedure getpriorities;
  { for each execution of the interpreter, individual priorities
    may be set, otherwise all process have the same priority }
begin
  write('Priorities = ');
  read(h1);
  if h1 <> 0 then
    begin
    readln(h2, h3);
    ptab[1].priority := h1;
    ptab[2].priority := h2;
    ptab[3].priority := h3
    end
end;

procedure initinterpret;
  { initialization }
var c: ptype;
    i: integer;
begin
  s[1] := 0;          { environment activation record }
  s[2] := 0;
  s[3] := -1;
  s[4] := btab[1].last;

  with ptab[0] do     { main process }
    begin
    b := 0;
    suspend := 0;     { initially active }
    priority := pmax;
    display[1] := 0;
    t := btab[2].vsize-1;
    pc := tab[s[4]].adr;
    stacksize := stmax - pmax*stkincr
    end;

  for c := 1 to pmax do  { other processes }
    with ptab[c] do
      begin
      display[1] := 0;
      pc := 0;
      priority := pmax;          { default priority }
      suspend := inactive;       { initially inactive }
      b := ptab[c-1].stacksize+1;
      stacksize := b+stkincr-1;
      t := b-1
      end;

  stamp     := 0;
  npr       := 0;
  curpr     := 0;
  seltask   := 0;
  selrandom := 0;
  selloop   := 2;
  pflag     := false;
  selflag   := false;
  stepcount := 0;
  ps        := run;
  chrcnt    := 0;
  steps     := 0;
  numglo    := 0;
  for i := 1 to entries do
    with entry[1] do
      begin open := 0; waiting := 0 end;
  for i := 1 to 10 do glovar[i] := 0;
  randomize;     { set random number generator }
  getpriorities;
  clrscr;
  window(1,1,80,12);   { program window }
end;

procedure relinquish(i: integer);
  { relinquish the processor by suspending on i and forcing
    a call to the scheduler }
begin
  ptab[curpr].suspend := i;
  stepcount := 0
end;

begin { interpret }
  initinterpret;

  repeat
    if keypressed then   { pressing any key forces break }
      begin ch := readkey; steps := 0 end;
    if steps = 0 then dump;
    steps := steps - 1;

    if ptab[0].suspend = 0 then curpr := 0
       { highest priority to main program to allow activation }
    else if stepcount = 0 then chooseproc
    else stepcount := stepcount - 1;

    with ptab[curpr] do  { extract next instruction }
      begin
      ir := code[pc];
      pc := pc + 1
      end;

    if pflag then  { process being activated }
      begin
      if ir.f=18 { markstack } then npr := npr + 1;
      curpr := npr
      end;

    with ptab[curpr] do
    case ir.f of         { decode instruction }

    0:  begin { load address }
        t := t + 1;
        if t > stacksize then ps := stkchk
        else s[t] := display[ir.x] + ir.y
        end;

    1:  begin { load value }
        t := t + 1;
        if t > stacksize then ps := stkchk
        else s[t] := s[display[ir.x] + ir.y]
        end;

    2:  begin { load indirect }
        t := t + 1;
        if t > stacksize then ps := stkchk
        else s[t] := s[s[display[ir.x] + ir.y]]
        end;

    3:  begin { update display }
        h1 := ir.y;
        h2 := ir.x;
        h3 := b;
        repeat
          display[h1] := h3;
          h1 := h1 - 1;
          h3 := s[h3+2]
        until h1 = h2
        end;

    4:  pflag := true; { cobegin - activate processes }

    5:  begin { coend - all processes activated }
        pflag := false;
        ptab[0].suspend := inactive
        end;

    6:  begin { semaphore wait }
        h1 := s[t];
        t := t - 1;
        if s[h1] > 0 then s[h1] := s[h1] - 1 else relinquish(h1)
        end;

    7:  begin { semaphore signal }
        h1 := s[t];
        t := t - 1;
        h2 := pmax+1;
        h3 := random(h2);      { from random point }
        while (h2 >= 0) and (ptab[h3].suspend <> h1) do
          begin      { search for process suspended on this semaphore }
          h3 := (h3+1) mod (pmax+1);
          h2 := h2 - 1
          end;
        if h2 < 0 then s[h1] := s[h1] + 1  { if none then increment }
        else ptab[h3].suspend := 0         { release suspended process }
        end;

    10: pc := ir.y; { jump }

    11: begin { conditional jump }
        if s[t] = fals then pc := ir.y;
        t := t - 1
        end;

    14: begin { top of for loop }
        h1 := s[t-1];  { lower bound on index }
        if h1 <= s[t] then s[s[t-2]] := h1 else
          begin        { upper > lower so skip loop }
          t := t - 3;
          pc := ir.y
          end
        end;

    15: begin { bottom of for loop }
        h2 := s[t-2];    { upper bound }
        h1 := s[h2] + 1; { index }
        if h1 <= s[t] then
          begin          { jump to top }
          s[h2] := h1;
          pc := ir.y
          end
        else t := t - 3  { finished }
        end;

    18: begin { mark stack }
        h1 := btab[tab[ir.y].ref].vsize; { size of stack for call }
        if t+h1 > stacksize then ps := stkchk else
          begin
          t := t + 5;       { allocate room for activation record }
          s[t-1] := h1 - 1; { store size and tab index }
          s[t] := ir.y      {   for call instruction }
          end
        end;

        { actual parameters stacked between mark stack and call }

    19: begin { procedure call }
        suspend := 0;
        h1 := t - ir.y;         { old bottom of stack }
        h2 := s[h1+4];          { tab index left by mark stack }
        h3 := tab[h2].lev;      { get nesting level }
        display[h3+1] := h1;    { store in display }
        h4 := s[h1+3] + h1;     { stack size left by mark stack }
        s[h1+1] := pc;          { return address }
        s[h1+2] := display[h3]; { static link }
        if pflag then s[h1+3] := ptab[0].b else s[h1+3] := b;
                                { dynamic link }
        for h3 := t+1 to h4 do s[h3] := 0;
                                { zero local variables }
        b := h1;                { new bottom of stack }
        t := h4;                { new top of stack }
        pc := tab[h2].adr       { start of procedure code }
        end;

    21: begin { load array element given index }
        h1 := ir.y;
        h2 := atab[h1].low;
        h3 := s[t];
        if h3 < h2 then ps := inxchk else
          begin
          t := t - 1;
          s[t] := s[t] + (h3-h2) * atab[h1].elsize
          end
        end;

    24: begin { literal }
        t := t + 1;
        if t > stacksize then ps := stkchk else s[t] := ir.y
        end;

    27: begin { read }
        if eof(inp) then ps := redchk else
          case ir.y of
            1: read(inp, s[s[t]]);
            3: begin read(inp, ch); s[s[t]] := ord(ch) end
          end;
        t := t - 1
        end;

    28: begin { write string }
        h1 := s[t];
        h2 := ir.y;
        t := t - 1;
        chrcnt := chrcnt + h1;
        if chrcnt = 80 then begin writeln; chrcnt := 0 end;
        repeat
          write(stab[h2]);
          h1 := h1 - 1;
          h2 := h2 + 1
        until h1 = 0
        end;

    29: begin { write1 }
        if ir.y = 3 then h1 := 1 else h1 := 10;
        chrcnt := chrcnt + h1;
        if chrcnt = 80 then begin writeln; chrcnt := 0 end;
        case ir.y of
          1: write(s[t]);
          2: write(itob(s[t]));
          3: if (s[t]<0) or (s[t]>255) then ps := inxchk
               else write(chr(s[t]))
        end;
        t := t - 1
        end;

    31: { end of program } ps := fin;

    32: { exit procedure } begin
        t := b - 1;        { old top of stack }
        pc := s[b+1];      { return address }
        if pc <> 0 then b := s[b+3] else
                           { old bottom of stack from dynamic link }
          begin            { exit from process }
          if selflag then ptab[seltask].suspend := 0;
          selloop := 2;
          relinquish(inactive); { deactivate process }
          npr := npr - 1;  { one less process active }
          if npr=0 then ptab[0].suspend := 0
             { if last process, reactivate main }
          end
        end;

    34: s[t] := s[s[t]];  { from address get value, used with index }
    35: s[t] := btoi(not(itob(s[t])));  { boolean not }
    36: s[t] := - s[t];   { unary minus }

    38: begin { store }
        if ir.y <> 0 then  { watch variable }
          begin
          h1 := wherex; h2 := wherey; { save program window }
          window(41,13,80,25);        { watch window }
          h4 := numglo + 1;           { see if variable exists in table }
          for h3 := 1 to numglo do
            if ir.y = glovar[h3] then
              h4 := h3;
          if h4 = numglo+1 then       { create new table entry }
            begin
            numglo := h4;
            glovar[numglo] := ir.y
            end;
          gotoxy(1,h4+1);             { table index is line in window }
          writeln(tab[ir.y].name, s[t]:8);
          window(1,1,80,12);          { reset window }
          gotoxy(h1,h2)
          end;
        s[s[t-1]] := s[t];
        t := t - 2;
        end;

        { arithmetical and logical operators }

    45: begin t:=t-1; s[t] := btoi(s[t] =  s[t+1]) end;
    46: begin t:=t-1; s[t] := btoi(s[t] <> s[t+1]) end;
    47: begin t:=t-1; s[t] := btoi(s[t] <  s[t+1]) end;
    48: begin t:=t-1; s[t] := btoi(s[t] <= s[t+1]) end;
    49: begin t:=t-1; s[t] := btoi(s[t] >  s[t+1]) end;
    50: begin t:=t-1; s[t] := btoi(s[t] >= s[t+1]) end;

    51: begin t:=t-1; s[t] := btoi(itob(s[t]) or  itob(s[t+1])) end;
    52: begin t:=t-1; s[t] := s[t] + s[t+1] end;
    53: begin t:=t-1; s[t] := s[t] - s[t+1] end;
    56: begin t:=t-1; s[t] := btoi(itob(s[t]) and itob(s[t+1])) end;
    57: begin t:=t-1; s[t] := s[t] * s[t+1] end;

    58: begin
        t := t - 1;
        if s[t+1] = 0 then ps := divchk else
          s[t] := s[t] div s[t+1]
        end;

    59: begin
        t := t - 1;
        if s[t+1] = 0 then ps := divchk else
          s[t] := s[t] mod s[t+1]
        end;

    62: { readln } if eof(inp) then ps := redchk else readln(inp);
    63: { writeln } begin writeln; chrcnt := 0 end;

        { Before an entry call, the parameters are compiled
          and the appropriate instruction 70-73 is emitted.
          in parameters load the value into the fields p1, p2
          of the calling process table entry while out
          parameters load the address into those fields }

    70: begin p1 := s[t]; t := t - 1 end;   { load in parm 1 }
    71: begin p2 := s[t]; t := t - 1 end;   { load in parm 2 }
    72: p1 := display[ir.x]+ir.y;     { load out parm 1 }
    73: p2 := display[ir.x]+ir.y;     { load out parm 2 }

    74: begin { call entry }
          stamp := stamp + 1;   { time stamp this call }
          timecalled := stamp;
          with entry[ir.y] do
          if open <> 0 then       { there is a waiting accept }
            with ptab[waiting] do { waiting contains the process }
              begin               { index of the accepting task }
              pc := open;         { open contains the pc of the accept }
              open := 0;          { revoke wait status }
              suspend := 0;       { reactivate accepting task }
              waiting := curpr    { store calling index here }
              end
          else { no waiting accept }
            if waiting = 0 then waiting := curpr;
               { if no other calls, we are first on this entry queue }
        if selflag then ptab[seltask].suspend := 0;
           { reactivate task with select }
        selloop := 2;
        relinquish(ir.y);         { calling task always suspended }
        end;

        { A select statement will try each accept statement in
          turn to see if there is a waiting call, otherwise it
          will suspend itself.
          To implement random selection of an alternative,
          a random number is used to decide if the first accept
          statement should be skipped. Since the second accept
          statement may be closed or have an empty queue,
          two passes are taken around the select loop before
          deciding to suspend. }

    75: begin { accept entry }
        curent := ir.y;
        with entry[ir.y] do
          if waiting = 0 then   { if no entry call waiting }
            if selflag then     { executing select }
              begin
              pc := ir.x;       { jump over accept body }
              selloop := selloop - 1
              end
            else                { no select }
              begin
              open := pc;       { note pc of waiting accept }
              waiting := curpr; { and accepting process index }
              relinquish(ir.y); { suspend pending an entry call }
              end
          else if selflag and (selrandom > 0) then
            begin
            pc := ir.x;         { randomly jump over accept body }
            selrandom := 0
            end
        end;

        { When entering rendezvous, copy in parameters (76-77)
          from calling task's process table fields p1 and p2.
          When completing rendezvous, use addresses in those
          fields to copy back the values (78-79). }

    76: s[display[ir.x]+ir.y] := ptab[entry[curent].waiting].p1;
    77: s[display[ir.x]+ir.y] := ptab[entry[curent].waiting].p2;
    78: s[ptab[entry[curent].waiting].p1] := s[display[ir.x]+ir.y];
    79: s[ptab[entry[curent].waiting].p2] := s[display[ir.x]+ir.y];

    80: begin  { release call }
        h1 := ir.y;
        with entry[h1] do
          begin
          ptab[waiting].suspend := 0;  { calling task reactivated }
          h4 := maxint;   { earliest call becomes waiting call }
          h3 := 0;
          for h2 := 1 to pmax do
            if (ptab[h2].suspend = h1) and
               (ptab[h2].timecalled < h4) then
                 begin
                 h4 := ptab[h2].timecalled;
                 h3 := h2
                 end;
          waiting := h3
          end
        end;

    81: begin { select }
        selflag := true;         { select being executed }
        selrandom := random(2);  { random choice of alternative }
        selloop := 2;            { loop count }
        seltask := curpr         { process executing select }
        end;

    82: { terminate }
        if npr = 1 then selflag := false { last process so terminate }
        else pc := pc + 1;               { skip over exit instruction }

    83: { end select } if selloop = 0 then relinquish(inactive)
           { after twice around loop we can suspend }

    end { case };
  until ps <> run;

  writeln;
  if ps <> fin then dump
end;

procedure interpret;
  { Interpret the program in the code table }
var ch: char;
begin
  repeat
    write('Interpret (y/n): ');
    if eoln then readln;
    readln(ch);
    if ch = 'y' then interpreter
  until ch <> 'y';
  window(1,1,80,25);
  clrscr
end;

end.