# # $Id: langprocs.icn,v 1.2 2004/02/12 17:07:55 rparlett Exp $ # # This file is in the public domain. # # Author: Robert Parlett (parlett@dial.pipex.com) # package lang import util # # Return the class name for the instance o # procedure get_class_name(o) image(o) ? { if ="record " then { return tab(find("__state")) | stop("Not a class") } } end # # Get the Class object for this object # procedure get_class(object) return lang::get_class_for_name(get_class_name(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) image(object) ? { if ="record " then { if find("__state") then return "class" else 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) image(object) ? { if ="record " then { if s := tab(find("__state")) then return s else return type(object) } else if ="procedure " then return tab(0) else if ="file(" then return tab(-1) else if ="window_" then { tab(upto('(')) 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 have undefined # results. # # @example # @ x := [1, 2 ,3] # @ write(image(x)) # @ write(get_id(x)) # @ # @ Output: # @ list_5(3) # @ 5 # procedure get_id(object) image(object) ? { while tab(upto('_')) do move(1) return tab(upto('(')) } end # # Generate the record names for a record. The results are undefined for a # non-record type of object. # procedure generate_record_names(object) every i := 1 to *object do { name(object[i]) ? { tab(upto('.')) move(1) suspend tab(0) } } end # # Generate the member names for a class. The results are undefined for a # non-class object. # procedure generate_member_names(object) every name(object[3 to *object]) ? { tab(upto('.')) move(1) suspend tab(0) } end # # Generate the members of a class. The results are undefined for a # non-class object. # procedure generate_class_members(object) suspend object[3 to *object] end # # Return the {n}th member variable of a class. The results are undefined for a # non-class object. # procedure get_class_member(object, n) return object[3 + n] end # # Cast the fields of this object to another object o. # procedure cast(object, other) local i, t t := table() i := 3 every s := generate_member_names(other) do { t[s] := i i +:= 1 } i := 3 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(get_class_for_name(get_class_name(obj)).get_implemented_classes(), 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 /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 := 3 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 /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