Show semaphore name in Pascal

I am currently studying Pascal for a university course in concurrent and distributed systems. My lecturer has consented to me posting this question as it does not help me in my assessment.

I have uploaded two files, semdem.pas and multa.inc. I can upload turbo pascal compiler if needed too. When semdem is run, if it is blocked by a semaphore, it states so in the top right hand corner, I can find the text in the compiler and can change this to whatever I like. I would like it to actually read out the name of the semaphore, in this instance the semaphore is named s. However in my dining philosophers problem I have named each chopstick C12, C23 etc.

Many thanks Ed.
edmaceyAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

edmaceyAuthor Commented:
Also the files are here.

 MULTIAINC.txt SemDem.PAS
0
aikimarkCommented:
I formatted the multiainc Pascal code using a Delphi formatting tool and a little manual tweaking.
{November 1991 Mod in Signal procedure, uses addr(name)}
{$C-,K-,U-}
const
  use_clock = true;
  default_stack_size = 2000;
type
  chan = 0..255;
  chanset = set of chan;
  maxstring = string[80];
  semaphore = 0..maxint;
  process_status_type =
    (ready, blocked_key, blocked_twait, blocked_semaphore,
    blocked_send, blocked_recv, killed);
  context_block_ptr = ^context_block_rec;
  context_block_rec = record 
    bp, sp, ss, pc: integer;
    priority, stack_size, slice: integer;
    wx1, wy1, wx2, wy2, curx, cury: integer;
    ctrl_c_is_on, show_run: boolean;
    status: process_status_type;
    waitchan: chanset;
    time_remaining, msg: integer;
    semaphore_q: ^semaphore;
    next: context_block_ptr;
  end;
  int_vector_rec = record 
     o, s: integer;
  end;
  regs = record 
    ax, bx, cx, dx, bp, si, di, ds, es, flags: integer;
  end;
const
  iret: byte = $CF;
  slices_left: integer = 0;
  entry_offset = 4;
  ctrl_c_state: boolean = true;
  return_dest:
  int_vector_rec = (o: 0; s: 0);
  old_int_3: int_vector_rec = (o: 0; s: 0);
  old_int_8: int_vector_rec = (o: 0; s: 0);
  bpf = 0;
  spf = 2;
  ssf = 4;
  pcf = 6;
var
  stacks_base: integer;
  wait_key: boolean;
  int_3_vec: int_vector_rec absolute 0: 12;
  int_8_vec: int_vector_rec absolute 0: 32

  ;

procedure cursor_on;
var
  reg:
  regs;
begin
  reg.cx := $0C0D;
  reg.ax := $0100;
  intr($10, reg);
end;

procedure cursor_off;
var
  reg: regs;
begin
  reg.cx := $2000;
  reg.ax := $0100;
  intr($10, reg);
end;
procedure swap; forward;

procedure interrupt_3;
label
  ok, quit;
begin
  inline($2E / $FF / $0E / > slices_left / $74 / 3);
  goto quit;
  ok: swap;
  quit:
  inline($2E / $FF / $2E / > return_dest);
end

;

procedure interrupt_8;
begin
  inline($9C / $2E / $FF / $1E / > old_int_8
    / $9C / $50 / $53 / $51 / $52 / $06 / $1E / $56 / $57 / $55);
  int_8_vec.o := old_int_8.o;
  int_8_vec.s := old_int_8.s;
  int_3_vec.o := ofs(interrupt_3) + entry_offset;
  int_3_vec.s := cseg;
  inline( $5D / $5F / $5E / $1F / $07 / $5A / $59 / $5B / $58 / $9D / $CF);
end

;

procedure
  reset_int_8;
begin
  if use_clock then
  begin
    inline($FA);
    with
      int_8_vec do
    begin
      o := ofs(interrupt_8) + entry_offset;
      s := cseg;
    end;
    inline($FB);
  end;
end

;

