ruby-dcl 1.6.2

data/GenWrapper/dcl_rb_footing

@@ -0,0 +1,29 @@
+      # //// Ruby-DCL original extention methods ////
+
+      alias __uemrkz uemrkz 
+      def uemrkz( upx,upy,z,itype,index,rsize )
+
+        #< extract array size(s) (which was(were) formerly an argument(s)) >
+        if ! ( upx == nil || upx.is_a?(Float) && lreq( upx, glrget("RUNDEF") ) )
+          len_upx_0 = upx.length
+          n = len_upx_0
+        else
+          upx = glrget("RUNDEF") if ( upx == nil )
+          len_upy_0 = upy.length
+          n = len_upy_0
+        end
+
+        #< check array size(s) >
+        raise "Invalid array length: upx.length != n" if \
+            upx!=nil && !( upx.is_a?(Float) && lreq(upx,glrget("RUNDEF")) ) && upx.length != (n)
+        raise "Invalid array length: upy.length != n" if \
+            upy!=nil && !( upy.is_a?(Float) && lreq(upy,glrget("RUNDEF")) ) && upy.length != (n)
+        raise "Invalid array length: z.length != n" if \
+            z!=nil && !( z.is_a?(Float) && lreq(z,glrget("RUNDEF")) ) && z.length != (n)
+
+        #< call the original method >
+        __uemrkz( n,upx,upy,z,itype,index,rsize )
+      end
+      module_function :uemrkz, :__uemrkz 
+      private_class_method :__uemrkz
+

data/GenWrapper/dcl_rb_heading

@@ -0,0 +1,129 @@
+require "narray"
+if /cygwin|mingw|darwin/ =~ RUBY_PLATFORM
+  begin
+    require "glib2"
+  rescue LoadError
+  end
+end
+
+require "numru/dcl_raw"
+module NumRu
+    module DCL
+      init_arg($0,ARGV) if DCLVERSION >= "5.3.2"
+
+      #<<< private functions >>>
+
+      def not_nary( na )
+	if defined?(NArrayMiss)
+	  !na.is_a?(NArray) && !na.is_a?(NArrayMiss)
+	else
+	  !na.is_a?(NArray)
+	end
+      end
+      module_function :not_nary
+      private_class_method :not_nary
+
+      #<<< ??p(set|stx|get) >>>
+
+      %w!gl sl sg uc ud ue ug ul um uu uz!.each do |pkg|
+	 %w!set stx!.each do |set|
+	    eval <<-EOS
+	       def #{pkg}p#{set}( name, value )
+		  case name
+		  when /^l/i
+		     DCL.#{pkg}l#{set}(name,value)
+		  when /^[i-n]/i
+		     DCL.#{pkg}i#{set}(name,value)
+		  else
+		     DCL.#{pkg}r#{set}(name,value)
+		  end
+	       end
+	       module_function :#{pkg}p#{set}
+	    EOS
+	 end
+	 eval <<-EOS
+	    def #{pkg}pget( name )
+	       case name
+	       when /^l/i
+		  DCL.#{pkg}lget(name)
+	       when /^[i-n]/i
+		  DCL.#{pkg}iget(name)
+	       else
+		  DCL.#{pkg}rget(name)
+	       end
+	    end
+	    module_function :#{pkg}pget
+	 EOS
+      end
+
+      %w!us!.each do |pkg|
+	 %w!set stx!.each do |set|
+	    eval <<-EOS
+	       def #{pkg}p#{set}( name, value )
+		  case name
+		  when /^c/i
+		     DCL.#{pkg}c#{set}(name,value)
+		  when /^l/i
+		     DCL.#{pkg}l#{set}(name,value)
+		  when /^[i-n]/i
+		     DCL.#{pkg}i#{set}(name,value)
+		  else
+		     DCL.#{pkg}r#{set}(name,value)
+		  end
+	       end
+	       module_function :#{pkg}p#{set}
+	    EOS
+	 end
+	 eval <<-EOS
+	    def #{pkg}pget( name )
+	       case name
+	       when /^c/i
+		  DCL.#{pkg}cget(name)
+	       when /^l/i
+		  DCL.#{pkg}lget(name)
+	       when /^[i-n]/i
+		  DCL.#{pkg}iget(name)
+	       else
+		  DCL.#{pkg}rget(name)
+	       end
+	    end
+	    module_function :#{pkg}pget
+	 EOS
+      end
+
+      @@sw_char_params = [/^WSNAME/i,/^FONT/i,/^CL2TN$/i,/^FNAME$/i,/^TITLE$/i,
+	    /^CLRMAP$/i,/^LPR$/i]
+      %w!set stx!.each do |set|
+         eval <<-EOS
+	    def swp#{set}(name, value)
+	       case name
+	       when *@@sw_char_params
+		  DCL.swc#{set}(name,value)
+	       when /^l/i
+		  DCL.swl#{set}(name,value)
+	       when /^[i-n]/i
+		  DCL.swi#{set}(name,value)
+	       else
+		  DCL.swr#{set}(name,value)
+	       end
+	    end
+	    module_function :swp#{set}
+	 EOS
+      end
+      def swpget( name )
+	 case name
+	 when *@@sw_char_params
+	    DCL.swcget(name)
+	 when /^l/i
+	    DCL.swlget(name)
+	 when /^[i-n]/i
+	    DCL.swiget(name)
+	 else
+	    DCL.swrget(name)
+	 end
+      end
+      module_function :swpget
+
+
+      #<<< to eliminate array length arguments >>>
+

