#
# $Id: langprocs.icn,v 1.8 2009-10-28 21:07:18 to_jafar Exp $
#
# This file is in the public domain.
#
# Author: Robert Parlett (parlett@dial.pipex.com)
#   Addition of call_by_name by Steve Wampler (sbw@tapestry.tucson.az.us)
#   Changes to use standard Unicon functions.
#
invocable all

package lang

import util

#
# Return the class name for the instance o
#
# <i>Deprecated in favor of function <tt>classname(o)</tt>.</i>
#
procedure get_class_name(o)
   return ::classname(o)
end

#
# Get the Class object for this object
#
procedure get_class(object)
   return lang::get_class_for(object)
end

#
# Return the type of the object, as a string.  For standard Icon types,
# this is the value returned by the {type()} function.  For records, it
# is the string "record" and for classes it is the string "class".
#
procedure get_type(object)
   if ::classname(object) then {
      return "class"
   } else {
      ::image(object) ? {
         if ="record " then {
            return "record"
	    }
         else {
	    return ::type(object)
	    }
      }
   }
end

#
# Return the name of the object.  For a record this is the type name;
# for a class it is the class name, for a procedure the procedure name,
# for a file the filename and for a window the window name.  For all other
# types, this method fails.
#
procedure get_name(object)
   local s
   if s := ::classname(object) then {
      return s
   } else {
      ::image(object) ? {
         if ="record " then {
            return ::type(object)
	 }
         else if ="procedure " then
            return ::tab(0)
         else if ="file(" then
            return ::tab(-1)
         else if ="window_" then {
            ::tab(::find("("))
            ::move(1)
            return ::tab(-1)
         }
      }
   }
end

#
# Return the id of the object, based on the string returned by {image()}.  For
# types that do not produce such a value, this method will fail for values that
# do not have a serial number.
#
# <i>Deprecated in favor of function <tt>serial()</tt>.</i>
#
# @example
# @ x := [1, 2 ,3]
# @ write(::image(x))
# @ write(get_id(x))
# @
# @ Output:
# @ list_5(3)
# @ 5
#
procedure get_id(object)
   return ::serial(object)
end

#
# Generate the record names for a record.  All other values/objects will cause
# failure.
#
procedure generate_record_names(object)
   if get_type(object) == "record" then {
      suspend ::fieldnames(object)
   }
end

#
# Generate the names of the member variables of an object. All other values/objects
# will cause failure.
#
procedure generate_member_names(object)
   local l, el
   if get_type(object) == "class" then {
      l := ::membernames(object)
      every el := !l do {
         if el == ("__s" | "__m") then {
            next
         } else {
            suspend el
         }
      }
   }
end

#
# Generate the values of the member variables of an object.  All other values/objects
# will cause failure.
#
procedure generate_class_members(object)
   suspend object[generate_member_names(object)]
end

#
# Return the value of the {n}th member variable of an object.
# The results are undefined for a non-class object.
#
procedure get_class_member(object, n)
   return object[1 + n]
end

#
# Cast the fields of this object to another object o.
#
procedure cast(object, other)
   local i, t, s

   t := ::table()
   i := 1
   every s := generate_member_names(other) do {
      t[s] := i
      i +:= 1
      }

   i := 1
   every s := generate_member_names(object) do {
      other[\t[s]] := object[i]
      i +:= 1
      }
   return other
end

#
# Succeed iff the given object is an instance of the class with the given name.
#
procedure is_instance(obj, name)
   return ::member(lang::get_class_for(obj).get_implemented_classes(), lang::mapPackageInt2Ext(name))
end

#
# The default behaviour for Object.equals
#
procedure object_equals(obj, other, seen)
   local i

   /seen := ::table()
   /seen[obj] := ::set()
   ::insert(seen[obj], other)
   get_type(other) == "class" | fail
   get_name(obj) == get_name(other) | fail
   if *obj ~= *other then
      fail
   every i := 1 to *obj do
      equals(obj[i], other[i], seen) | fail
   return
end

