• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 722
  • Last Modified:

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.
0
edmacey
Asked:
edmacey
  • 5
  • 5
2 Solutions
 
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
 
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
Introducing Cloud Class® training courses

Tech changes fast. You can learn faster. That’s why we’re bringing professional training courses to Experts Exchange. With a subscription, you can access all the Cloud Class® courses to expand your education, prep for certifications, and get top-notch instructions.

 
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
 
DhaestCommented:
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 5
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now