data/GenWrapper/def.rb

@@ -0,0 +1,20 @@
+# def.rb
+#   $Id: def.rb,v 1.1.1.1 2011-02-23 07:21:28 horinout Exp $
+
+OBJ2CCHARARY    = "dcl_obj2ccharary"
+OBJ2CINTEGERARY = "dcl_obj2cintegerary"
+OBJ2CREALARY    = "dcl_obj2crealary"
+OBJ2CCOMPLEXARY = "dcl_obj2ccomplexary"
+OBJ2CLOGICALARY = "dcl_obj2clogicalary"
+
+CCHARARY2OBJ    = "dcl_ccharary2obj"
+CINTEGERARY2OBJ = "dcl_cintegerary2obj"
+CREALARY2OBJ    = "dcl_crealary2obj"
+CCOMPLEXARY2OBJ = "dcl_ccomplexary2obj"
+CLOGICALARY2OBJ = "dcl_clogicalary2obj"
+
+FREECCHARARY    = "dcl_freeccharary"
+FREECINTEGERARY = "dcl_freecintegerary"
+FREECREALARY    = "dcl_freecrealary"
+FREECCOMPLEXARY = "dcl_freeccomplexary"
+FREECLOGICALARY = "dcl_freeclogicalary"

data/GenWrapper/elim_ary_size.rb