#
# Compare this object with another by recursively comparing all
# members of the object.
#
procedure equals(x, y, seen)
   local cx, cy, i

   /seen := ::table()

   if ::member(\seen[x], y) then
      return

   if get_type(x) ~== get_type(y) then
      fail

   case get_type(x) of {
      "class" : {
         /seen[x] := ::set()
         ::insert(seen[x], y)

         #
         # If x subclasses Object, use its .equals method.
         #
         if is_instance(x, "lang::Object") then
            return x.equals(y, seen)
         else
            return object_equals(x, y, seen)
      }

      "record" : {
         /seen[x] := ::set()
         ::insert(seen[x], y)
         get_name(x) == get_name(y) | fail
         if *x ~= *y then
            fail
         every i := 1 to *x do
            equals(x[i], y[i], seen) | fail
         return
      }

      "list" : {
         /seen[x] := ::set()
         ::insert(seen[x], y)
         if *x ~= *y then
            fail
         every i := 1 to *x do
            equals(x[i], y[i], seen) | fail
         return
      }

      "set" : {
         /seen[x] := ::set()
         ::insert(seen[x], y)
         if *x ~= *y then
            fail
         return equals(::sort(x), ::sort(y), seen)
      }

      "table" : {
         /seen[x] := ::set()
         ::insert(seen[x], y)
         equals(x[[]], y[[]]) | fail
         return equals(::sort(x), ::sort(y), seen)
      }

      default : {
         if get_name(x) ~== get_name(y) then
            fail
         return x === y
      }
   }
end

procedure hash_string(s)
   local n
   n := *s
   every n +:= ::ord(!s \ 10)
   return n
end

#
# The default behaviour for Object.hash_code
#
procedure object_hash_code(o, depth, seen)
   local n
   /seen := ::table()
   /depth := 3
   seen[o] := 1
   n := 0
   every n +:= hash_code(!o \ 10, depth - 1, seen)
   return n
end

#
# Return a hash code for this object.  For any two objects for which {equals} indicates
# equality, the returned hash code should be the same.
#
procedure hash_code(x, depth, seen)
   local cx, cy, i, n

   /seen := ::table()
   /depth := 3

   if (depth = 0) | \seen[x] then
      return 0

   n := 0

   case get_type(x) of {
      "class" : {
         seen[x] := 1
         if is_instance(x, "lang::Object") then
            return x.hash_code(depth, seen)
         else
            return object_hash_code(x, depth, seen)
      }

      "record" | "list" : {
         seen[x] := 1
         every n +:= hash_code(!x \ 10, depth - 1, seen)
      }

      "set" : {
         seen[x] := 1
         every n +:= hash_code(!::sort(x) \ 10, depth - 1, seen)
      }

      "table" : {
         seen[x] := 1
         n +:= hash_code(x[[]], depth - 1, seen)
         every n +:= hash_code(!::sort(x) \ 10, depth - 1, seen)
      }

      "string" :
         n +:= hash_string(x)

      "cset" :
         n +:= hash_string(::string(x))

      "integer" :
         n +:= ::abs(x)

      "real" :
         n +:= hash_string(::string(x))

      default :
         n +:= hash_string(get_name(x))
   }
   return n
end

#
# The default behaviour for Object.clone
#
procedure object_clone(o, seen)
   local res, i

   /seen := ::table()
   res := ::proc(get_name(o))()
   seen[o] := res
   every i := 1 to *o do
      res[i] := clone(o[i], seen)
   return res
end

#
# Clone the given object
#
procedure clone(o, seen)
   local c, e, ty, res, t, i

   /seen := ::table()

   if res := \seen[o] then
      return res

   ty := get_type(o)

   case ty of {
      "class" : {
         if is_instance(o, "lang::Object") then {
            t := o.clone(seen)
            seen[o] := t
            return t
         } else
            return object_clone(o, seen)
      }

      "record" : {
         res := ::proc(get_name(o))()
         seen[o] := res
         every i := 1 to *o do
            res[i] := clone(o[i], seen)
         return res
      }

      "set" : {
         res := ::set([])
         seen[o] := res
         every ::insert(res, clone(!o, seen))
         return res
      }

      "list" : {
         res := []
         seen[o] := res
         every ::put(res, clone(!o, seen))
         return res
      }

      "table" : {
         res := ::table(clone(o[[]], seen))
         seen[o] := res
         every e := !::sort(o) do
            res[clone(e[1], seen)] := clone(e[2], seen)
         return res
      }

      default :
         return o
   }
end