procedure ctrl_c_off;
begin
  with
    return_dest do
  begin
    o := ofs(iret);
    s := cseg;
    ctrl_c_state := false;
  end;
end

;

procedure ctrl_c_on;
begin
  if wait_key then
    ctrl_c_off
  else
    return_dest := old_int_3;
  ctrl_c_state := true;
end

;

procedure init_interrupts;
var
  local: integer;
  i: integer;
begin
  inline($FA);
  old_int_3 := int_3_vec;
  old_int_8 := int_8_vec;
  inline($FB);
  ctrl_c_off;
  with int_3_vec do
  begin
    o := ofs(interrupt_3) + entry_offset;
    s := cseg;
  end;
  reset_int_8;
  ctrl_c_on;
end

;

procedure start_process(proc: integer);
var
  newsp, newss, stksiz: integer;
  current, new, old:
  context_block_ptr;
label
  quit;
begin
  stksiz := default_stack_size;
  stksiz := (stksiz + sizeof(context_block_rec) + 15) and $FFF0;
  current := ptr(sseg, 0);
  new := current;
  repeat new := new^.next;
  until (new = current) or ((new^.status = killed) and (new^.stack_size shr 4 <= stksiz shr 4));
  if not ((new^.status = killed) and
    (new^.stack_size shr 4 <= stksiz shr 4)) then
  begin
    stacks_base := stacks_base - (stksiz shr 4);
    new := ptr(stacks_base, 0);
    old := current^.next;
    current^.next := new;
    new^.next := old;
  end;
  with
    new^ do
  begin
    wx1 := current^.wx1;
    wy1 := current^.wy1;
    wx2 := current^.wx2;
    wy2 := current^.wy2;
    curx := current^.curx;
    cury := current^.cury;
    priority := current^.priority;
    slice := current^.slice;
    time_remaining := 0;
    semaphore_q := nil;
    show_run := true;
    ctrl_c_is_on := ctrl_c_state;
    slices_left := slice;
    stack_size := stksiz;
  end;
  with current^ do
  begin
    curx := wherex;
    cury := wherey;
    status := ready;
  end;
  old := current;
  newss := seg(new^);
  newsp := new^.stack_size;
  inline($FA / $C4 / $BE / > old
    / $26 / $89 / $6D / < bpf / $26 / $89 / $65 / < spf / $26 / $8C / $55 / < ssf / $B8 / > * +4 / $EB / 3);
  goto quit;
  inline($26 / $89 / $45 / < pcf / $8B / $86 / > proc
    / $8B / $A6 / > newsp / $8E / $96 / > newss / $FF / $E0);
  quit: inline($FB);
end

;

procedure check_delays;
var
  current, next:
  context_block_ptr;
begin
  current := ptr(sseg, 0);
  next := current;
  repeat if (next^.status = blocked_twait) then
    begin
      with next^ do
        if time_remaining > 0 then
          time_remaining := time_remaining - 1
        else
          status := ready;
    end;
    next := next^.next;
  until next = current;
end

;

procedure find_process(var new: context_block_ptr);
var
  current, next, wait: context_block_ptr;
  any_active: boolean;
begin
  repeat check_delays;
    any_active := false;
    if (new = nil) or (new^.status <> ready) then
    begin
      current := ptr(sseg, 0);
      next := current;
      new := nil;
      wait := nil;
      repeat if (next^.status =
          blocked_key) and ((wait = nil) or (next^.priority >=
          wait^.priority)) then
          wait := next;
        if (next^.status = ready) and
          ((new = nil) or (next^.priority >= new^.priority)) then
          new := next;
        if (next^.status = blocked_twait) then
          any_active := true;
        next := next^.next;
      until next = current;
    end;
    if new = nil then
      new := wait
    else if (wait <> nil) and keypressed and
      (wait^.priority >= new^.priority) then
      new := wait;
    if (new = nil) and (not any_active) then
    begin
      window(1, 1, 80, 25);
      gotoxy(1, 25);
      cursor_on;
      write('No processes active - scheduling terminated');
      halt;
    end;
    if new = nil then
      delay(30);
  until
    new <> nil;
