-- This file contains the package body for
--    the package a4types, used for a dfa simulation.
-- Thus it contains the definitions for all of the
--    functions given in the package specification,
--    and of some other functions as well.


with TEXT_IO;            use TEXT_IO;


 
package body a3 is

package BINDING_IO is new INTEGER_IO(BINDING); use BINDING_IO;








--  The stack component (which is the 2nd component) of an empty
--    environment consists of a single header node, with a dummy
--    (empty) list of values.
--  So this constructor, which returns an empty environment,
--    builds such a list as the 2nd component of its return value.
--    The first component is an empty display.

function new_environment return environment_ptr is
begin
  return new environment'((others=>null),0,new environment_node'(null,null));
end new_environment;


-- This procedure recreates the display from an environment's list
--   of frames by traversing the chain of static links starting at
--   the topmost frame, and entering a pointer to each frame in the
--   chain into the display.
-- Note that display elements needn't be erased if the display_size
--   is checked before each reference to the display.  That is,
--   display elements at or beyond the position given by the
--   display size aren't guaranteed to be correct.

procedure update_display(e:environment_ptr) is
counter:integer:=0;
eptr:environment_node_ptr:=e.frames.next;  -- skip header node
f:frame_ptr;
begin
  if eptr/=null then
    f:=eptr.frame;
    while f/=null loop
      e.d(counter):=f;
      counter:=counter+1;
      f:=f.static_link;
    end loop;
  end if;
  e.display_size:=counter;
end;



-- This procudure adds a given frame to a given environment.
-- Since the new frame is to be inserted immediately after the
--   header node, a new successor node is built for this header
--   node that points to the frame.  The successor of this new
--   node is the header's old successor.

procedure add_frame(e:environment_ptr; fr:frame_ptr) is
begin
  e.frames.next:=new environment_node'(fr,e.frames.next);
  update_display(e);
end add_frame;


-- This procedure deletes the frame from the beginning of an
--   environment.  That is, the header node's successor is to
--   be the old successor's successor.
-- The display must also be updated.
-- Here there is no error checking or storage reclamation

procedure delete_frame(e:environment_ptr) is
begin
  e.frames.next:=e.frames.next.next;
  update_display(e);
end delete_frame;


-- This function builds a new frame, given a static link
--   and a list of bindings.  The binding list is implemented
--   with a header node, so this function builds such a node.

function new_frame(fr:frame_ptr) return frame_ptr is
begin
  return new frame'(fr,new binding_node'(0,null));
end new_frame;


-- This function adds a binding to the end of a frame's list
--   of bindings.  The function steps through the list of
--   bindings, looking ahead to make sure that it never falls
--   off the end of the list (it won't initially, due to the
--   presence of a header node).  When it reaches the last node,
--   it creates a new successor node for it that contains the
--   given binding.

procedure add_binding(f:frame_ptr; bb:binding) is
current:binding_node_ptr:=f.bindings;
begin
  while (current.next /= null) loop
    current:=current.next;
  end loop;
  current.next:=new binding_node'(bb,null);
end add_binding;


-- This function returns the binding in an environment specified
--   by a pair of offsets.
-- It raises an exception if the offsets are illegal in the
--   given environment.  A procedure that doesn't use offsets
--   is given at the end of this file.

function lookup(e:environment_ptr; i,j:integer) return binding is
d:display;
bcurrent:binding_node_ptr;
begin
  d:=e.d;
  bcurrent:=d(i).bindings.next;
  for k in 1..j loop
    bcurrent:=bcurrent.next;
  end loop;
  return bcurrent.data;
exception
  when CONSTRAINT_ERROR =>
    raise;
end lookup;


-- This function finds the binding in an environment specified
--   by a pair of offsets, and prints its value.
-- It calls a lookup function to return the binding.  If no
--   binding is found, a constraint exception will be raised,
--   and this function will return an error message.

procedure lookup_and_print(e:environment_ptr; i,j:integer) is
begin
  put(lookup(e,i,j));    -- leading spaces printed automatically
exception
  when CONSTRAINT_ERROR =>
    put("     error");
end lookup_and_print;


-- Not used, but just provided to show a possible approach
--   that doesn't use exceptions
-- This function returns the binding in an environment specified
--   by a pair of offsets.

procedure old_lookup_and_print(e:environment_ptr; i,j:integer) is
d:display;
bcurrent:binding_node_ptr;
begin
  if i<e.display_size then
    d:=e.d;
    bcurrent:=d(i).bindings.next;
  else
    put("      error");
    return;
  end if;
  for k in 1..j loop
    if (bcurrent/=null) then
      bcurrent:=bcurrent.next;
    else
      put("      error");
      return;
    end if;
  end loop;
  if (bcurrent=null) then
    put("      error");
    return;
  end if;
  put(bcurrent.data);   -- leading spaces printed automatically


end old_lookup_and_print;


end a3;