#
# The default behaviour for Object.to_string
#
procedure object_to_string(o, depth, seen)
   local i, s, string_buff

   /seen := ::table()
   /depth := -1
   seen[o] := 1
   string_buff := StringBuff()

   string_buff.add(get_type(o) || " " || get_name(o) || "<" || get_id(o) || ">")
   if depth ~= 0 then {
      string_buff.add("(")
      i := 1
      every s := generate_member_names(o) do {
         string_buff.add(s || "=")
         string_buff.add(to_string(o[i], depth - 1, seen))
         string_buff.add(";")
         i +:= 1
      }
      string_buff.drop_last(";")
      string_buff.add(")")
   }

   return string_buff.get_string()
end

#
# Convert the object to string ,descending structures to the given depth
#
# @param o       The object to be converted.
# @param depth   The depth of recursion; default is all levels
#
procedure to_string(o, depth, seen)
   local ty, string_buff, s, i, e, pairs

   /seen := ::table()
   /depth := -1

   if \seen[o] then {
      if s := get_name(o) then
         return "ref " || get_type(o) || " " || s || "<" || get_id(o) || ">"
      else
         return "ref " || get_type(o) || "<" || get_id(o) || ">"
   }

   string_buff := StringBuff()

   ty := get_type(o)

   case ty of {
      "record" : {
         seen[o] := 1
         string_buff.add(ty || " " || get_name(o) || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("(")
            i := 1
            every s := generate_record_names(o) do {
               string_buff.add(s || "=")
               string_buff.add(to_string(o[i], depth - 1, seen))
               string_buff.add(";")
               i +:= 1
            }
            string_buff.drop_last(";")
            string_buff.add(")")
         }
      }

      "class" : {
         seen[o] := 1

         if is_instance(o, "lang::Object") then
            string_buff.add(o.to_string(depth, seen))
         else
            string_buff.add(object_to_string(o, depth, seen))
      }

      "procedure" :
         string_buff.add(ty || " " || get_name(o))

      "null" :
         string_buff.add("&null")

      "string" :
         string_buff.add("\"" || format_escape(o) || "\"")

      "cset" :
         string_buff.add("\'" || format_escape(o) || "\'")

      "integer" :
         string_buff.add(o)

      "real" :
         string_buff.add(o)

      "set" : {
         seen[o] := 1
         string_buff.add(ty || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("{")
            every e := !o do {
               string_buff.add(to_string(e, depth - 1, seen))
               string_buff.add(", ")
            }
            string_buff.drop_last(", ")
            string_buff.add("}")
         }
      }

      "list" : {
         seen[o] := 1
         string_buff.add(ty || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("[")
            every e := !o do {
               string_buff.add(to_string(e, depth - 1, seen))
               string_buff.add(", ")
            }
            string_buff.drop_last(", ")
            string_buff.add("]")
         }
      }

      "table" : {
         seen[o] := 1
         string_buff.add(ty || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("def=")
            string_buff.add(to_string(o[[]], depth - 1, seen))
            pairs := ::sort(o)
            string_buff.add("[")
            every e := !pairs do {
               string_buff.add(to_string(e[1], depth - 1, seen))
               string_buff.add("=")
               string_buff.add(to_string(e[2], depth - 1, seen))
               string_buff.add(";")
            }
            string_buff.drop_last(";")
            string_buff.add("]")
         }
      }

      "co-expression" : {
         string_buff.add(ty || "<" || get_id(o) || ">")
      }

      "file" : {
         string_buff.add(ty || "(" || get_name(o) || ")")
      }

      "window" : {
         string_buff.add(ty || "<" || get_id(o) || ">(" || get_name(o) || ")")
      }

      default :
         string_buff.add("unknown type")
   }

   return string_buff.get_string()
end

#
# Look for the method in the given object.
#
# @param obj         The object in which to find the method
# @param method_name The name of the method
# @return            a procedure object, being the method
# @fail              if the method cannot be found.
#
procedure find_method(obj, method_name)
   return lang::get_class(obj).get_method(method_name).get_as_procedure()
end

#
# Invoke a procedure by string name.
# This is a convenience procedure for invoking a procedure given its
#   string name.  The primary convenience is that it maps external
#   package procedure names into internal form for string-invocation.
#   An example of its use would be to call the constructor for some
#   class identified by its string name at runtime.
#
# @param f_name -- Name of procedure
# @param f_args... -- arguments to pass to the procedure, if any
# @return result of invocation
#
procedure call_by_name(f_name, f_args[])
   local intName
   /f_args := []
   intName := ""
   f_name ? {
       while intName ||:= ::tab(::find("::")) || (::move(2),"__")
       intName ||:= ::tab(0)
       }
   return intName ! f_args
end