# variable.rb - Attribute specific modules
# $Id: variable.rb,v 1.6 2000/11/28 04:38:40 keiko Exp $

require "util"
require "def"

module Input
  PREFIX = "i_"
  def input?; true; end
end

module Output
  PREFIX = "o_"
  def output?; true; end
end

module Working
  PREFIX = "w_"
  def work?; true; end
end

module InputOutput
  PREFIX = "io_"
  def input?; true; end
  def output?; true; end
end

def Variable(name, vtype, attr, ary, charlen)
  vt = vtype.capitalize
  at = case attr
       when "i"
	 "Input"
       when "o"
	 "Output"
       when "io"
	 "InputOutput"
       when "t"
	 "Working"
       end
  ar = ary ? "Array" : ""
  klass = eval(vt + at + ar + "Variable")
  klass.new(name, ary, charlen)
end

class Variable
  def initialize(name, ary, *arg)
    @name = name
    @ary = ary
    @arysize = nil
    @aryrank = nil
  end

  attr_reader :name;
  attr_reader :ary;
  attr_reader :aryrank;

  def prefix
    self.class::PREFIX
  end

  def vartype
    self.class::VARTYPE
  end

  def arg_name
    "&" + prefix + name
  end

  def localvariable
    [vartype, prefix+name]
  end

  def ftnlen
    nil
  end

  def checktype
    "/* checktype: not implemented for #{name} (#{type}) */\n"
  end

  def initialization
    "/* initialization: not implemented for #{name} (#{type}) */\n"
  end

  def allocworkingarea
    nil
  end

  def getresult
    "/* getresult: not implemented for #{name} (#{type}) */\n"
  end

  def freecary
    nil
  end

  def freeworkingarea
    nil
  end

  def input?;  false; end
  def output?; false; end
  def work?;   false; end

end

## Type specific modules

module DefaultType
  def basic_r2c(r, c)
    "/* not implemented */"
  end

  def basic_c2r(r, c)
    "/* not implemented */"
  end
end