@@ -0,0 +1,398 @@
+# Eliminate array size arguments
+#  May 13, 2002   T. Horinouchi  
+#
+# Usage:
+# % ruby generate_new_rbdcl.rb proto_files
+# where files are grph2_uvpack.fp math2_fftlib.fb etc (in the proto directory)
+
+class Variable
+  def initialize(decl)
+    name, *tmp = decl.split.reverse
+    tmp.reverse!
+    attr = (tmp[-1] =~ /^[a-z]+$/ ? tmp.pop : "i")
+    ary =  (tmp[-1] =~ /^\((.*)\)/ ? (tmp.pop; $1.downcase) : false)
+    vtype = tmp.pop
+    if (/(\d+)|\*\((.*)\)/ =~ vtype)
+      charlen = ($1||$2).downcase   # may be charcter length
+      vtype = vtype.scan(/\w+/)[0]
+    else
+      charlen = nil
+    end
+    @name = name.downcase
+    @attr = attr
+    @ary = ary
+    @vtype = vtype.downcase
+  end
+
+  attr_reader(:name, :attr, :ary, :vtype)
+end
+
+def pre_filter(decl)
+  case $method_name
+  when /(^ud|^ue)/
+    # replace MX with NX
+    decl.gsub!('MX','NX')
+  when /^ug/
+    # replace MU & MV with NX
+    decl.gsub!(/(MU|MV)/,'NX')
+  end
+  decl
+end
+
+def extract_args(proto)
+  args_org = []
+  while ( decl = proto.gets )
+    break if decl =~ /^ *\)$/
+    decl = pre_filter(decl)
+    if ( decl !~ /^\s*$/ )
+      print decl if $DEBUG
+      var = Variable.new(decl)
+      p var if var.ary if $DEBUG
+      if var.attr != "o" && var.attr != "t"
+	args_org.push(var)
+      else
+      end
+    end
+  end
+  args_org
+end
+
+def has_array?( args )
+  args.each do |v|
+    return true if v.ary
+  end
+  false
+end
+
+def new_args( args_org )
+  del_argname = []
+  args_org.each do |v|
+    if ( (shape = v.ary) )
+      shape = shape.split(',')
+      shape.each do |lendef|
+	lpos = lendef.index(/([a-z]\w*)/)
+	m = $1
+	if ( lpos )
+	  lpos2 = lendef.index(/([a-z]\w*)/,lpos+m.length)
+	  if (!lpos2)
+	    # to be deleted only when unambiguous
+	    del_argname.push(m) if m && !del_argname.include?(m)
+	  end
+	end
+      end
+    end
+  end
+  args_new = args_org.clone
+  del_argname.each do |nm|
+    args_new.delete_if {|v| 
+	v.name == nm
+    }
+  end
+  print "  ORG: ", args_org.collect{|i| i.name}.join(','),"\n" if $DEBUG
+  print "  NEW: ", args_new.collect{|i| i.name}.join(','),"\n" if $DEBUG
+  print "  args deleted: ",del_argname.join(','),"\n" if $DEBUG
+  [args_new, del_argname]
+end
+
+
+def new_def( args_org, args_new, del_argname )
+  method_def = <<-EOS
+      alias __#{$method_name} #{$method_name} 
+      def #{$method_name}( #{args_new.collect{|i| i.name}.join(',')} )
+  EOS
+  method_def.concat( del_arg_deriv( args_new, del_argname ) )
+  args_org_names = args_org.collect{|arg| arg.name}
+  method_def.concat( check_array_size( args_new, args_org_names ) )
+  method_def.concat( <<-EOS
+
+        #< call the original method >
+        __#{$method_name}( #{args_org.collect{|i| i.name}.join(',')} )
+      end
+      module_function :#{$method_name}, :__#{$method_name} 
+      private_class_method :__#{$method_name}
+
+  EOS
+  )
+
+  #print '*** ',method_def
+  method_def
+end
+
+#def wrap_in_rundef_rescue(
+#        if ( #{v.name}.is_a(Float) && x == glrget("RMISS") )
+#end
+
+def del_arg_deriv( args_new, del_argname )
+  deriv = ""
+  first = true
+  del_argname.each do |nm|
+    ary = []
+    args_new.each do |v|
+      if v.ary && v.ary =~ /\W*#{nm}\W*/
+	ary.push( [ v.name, inv_deriv(nm, v.ary, v.name) ] )
+	if (!possibly_rundef?(nm, v.name))
+	  break
+	end
+      end
+    end
+    if(first)
+      deriv = <<-EOS
+
+        #< extract array size(s) (which was(were) formerly an argument(s)) >
+      EOS
+      first = false
+    end
+    deriv.concat( recursive_join( ary ) )
+  end
+  deriv
+end
+
+def possibly_rundef?(argname, varname)
+  case $method_name
+  when /(^usgrph|^usspnt)/
+    if( argname == 'n' && varname == 'x' )
+      return true
+    elsif ( argname == nil )
+      return true
+    end
+  when /(^uulin|^uumrk|^uv|^uh)/
+    if ( argname == 'n' && 
+	( varname == 'upx'  || varname == 'upy'  ||
+	  varname == 'upx1' || varname == 'upx2' || 
+	  varname == 'upy1' || varname == 'upy2' ) )
+      return true
+    elsif ( argname == nil )
+      return true
+    end
+  end
+  false
+end
+
+def recursive_join( ary )
+  first = ary.shift
+  if( ary.length > 0)
+    str = <<-EOS
+        if ! ( #{first[0]} == nil || #{first[0]}.is_a?(Float) && lreq( #{first[0]}, glrget("RUNDEF") ) )
+#{first[1].gsub(/^/,"  ").chop}
+        else
+    EOS
+    str += <<-EOS
+          #{first[0]} = glrget("RUNDEF") if ( #{first[0]} == nil )
+#{recursive_join(ary).gsub(/^/,"  ").chop}
+        end
+    EOS
+  else
+    first[1]
+  end
+end
+
+
+def inv_arithm(lendef, varname)
+  case lendef
+  when varname
+    form = "LEN"
+  when /^(\w+) *\* *#{varname}$/
+    form = "LEN / #{$1}"
+  when /^#{varname} *\/ *(\w+)$/
+    form = "LEN * #{$1}"
+  when /^#{varname} *\+ *(\w+)$/
+    form = "LEN - #{$1}"
+  when /^\(*(\w+) *\* *#{varname} *\+ *(\w+)\)*$/
+    form = "( LEN - #{$2} ) / #{$1}"
+  else
+    raise 'unsuppoerted dimension specification : '+lendef
+  end
+  form
+end
+
+def inv_deriv(argname, shape, aryname)
+  deriv = ""
+  shape = shape.split(',')
+  multiD = ( shape.length > 1 )
+  shape.each_index do |i|
+    if (lendef=shape[i]) =~ /\W*#{argname}\W*/
+      idim = i
+      form = inv_arithm( lendef, argname )
+      form.sub!('LEN',"len_#{aryname}_#{idim}")
+      if multiD
+	deriv = <<-EOS
+        if ( not_nary(#{aryname}) || (#{aryname}.rank < #{idim+1}) )
+          raise "#{aryname} must be a NArray of rank == #{shape.length}"
+        end
+        len_#{aryname}_#{idim} = #{aryname}.shape[#{idim}]
+	EOS
+      else
+	deriv = <<-EOS
+        len_#{aryname}_#{idim} = #{aryname}.length
+	EOS
+      end
+      deriv.concat( <<-EOS
+        #{argname} = #{form}
+      EOS
+      )
+      print deriv if $DEBUG
+      break
+    end
+  end
+  deriv
+end
+
+def aster2dimlen_if_possible( varname, dimlen ) 
+  if $method_name =~ /(^rvmax|^rvmin)/ && varname == 'rx'
+    dimlen.replace('(len=1; ns.each{|i| len*=i}; len)')
+    true
+  else
+    raise $!
+  end
+end
+
+def consist_of_names?(str, names)
+  ary = str.split(/\W/).uniq     
+  names.each{|str| ary.delete(str)}
+  ary.each do |str| 
+    return false if (/^\d*$/ !~ str)
+  end
+  true
+end
+
+def check_array_size( args_new, args_org_names )
+  body = <<-EOS
+
+        #< check array size(s) >
+  EOS
+  args_new.each do |v|
+    if ( v.ary )
+      shape = v.ary.split(',')
+      if ( shape.length == 1 )
+	arylen_replaced = false
+	if ( shape[0] == '*' )
+	  begin
+	    raise "Array #{v.name} is declared using *"
+	  rescue
+	    arylen_replaced = aster2dimlen_if_possible( v.name, shape[0] ) 
+	  end
+	end
+	if possibly_rundef?(nil, v.name)
+	  ins = "\\\n            #{v.name}!=nil && !( #{v.name}.is_a?(Float) && lreq(#{v.name},glrget(\"RUNDEF\")) ) && "
+	else
+	  ins = ""
+	end
+	if arylen_replaced || consist_of_names?(shape[0], args_org_names )
+	body.concat( <<-EOS
+        raise "Invalid array length: #{v.name}.length != #{shape[0]}" if #{ins}#{v.name}.length != (#{shape[0]})
+	EOS
+	)
+	end
+      else
+	shape.each_index do |i|
+ 	  if ( shape[i] == '*' )
+	    raise "Array #{v.name}'s #{i}-th dim is declared using *"
+          end
+          body.concat( <<-EOS
+        raise "Invalid array shape: #{v.name}.shape[#{i}] != #{shape[i]}" if #{v.name}.shape[#{i}] != (#{shape[i]})
+	  EOS
+          )
+        end
+      end
+    end
+  end
+  body
+end
+
+def head
+  f = File.open('dcl_rb_heading')
+  heading = f .readlines
+  f.close
+  heading
+end
+
+def foot
+  f = File.open('dcl_rb_footing')
+  footing = f .readlines
+  f.close
+  footing
+end
+
+def close
+  return <<-EOS
+    end
+end
+  EOS
+end
+
+def post_filter( ndf )
+  if $method_name == 'udcntz'
+    ndf.sub!(/,nbr2/,'')
+    add = <<-EOS
+        # derivation of nbr2 is provied aditionally in the method post_filter:
+        nbr2 = (nx+2)*(ny+2)*6/32+4
+
+    EOS
+    ndf =~ /(^ *\#.*check array size.*$)/
+    ndf[$1] = add + $1
+  end
+end
+
+def delete_comment(src) # [ruby-list:32030] [ruby-list:32049]
+  src.gsub(%r@ ([\'\"])(\\.|.)*?\1
+               | (/\*.*?\*/)      
+               | (//)[^\n]*$      
+               @mx) {
+    if $3
+      s = $3.delete("^\n")
+      s = ' ' if s.empty?
+      s
+    elsif $4
+      ''
+    else
+      $&
+    end
+  }
+end
+
+#####################  (main) ###########################
+require "tempfile"
+files = ARGV
+ofilename = "../lib/dcl.rb"
+ofile = open( ofilename, "w+" )
+ofile.puts( head() )
+for f in files
+  print "processing file #{f}\n"
+  #proto = open("| cat #{f} | gcc -E -", "r+")
+  #proto.close_write
+  fl = File.open(f)
+  proto = Tempfile.new('proto', '.')
+  proto.print( delete_comment(fl.read) )
+  proto.sync
+  proto.rewind
+  fl.close
+  while ( line = proto.gets )
+    case line
+    when /^ *SUBROUTINE *(\w+)|^ *\w+ *FUNCTION *(\w+)/
+      $method_name = ( $1 || $2 ).downcase
+      print $method_name+"\n" if $DEBUG
+      args_org = extract_args(proto)
+      if ( has_array?(args_org) )
+	# redefine the method
+	args_new, del_argname = new_args( args_org )
+	ndf = new_def( args_org, args_new, del_argname )
+	post_filter( ndf )
+	ofile.puts( ndf )
+      end
+    when /^#if *DCLVER *([<=>]+) *(\d\d\d)/
+      op = $1
+      ver = "'"+$2.split(//).join('.')+"'"   # "'5.3.1'" etc
+      ver.sub!(/\.0/,'')
+      ofile.print("      if DCLVERSION #{op} #{ver}\n")
+    when /^#endif/
+      ofile.print("      end\n\n")
+    end
+  end
+  proto.close
+end
+
+ofile.puts( foot() )
+ofile.puts( close() )
+ofile.close
+
+print "generated the DCL module file #{ofilename}\n"