end

;

procedure twindow(x1, y1, x2, y2: integer);
begin
  window(x1, y1, x2, y2);
end

;

procedure
  swap_processes(new: context_block_ptr);
var
  cur, current: context_block_ptr;
  i, j: integer;
label 
  quit;
begin
  current := ptr(sseg, 0);
  with current^ do
  begin
    curx := wherex;
    cury := wherey;
    cursor_off;
    ctrl_c_is_on := ctrl_c_state;
    window(1, 1, 80, 25);
    gotoxy(wx2 - 12, wy1 - 1);
    if wx2 > wx1 then
      case status of
        ready: write(#196, #196, #196, #196, #196, #196, #196,
            #196, #196, #196, #196, #196, #196);
        blocked_key: write(#196, 'blocked(key)');
        blocked_twait: write(#196, 'blocked(dly)');
        blocked_send: write('blocked(send)');
        blocked_recv: write('blocked(recv)');
        blocked_semaphore: write('blocked(sem4)');
        killed: write(#196, #196, #196, #196, #196, #196, #196, 'killed');
      end;
  end;
  repeat find_process(new);
  until new^.status <> blocked_twait;
  reset_int_8;
  if use_clock then
  begin
    inline($FA);
    int_3_vec := return_dest;
    inline($FB);
  end;
  with new^ do
  begin
    if wx2 > wx1 then
    begin
      window(1, 1, 80, 25);
      gotoxy(wx2 - 12, wy1 - 1);
      if show_run then
        write(#196, #196, #196, #196, #196, #196, 'running');
      window(wx1, wy1, wx2, wy2);
      gotoxy(curx, cury);
      cursor_on;
      if
        ctrl_c_is_on then
        ctrl_c_on
      else
        ctrl_c_off;
    end;
    slices_left :=
      slice;
  end;
  cur := current;
  inline($FA / $C4 / $BE / > cur
    / $26 / $89 / $6D / < bpf / $26 / $89 / $65 / < spf / $26 / $8C / $55 / < ssf / $B8 / > * +4 / $EB / 3);
  goto quit;
  inline($26 / $89 / $45 / < pcf / $C4 / $BE / > new
    / $26 / $8B / $6D / < bpf / $26 / $8B / $65 / < spf / $26 / $8E / $55 / < ssf / $26 / $FF / $65 / < pcf);
  quit: inline($FB);
end

;

procedure swap;
var
  current: context_block_ptr;
begin
  current := ptr(sseg, 0);
  current^.status := ready;
  swap_processes(nil);
end

;

procedure
  initialise_multitasking;
var
  stksiz: integer;
  newss: integer;
  cb: context_block_rec;
  current: context_block_ptr;
begin
  stksiz
    := default_stack_size;
  wait_key := false;
  stksiz := (stksiz + sizeof(context_block_rec) + 15) and $FFF0;
  newss := sseg + $1000 - (stksiz shr 4);
  stacks_base := newss;
  current := ptr(newss, 0);
  with current^ do
  begin
    wx1 := 1;
    wy1 := 0;
    wx2 := 0;
    wy2 := 0;
    curx := wherex;
    cury := wherey;
    slice := 1;
    slices_left := slice;
    priority := 0;
    time_remaining := 0;
    stack_size := stksiz;
    next := current;
  end;
  init_interrupts;
  inline($8B / $9E / > newss / $8B / $86 / > stksiz / $01 / $C5 / $8E / $D3 / $8B / $E5 / $5D / $01 / $C5 / $55 / $89 / $E5);
end

;

procedure
  initialise_semaphore(var name: semaphore; value: integer);
begin
  name := value;
end;

procedure wait(var name: semaphore);
var
  current: context_block_ptr;
begin
  if name > 0 then
    name := name - 1
  else
  begin
    current := ptr(sseg, 0);
    current^.status := blocked_semaphore;
    current^.semaphore_q := addr(name);
    while current^.status = blocked_semaphore do
      swap_processes(nil);
  end;
end;

procedure signal(var name: semaphore);
var
  current, next:
  context_block_ptr;
  found: boolean;
begin
  current := ptr(sseg, 0);
  next := current;
  found := false;
  repeat if (next^.status = blocked_semaphore) then
    begin
      with next^ do
        if semaphore_q = addr(name) then
        begin
          semaphore_q := nil;
          status := ready;
          found := true;
        end;
    end;
    next := next^.next;
  until (next = current) or found;
  if not found then
    name := name + 1;
end

;

procedure test_and_set(var
  a, b: boolean);
begin
  a := b;
  b := true;
end

;

procedure
  send(c: chan; v: integer);
var
  dest, current: context_block_ptr;
  ok: boolean;
begin
  current := ptr(sseg, 0);
  dest := current;
  repeat
    dest := dest^.next;
    with dest^ do
      ok := (status = blocked_recv) and (c in waitchan);
  until ok or (dest = current);
  if dest = current then
  begin
    current^.status := blocked_send;
    current^.waitchan := [c];
    current^.msg := v;
    swap_processes(nil);
  end
  else
  begin
    current^.status := ready;
    dest^.status := ready;
    dest^.msg := v;
    swap_processes(dest);
  end;
end

;

procedure recv(c
  : chanset; var v: integer);
var
  source, current:
  context_block_ptr;
  ok: boolean;
begin
  current := ptr(sseg, 0);
  source := current;
  repeat source := source^.next;
    with source^ do
      ok := (status = blocked_send) and (c >= waitchan);
  until ok or (source = current);
  if current = source then
  begin
    current^.status := blocked_recv;
    current^.waitchan := c;
    swap_processes(nil);
    v := current^.msg;
  end
  else
  begin
    source^.status := ready;
    current^.status := ready;
    v := source^.msg;
  end;
end

;

procedure terminate;
var
  current:
  context_block_ptr;
begin
  current := ptr(sseg, 0);
  current^.status := killed;
  swap_processes(nil);
end

;

procedure
  priority(pri: integer);
var
  current: context_block_ptr;
begin
  current := ptr(sseg, 0);
  current^.priority := pri;
end

;

procedure
  slices(s: integer);
var
  current: context_block_ptr;
begin
  current := ptr(sseg, 0);
  current^.slice := s;
end

;

procedure
  time_delay(s: integer);
var
  current: context_block_ptr;
begin
  current := ptr(sseg, 0);
  if s > 0 then
  begin
    current^.time_remaining := s;
    current^.status := blocked_twait;
    while current^.status = blocked_twait do
      swap_processes(nil);
  end;
end

;

procedure
  frame(x1, y1, x2, y2: integer; name: maxstring);
var
  i: integer;
begin
  if name <> #0 then
  begin
    twindow(1, 1, 80, 25);
    gotoxy(x1, y1);
    write(#218); write(name);
    for i := wherex to x2 - 1 do
      write(#196);
    write(#191);
    for i := y1 + 1 to y2 - 1 do
    begin
      gotoxy(x1, i);
      write(#179);
      gotoxy(x2, i); write(#179);
    end;
    gotoxy(x1, y2);
    write(#192);
    for i := 1 to x2 - x1 - 1 do
      write(#196);
    if (x2 < 80) or
      (y2 < 25) then
      write(#217);
  end;
end

;

procedure
  draw_window(x1, y1, x2, y2: integer; name: maxstring);
var
  current:
  context_block_ptr;
begin
  current := ptr(sseg, 0);
  with current^ do
  begin
    if name = #0 then
    begin
      wx1 := x1;
      wy1 := y1;
      wx2 := x2;
      wy2 := y2;
    end
    else
    begin
      wx1 := x1 + 1;
      wy1 := y1 + 1;
      wx2 := x2 - 1;
      wy2 := y2 - 1;
    end;
    if x2 > x1 then
    begin
      frame(x1, y1, x2, y2, name);
      twindow(wx1, wy1, wx2, wy2);
      gotoxy(1, 1);
    end;
  end;
end

;

procedure
  inp_error(i: integer);
begin
  cursor_on;
  case i of
    1:
      begin
        writeln('user break...');
      end;
    10:
      begin
        writeln('i/o error...');
      end;
  end;
  halt;
end

;

function getchar: char;
var
  c: char;
  current
    : context_block_ptr;
begin
  wait_key := true;
  current := ptr(sseg, 0);
  current^.status := blocked_key;
  current^.show_run := false;
  while not keypressed do
    swap_processes(nil);
  read(kbd, c);
  getchar := c;
  wait_key := false;
  current^.status := ready;
  current^.show_run := true;
end

;

function getstr: maxstring;
var
  c: char;
  s: maxstring;
begin
  s := '';
  c := getchar;
  while c <> #13 do
  begin
    case c of
      #3:
        begin
          getstr := c;
          exit;
        end;
      #8: if s <> '' then
        begin
          s[0] := pred(s[0]); write(#8, ' ', #8);
        end;
      #27: while
        s <> '' do
        begin
          s[0] := pred(s[0]); write(#8, ' ', #8);
        end;
    else
      begin
        s := s + c; write(c);
      end;
    end;
    c := getchar;
  end;
  getstr := s;
end

;

function read_char: char;
var
  c: char;
begin
  c := getchar;
  if c = #3 then
    inp_error(1);
  read_char := c;
end

;

function
  read_string: maxstring;
var
  c: char;
  s: maxstring;
begin
  s := getstr;
  if s = #3 then
    inp_error(1);
  read_string := s;
end;

function read_integer: integer;
var
  i, j: integer;
  s: maxstring;
begin
  s := getstr;
  if s = #3 then
    inp_error(1);
  if s = '' then
    i := 0
  else
  begin
    val(s, i, j);
    if j <> 0 then
      inp_error(10);
  end;
  read_integer := i;
end

;

procedure get_time(var h, m, s, f: byte);
var
  recpack: regs;
begin
  recpack.ax := $2C00;
  intr($21, recpack);
  with
    recpack do
  begin
    h := hi(cx);
    m := lo(cx);
    s := hi(dx);
    f := lo(dx);
  end;
end;

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
edmaceyAuthor Commented:
Many thanks for your help, unfortunately the programme still writes blocked(sem4) rather than blocked(name of actual semaphore).
I would like to get it so that if the name of the semaphore is C12 then it writes blocked(C12) in the bar.

Many thanks Ed.
0
JavaScript Best Practices

Save hours in development time and avoid common mistakes by learning the best practices to use for JavaScript.

aikimarkCommented:
@Ed

I did not change the Multianc code, just format it for readability.

0
edmaceyAuthor Commented:
Oh ok, thanks, but how do I change the code so that it displays the name of the semaphore and not sem4?

Thanks, Ed.
0
aikimarkCommented:
I don't see where a string name is assigned to a semaphore, especially something that resembles 'C12'
0
edmaceyAuthor Commented:
No yeah the string name is assigned in the programme not in the mutia.inc, its how do I call that from the programme. Ed
0
aikimarkCommented:
I don't recognize where this name is assigned.  Please post a short bit of semdem code that includes this.
0
edmaceyAuthor Commented:
So if you run that sem dem programme then the semaphore name is s,1 - i'd like to get that to display instead of blocked(sem4)
0
aikimarkCommented:
's' is the variable name.  I don't consider it the 'name' of the semaphore.

If you want to give names to each semaphore, you will need to extend the multianc class to include a semname property.  Then you can use that property value in the statement

Example:

blocked_semaphore: write('blocked(' + semname + ')');

Open in new window

0
Dirk HaestProject managerCommented:
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Pascal

From novice to tech pro — start learning today.