ruby-dcl 1.6.2

data/GenWrapper/util.rb

@@ -0,0 +1,9 @@
+# util.rb
+#   $Id: util.rb,v 1.1.1.1 2011-02-23 07:21:28 horinout Exp $
+
+class String
+  def <<(str)
+    self.concat str.to_s
+    self
+  end
+end

data/GenWrapper/variable.rb

@@ -0,0 +1,671 @@
+# variable.rb - Attribute specific modules
+# $Id: variable.rb,v 1.1.1.1 2011-02-23 07:21:28 horinout 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} (#{self.class}) */\n"
+  end
+
+  def initialization
+    "/* initialization: not implemented for #{name} (#{self.class}) */\n"
+  end
+
+  def allocworkingarea
+    nil
+  end
+
+  def getresult
+    "/* getresult: not implemented for #{name} (#{self.class}) */\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} = StringValuePtr(#{r});\n$
+  end
+
+  def basic_r2c_copy(r, c)
+    type = self.vartype.gsub(/\s+\*$/, "")
+    %Q$#{c} = ALLOCA_N(#{type}, strlen(StringValuePtr(#{r}))+1);\n$ +
+    %Q$strcpy(#{c}, StringValuePtr(#{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
+