module CharacterType
  include DefaultType

  VARTYPE = "char *"

  def initialize(name, ary, *arg)
    super
    if arg[0]
      @charlen = (arg[0] == "*") ? "DFLT_SIZE" : arg[0]
    else
      @charlen = "1"
    end
  end

  def basic_r2c(r, c)
    %Q$#{c} = STR2CSTR(#{r});\n$
  end

  def basic_r2c_copy(r, c)
    type = self.vartype.gsub(/\s+\*$/, "")
    %Q$#{c} = ALLOCA_N(#{type}, strlen(STR2CSTR(#{r}))+1);\n$ +
    %Q$strcpy(#{c}, STR2CSTR(#{r}));\n$
  end

  def basic_c2r(r, c)
    %Q$#{r} = rb_str_new2(#{c});\n$
  end
end

module IntegerType
  include DefaultType

  VARTYPE = "integer"

  def basic_r2c(r, c)
    %Q$#{c} = NUM2INT(#{r});\n$
  end

  def basic_c2r(r, c)
    %Q$#{r} = INT2NUM(#{c});\n$
  end
end

module RealType
  include DefaultType

  VARTYPE = "real"

  def basic_r2c(r, c)
    %Q$#{c} = (#{VARTYPE})NUM2DBL(#{r});\n$
  end

  def basic_c2r(r, c)
    %Q$#{r} = rb_float_new((double)#{c});\n$
  end
end

module ComplexType
  include DefaultType

  VARTYPE = "complex"
end

module LogicalType
  include DefaultType

  VARTYPE = "logical"

  def basic_r2c(r, c)
    %Q$#{c} = ((#{r} == Qnil)||(#{r} == Qfalse)) ? FALSE_ : TRUE_;\n$
  end

  def basic_c2r(r, c)
    %Q$#{r} = (#{c} == FALSE_) ? Qfalse : Qtrue;\n$
  end
end

## Basic Variables

class CharacterVariable < Variable
  include CharacterType

  def arg_name
    "" + prefix + name
  end

  def ftnlen
    if self.input?
      "(ftnlen)strlen(#{prefix+name})"
    else
      "(ftnlen)#{@charlen}"
    end
  end

  def checktype
    "" +
      %Q$if (TYPE(#{name}) != T_STRING) {\n$ +
      %Q$  #{name} = rb_funcall(#{name}, rb_intern("to_str"), 0);\n$ +
      %Q$}\n$
  end

  def initialization
    if self.input? && self.output?
      basic_r2c_copy(name, prefix+name)
    else
      basic_r2c(name, prefix+name)
    end
  end

  def allocworkingarea                  # kuro: +1 need ?
    type = vartype.gsub(/\s+\*$/, "")
    len = (@charlen + "+1").gsub(/^1[+]1/,"2")
    %Q$#{prefix+name}= ALLOCA_N(#{type}, (#{len}));\n$ +
    %Q$memset(#{prefix+name}, '\\0', #{len});\n$
  end

  def getresult
    basic_c2r(name, prefix+name)
  end

  def freeworkingarea
    nil
  end
end

class IntegerVariable < Variable
  include IntegerType

  def checktype
    "" +
      %Q$if ((TYPE(#{name}) != T_BIGNUM) || (TYPE(#{name}) != T_FIXNUM)) {\n$ +
      %Q$  #{name} = rb_funcall(#{name}, rb_intern("to_i"), 0);\n$ +
      %Q$}\n$
  end

  def initialization
    basic_r2c(name, prefix+name)
  end

  def getresult
    basic_c2r(name, prefix+name)
  end
end

class RealVariable < Variable
  include RealType

  def checktype
    "" +
      %Q$if (TYPE(#{name}) != T_FLOAT) {\n$ +
      %Q$  #{name} = rb_funcall(#{name}, rb_intern("to_f"), 0);\n$ +
      %Q$}\n$
  end

  def initialization
    basic_r2c(name, prefix+name)
  end

  def getresult
    basic_c2r(name, prefix+name)
  end
end

class ComplexVariable < Variable
  include ComplexType

end

class LogicalVariable < Variable
  include LogicalType

  def checktype
    nil
  end

  def initialization
    basic_r2c(name, prefix+name)
  end

  def getresult
    basic_c2r(name, prefix+name)
  end
end

### Character
class CharacterInputVariable < CharacterVariable
  include Input
end

class CharacterOutputVariable < CharacterVariable
  include Output
end

class CharacterInputOutputVariable < CharacterVariable
  include InputOutput
end

class CharacterWorkingVariable < CharacterVariable
  include Working
end

### Integer
class IntegerInputVariable < IntegerVariable
  include Input
end

class IntegerOutputVariable < IntegerVariable
  include Output
end

class IntegerInputOutputVariable < IntegerVariable
  include InputOutput
end

class IntegerWorkingVariable < IntegerVariable
  include Working
end

### Real
class RealInputVariable < RealVariable
  include Input
end

class RealOutputVariable < RealVariable
  include Output
end

class RealInputOutputVariable < RealVariable
  include InputOutput
end

class RealWorkingVariable < RealVariable
  include Working
end

### Complex
class ComplexInputVariable < ComplexVariable
  include Input
end

class ComplexOutputVariable < ComplexVariable
  include Output
end

class ComplexInputOutputVariable < ComplexVariable
  include InputOutput
end

class ComplexWorkingVariable < ComplexVariable
  include Working
end

### Logical
class LogicalInputVariable < LogicalVariable
  include Input
end

class LogicalOutputVariable < LogicalVariable
  include Output
end

class LogicalInputOutputVariable < LogicalVariable
  include InputOutput
end

class LogicalWorkingVariable < LogicalVariable
  include Working
end

## Array Variables

class ArrayVariable < Variable

  def setarysize(size)
    @arysize = size
    @aryrank = size.size
  end

  def arysize
    if (@aryrank == 1)
      if (@arysize[0].to_s !~ /\(/)
        "(" + @arysize[0].to_s + ")" 
      else
	@arysize[0].to_s
      end
    else
      "(" + @arysize.join("*").gsub(/\*1/, "") + ")"
    end
  end

  def aryshape
#    if (@aryrank == 1)
#      if (@arysize[0].to_s !~ /\(/)
#        "(" + @arysize[0].to_s + ")" 
#      else
#	@arysize[0].to_s
#      end
#    else
    "{"+ @arysize.join(", ").gsub(/\*1/, "")+"}"
#    end
  end

  def arg_name
    "" + prefix + name
  end

  def allocworkingarea
    type = vartype.gsub(/\s+\*$/, "")
    %Q$#{prefix+name}= ALLOCA_N(#{type}, #{arysize});\n$
  end

end

class CharacterArrayVariable < ArrayVariable
  include CharacterType

  def arysize
    "(" + (@arysize.join("*") + "*" + @charlen).gsub(/\*1/, "") + ")"
  end

  def ftnlen
    "(ftnlen)#{@charlen}"
  end

  def checktype
    "" +
      %Q$if (TYPE(#{name}) == T_STRING) {\n$ +
      %Q$  #{name} = rb_Array(#{name});\n$ +
      %Q$}\n$ +
      %Q$if (TYPE(#{name}) != T_ARRAY) {\n$ +
      %Q$  rb_raise(rb_eTypeError, "invalid type");\n$ +
      %Q$}\n$
  end

  def initialization
    %Q$#{prefix+name} = #{OBJ2CCHARARY}(#{name}, #{arysize}, #{@charlen});\n$
  end

  def allocworkingarea
    type = vartype.gsub(/\s+\*$/, "")
    %Q$#{prefix+name}= ALLOCA_N(#{type}, #{arysize});\n$ +
    %Q$memset(#{prefix+name}, '\\0', #{arysize});\n$
  end

  def getresult
    %Q$#{name} = #{CCHARARY2OBJ}(#{prefix+name}, #{arysize}, #{@charlen});\n$
  end

  def freecary
    %Q$#{FREECCHARARY}(#{prefix+name});\n$
  end

end

class IntegerArrayVariable < ArrayVariable
  include IntegerType

  VARTYPE += " *"

  def checktype
    "" +
      %Q$if ((TYPE(#{name}) == T_BIGNUM) || (TYPE(#{name}) == T_FIXNUM)) {\n$ +
      %Q$  #{name} = rb_Array(#{name});\n$ +
      %Q$}\n$ +
      %Q$/* if ((TYPE(#{name}) != T_ARRAY) && \n$ +
      %Q$       (rb_obj_is_kind_of(#{name}, cNArray) != Qtrue)) {\n$ +
      %Q$     rb_raise(rb_eTypeError, "invalid type");\n$ +
      %Q$   }  -- no check since obj2c*ary will do that */\n$
  end

  def initialization
    %Q$#{prefix+name} = #{OBJ2CINTEGERARY}(#{name});\n$
  end

  def getresult
    %Q${int array_shape[#{aryrank}] = #{aryshape};\n$ +
    %Q$     #{name} = #{CINTEGERARY2OBJ}(#{prefix+name}, #{arysize}, #{aryrank}, array_shape);\n$ +
    %Q$    }\n$
  end

  def freecary
    %Q$#{FREECINTEGERARY}(#{prefix+name});\n$
  end
end

class RealArrayVariable < ArrayVariable
  include RealType
  VARTYPE += " *"

  def checktype
    "" +
      %Q$if (TYPE(#{name}) == T_FLOAT) {\n$ +
      %Q$  #{name} = rb_Array(#{name});\n$ +
      %Q$}\n$ +
      %Q$/* if ((TYPE(#{name}) != T_ARRAY) && \n$ +
      %Q$       (rb_obj_is_kind_of(#{name}, cNArray) != Qtrue)) {\n$ +
      %Q$     rb_raise(rb_eTypeError, "invalid type");\n$ +
      %Q$   }  -- no check since obj2c*ary will do that */\n$
  end

  def initialization
    %Q$#{prefix+name} = #{OBJ2CREALARY}(#{name});\n$
  end

  def getresult
    %Q${int array_shape[#{aryrank}] = #{aryshape};\n$ +
    %Q$     #{name} = #{CREALARY2OBJ}(#{prefix+name}, #{arysize}, #{aryrank}, array_shape);\n$ +
    %Q$    }\n$
  end

  def freecary
    %Q$#{FREECREALARY}(#{prefix+name});\n$
  end
end

class ComplexArrayVariable < ArrayVariable
  include ComplexType

  VARTYPE += " *"

#  def checktype
#    "" +
#      %Q$if (TYPE(#{name}) == T_XXXXX) {\n$ +
#      %Q$  #{name} = rb_Array(#{name});\n$ +
#      %Q$}\n$ +
#      %Q$if (TYPE(#{name}) != T_ARRAY) {\n$ +
#      %Q$  rb_raise(rb_eTypeError, "invalid type");\n$ +
#      %Q$}\n$
#  end

#  def initialization
#    %Q$#{prefix+name} = #{OBJ2CCOMPLEXARY}(#{name});\n$
#  end

#  def getresult
#    %Q$#{name} = #{CCOMPLEXARY2OBJ}(#{prefix+name}, #{arysize}, "");\n$
#  end

#  def freecary
#    %Q$ #{FREECCOMPLEXARY}(#{prefix+name});\n$
#  end
end

class LogicalArrayVariable < ArrayVariable
  include LogicalType

  VARTYPE += " *"

  def checktype
    "" +
      %Q$#{name} = rb_Array(#{name});\n$
  end

  def initialization
    %Q$#{prefix+name} = #{OBJ2CLOGICALARY}(#{name});\n$
  end

  def getresult
    %Q${int array_shape[#{aryrank}] = #{aryshape};\n$ +
    %Q$     #{name} = #{CLOGICALARY2OBJ}(#{prefix+name}, #{arysize}, #{aryrank}, array_shape);\n$ +
    %Q$    }\n$
  end

  def freecary
    %Q$#{FREECLOGICALARY2}(#{prefix+name});\n$
  end
end

### Character
class CharacterInputArrayVariable < CharacterArrayVariable
  include Input
end

class CharacterOutputArrayVariable < CharacterArrayVariable
  include Output
end

class CharacterInputOutputArrayVariable < CharacterArrayVariable
  include InputOutput
end

class CharacterWorkingArrayVariable < CharacterArrayVariable
  include Working
end

### Integer
class IntegerInputArrayVariable < IntegerArrayVariable
  include Input
end

class IntegerOutputArrayVariable < IntegerArrayVariable
  include Output
end

class IntegerInputOutputArrayVariable < IntegerArrayVariable
  include InputOutput
end

class IntegerWorkingArrayVariable < IntegerArrayVariable
  include Working
end

### Real
class RealInputArrayVariable < RealArrayVariable
  include Input
end

class RealOutputArrayVariable < RealArrayVariable
  include Output
end

class RealInputOutputArrayVariable < RealArrayVariable
  include InputOutput
end

class RealWorkingArrayVariable < RealArrayVariable
  include Working
end

### Complex
class ComplexInputArrayVariable < ComplexArrayVariable
  include Input
end

class ComplexOutputArrayVariable < ComplexArrayVariable
  include Output
end

class ComplexInputOutputArrayVariable < ComplexArrayVariable
  include InputOutput
end

class ComplexWorkingArrayVariable < ComplexArrayVariable
  include Working
end

### Logical
class LogicalInputArrayVariable < LogicalArrayVariable
  include Input
end

class LogicalOutputArrayVariable < LogicalArrayVariable
  include Output
end

class LogicalInputOutputArrayVariable < LogicalArrayVariable
  include InputOutput
end

class LogicalWorkingArrayVariable < LogicalArrayVariable
  include Working
end