----------------------- functions for lists ---------------------------------

with TEXT_IO;  use TEXT_IO;

package body funct is

package INT_IO is new INTEGER_IO(INTEGER);

---------------- for lists of symbols --------------------------

-- Insert the symbol SYM into the list LS of symbols

procedure insert(ls:list_of_symbols_ptr; sym:symbol_type_ptr) is
begin
  ls.symbol(ls.size):=sym;
  ls.size:=ls.size+1;
end;

-- return the (first) position, if any, in the list where a given symbol
--   SYM is to be found
-- if not found, return an error signal rather than fail.

function search(ls:list_of_symbols_ptr; sym:symbol_type_ptr)
         return integer is 
begin
  for i in 0..ls.size-1 loop
    if equal(ls.symbol(i),sym) then
      return i;
    end if;
  end loop;
  return ERROR_FLAG;
end search;


---------------------- for lists of lists ---------------------------

procedure insert(ll:list_of_lists_ptr; sym:list_of_symbols_ptr) is
begin
  ll.symbols(ll.size):=sym;
  ll.size:=ll.size+1;
end insert;


---------------------- for lists of offsets -----------------------------

procedure insert(lo:list_of_offsets_ptr; o:offset_ptr) is
begin
  lo.offsets(lo.size):=o;
  lo.size:=lo.size+1;
end insert;

-- Lists of offsets are used to represent function calls in the
--   target language, so a version of the constructor is provided
--   to do the translation.  The first argument is the source
--   language version of the call; the second is a pointer to a
--   function object.  This function object contains the information
--   about block structure needed to translate the call to the
--   corresponding function.
-- Thus the constructor can merely translate the function name by
--   a call to "search_f" and each argument by a call to "search_v".
--   If any search fails, the constructor signals an error by
--   returning an error flag in the "size" field of the constructed
--   list.

function build_list_of_offsets(ls:list_of_symbols_ptr; f:function_ptr)
                 return list_of_offsets_ptr is
o:offset_ptr;
lo:list_of_offsets_ptr:=new list_of_offsets;
begin
   o:=search_f(f,get_symbol(ls,0),get_size(ls));  -- translate function
   lo.size:=get_size(ls);
   lo.offsets(0):=o;
   for i in 1..get_size(ls)-1 loop                -- translate arguments
     o:=search_v(f,get_symbol(ls,i));
     lo.offsets(i):=o;
   end loop;
   return lo;
exception
  when others =>raise;
end build_list_of_offsets;


------------------------ for lists of functions ---------------------

procedure insert(lf:list_of_functions_ptr; f:function_ptr) is
begin
  lf.funct(lf.size):=f;
  lf.size:=lf.size+1;
end insert;

function search(lf:list_of_functions_ptr; s:symbol_type_ptr) 
          return integer is 
fname:symbol_type_ptr;
length:integer;
begin
  for i in 0..lf.size loop
    fname:=get_name(lf.funct(i));
    length:=fname.length;
    if equal(s,fname) then
      return i;
    end if;
  end loop;
exception
  when others =>raise;
end search;


-------------------- for lists of encodings ---------------------------

-- This constructor translates the body of the function f from
--   the source language to the target language by calling the
--   list_of_offsets constructor once for each instruction.
-- Like this latter constructor, it returns an error flag in the
--   "size" field if an error is discovered.

function build_list_of_encodings (f:function_ptr)
                     return list_of_encodings_ptr is
  le:list_of_encodings_ptr:=new list_of_encodings;
  instrs:list_of_lists_ptr:=f.instrs;
begin
  le.size:=get_size(instrs);
  for i in 0..le.size-1 loop
    le.code(i):=build_list_of_offsets(get_symbols(f.instrs,i),f);
--    if get_size(le.code(i))=ERROR_FLAG then
--      le.size:=ERROR_FLAG;
--      return le;
--    end if;
  end loop;
  return le;
exception
  when others => raise;
end build_list_of_encodings;


------------------------ for functions ----------------------------


-- return an encoding of the run-time position of a given identifier
--   Search outward from the current function, following the links
--   given by environment pointers.  Print an error message and
--   return NULL if the variable is not found.

function search_v(f:function_ptr; s:symbol_type_ptr) 
           return offset_ptr is
tempf:function_ptr:=f;
posn:integer:=0;
counter:integer:=0;
output:offset_ptr;
SEARCH_ERROR:exception;
begin
  counter:=0;
  posn:=0;
  while tempf/=NULL loop                     -- iterate over blocks
    posn:=search(tempf.parameter,s);
    if (posn /= ERROR_FLAG) then
      output:=new offset'(counter,posn);
      return output;
    end if;
    counter:=counter+1;
    tempf:=get_ep(tempf);
  end loop;
  raise SEARCH_ERROR;
exception
  when SEARCH_ERROR =>
    PUT_LINE("undefined function"); raise;
end search_v;


-- return an encoding of the run-time position of a given function
-- works as above, except that a function is being sought, and that
-- an error message is printed and NULL is returned if there is a
-- mismatch in the number of arguments.

function search_f(f:function_ptr; s:symbol_type_ptr; k:integer)
         return offset_ptr is
tempf:function_ptr:=f;
posn:integer:=0;
counter:integer:=0;
arity:integer;
output:offset_ptr;
WRONG_ARITY,SEARCH_ERROR:exception;
begin
  while tempf/=NULL loop
    posn:=search(tempf.subr_names,s);
    if (posn /= ERROR_FLAG) then
      -- check numbers of formals & actuals
      arity:=get_size(get_funct(tempf.subroutines,posn).parameter);
      if arity+1 = k then
        output:=new offset'(counter,posn);
        return output;
      else
        raise WRONG_ARITY;
      end if;
    end if;
    counter:=counter+1;
    tempf:=get_ep(tempf);
  end loop;
  raise SEARCH_ERROR;
exception
  when WRONG_ARITY =>
    PUT_LINE("wrong number of arguments"); raise;
  when SEARCH_ERROR =>
    PUT_LINE("undefined function"); raise;
end search_f;

---------------------- miscellaneous selectors ----------------------

function get_ep(f:function_ptr) return function_ptr is
begin
  return f.ep;
end get_ep;

function get_name(f:function_ptr) return symbol_type_ptr is
  s:symbol_type_ptr:=new symbol_type;
begin
  s:=f.name;
  return s;
end get_name;

function get_symbol(ls:list_of_symbols_ptr; i:integer) 
          return symbol_type_ptr is
begin
  return ls.symbol(i);
end get_symbol;
      -- safe not to copy

function get_size(ls:list_of_symbols_ptr) return integer is
begin
  return ls.size;
end get_size;

function get_symbols(ll:list_of_lists_ptr; i:integer) 
               return list_of_symbols_ptr is
begin
  return ll.symbols(i);
end get_symbols;

function get_size(ll:list_of_lists_ptr) return integer is
begin
  return ll.size;
end get_size;

function get_funct(lf:list_of_functions_ptr; i:integer)
            return function_ptr is
begin
  return lf.funct(i);
end get_funct;

function get_size(lf:list_of_functions_ptr) return integer is
begin
  return lf.size;
end get_size;

function get_offsets(lo:list_of_offsets_ptr; i:integer) return offset_ptr is
begin
  return lo.offsets(i);
end get_offsets;

function get_size(lo:list_of_offsets_ptr) return integer is
begin
  return lo.size;
end get_size;

function get_size(le:list_of_encodings_ptr) return integer is
begin
  return le.size;
end get_size;

function get_code(le:list_of_encodings_ptr; i:integer)
             return list_of_offsets_ptr is
begin
  return le.code(i);
end get_code;


end funct;