compare.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
-------------------------> GNU Sather - sourcefile <-------------------------
-- Copyright (C) 2000 by K Hopper, University of Waikato, New Zealand --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute and/or modify it under the terms of the GNU Library General --
-- Public License (LGPL) as published by the Free Software Foundation; --
-- either version 2 of the license, or (at your option) any later version. --
-- This library is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details. --
-- The license text is also available from: Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --
--------------> Please email comments to <bug-sather@gnu.org> <--------------
class ELT_EQ{ETP}
class ELT_EQ{ETP} is
-- This class provides the equality comparison function for elements
-- of type ETP. If no user methos has been provided then a default system-
-- defined equality is used.
-- Version 1.1 Mar 00. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 21 Nov 98 kh Original from Sather 1.2 dist
-- 23 Mar 00 kh No longer a partial class
elt_eq(first, second : ETP) : BOOL is
-- This predicate returns true if and only if the two arguments are equal.
-- The equality relation uses the user defined is_eq routine,
-- if the argument type is a subtype of $IS_EQ. Otherwise it uses the system
-- defined equality routine is used.
typecase first
--when $FMT then return SYS::ob_eq(first,second) -- test
when $IS_EQ then return first.is_eq(second);
else return SYS::ob_eq(first,second)
end
end ;
end ; -- ELT_EQ
class ELT_LT{ETP}
class ELT_LT{ETP} is
-- This class provides the less than comparison facility for the given
-- element type.
-- Version 1.1 Mar 00. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 21 Nov 98 kh Original from Sather 1.2
-- 23 Mar 90 kh No longer a partial class
private verify_can_call_lt(
first,
second : $OB
) : BOOL is
-- This private predicate is used in the assertion in the following
-- routine to establish whether or not a less than comparison on first and
-- second can be done, when true is returned! Neither of the two operands
-- may be void nor may they be immutable!
if void(first)
or void(second) then
return false
elsif REFERENCE::is_immutable(first)
or REFERENCE::is_immutable(second) then
return false
else
return true
end
end ;
elt_lt(
first,
second : ETP
) : BOOL is
-- This predicate returns true if and only if the first argument is less
-- than second. Should there be no user-defined operation then an assertion
-- is used to ensure that the system relation predicate is valid - if not
-- then the assertion fails.
typecase first
when $IS_LT{ETP} then
return first.is_lt(second)
else
assert verify_can_call_lt(first,second) ;
return SYS::id(first) < SYS::id(second)
end
end ;
end ; -- ELT_LT
class ELT_HASH
class ELT_HASH is
-- This class provides the hash value of an object. This is guaranteed
-- to be the same on repeated calls on the same object.
-- Version 1.1 Mar 00. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 21 Nov 98 kh Original from Sather 1.2
-- 23 Mar 00 kh No longer a partial class
private verify_can_call_hash(item : $OB) : BOOL is
-- This private predicate returns true if and only if item is of
-- a reference type.
return ~REFERENCE::is_immutable(item)
end ;
elt_hash(item : $OB) : CARD is
-- This routine returns a hash value for the given item, using the
-- user-defined hash routine if one is defined. Otherwise, uses the system
-- defined hash function.
typecase item
when $HASH then
return item.hash
when $IS_EQ then -- therefore cannot use SYS routine
SYS_ERROR::create.error(self,SYS_EXCEPT::Bad_Type,
SYS::str_for_tp(SYS::tp(item))) ;
return void -- to keep compiler happy!
else
if void(item) then -- special case for valid voids!
return 0
else
assert verify_can_call_hash(item) ;
return SYS::id(item).hash
end
end
end ;
end ; -- ELT_HASH
class ELT_NIL{ETP}
class ELT_NIL{ETP} is
-- This class provides a nil value for an object of type ETP.
-- This operation does not work for abstract types!
-- Version 1.1 Mar 00. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 21 Nov 98 kh Original from Sather 1.2
-- 23 Mar 00 kh No longer a partial class
elt_nil : ETP is
-- This routine returns a 'nil' value for the given class if one
-- exists, otherwise void.
loc_val : ETP ;
typecase loc_val
when $NIL then
res : $NIL := loc_val.nil ; -- This is of abstract type $NIL
typecase res -- needed to return value of ETP
when ETP then
return res
end
else
return void
end
end ;
is_elt_nil(
item : ETP
) : BOOL is
-- This predicate returns true if and only if ETP defines a nil value
-- and item has that value.
typecase item
when $IS_NIL then
return item.is_nil
else
return void(item)
end
end ;
end ; -- ELT_NIL
partial class COMPARE{ETP}
partial class COMPARE{ETP} is
-- This partial class should be included by containers of elements of
-- class ETP which must provide an elt_eq, an elt_lt, elt_hash, elt_nil or
-- is_elt_nil routines. The user defined functions are used by default,
-- otherwise the implementation defined equality, hash and nil if it is
-- possible and correct to do so.
-- Version 1.1 Nov 98. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 16 Dec 96 kh Original from Sather dist abstract.sa
-- 21 Nov 98 kh Rewrite for Sather 1.2 distrib.
elt_eq(first,second : ETP) : BOOL is
-- This is the standard 'less than' predicate used in sorting routines.
-- The using class must specify an equality predicate routine.
return ELT_EQ{ETP}::elt_eq(first,second)
end ;
elt_lt(first,second : ETP) : BOOL is
-- This routine is the standard predicate 'less than' for use in
-- sorting. By default the object identity components are compared.
-- It may be redefined in descendants.
return ELT_LT{ETP}::elt_lt(first,second)
end ;
elt_hash(elem : $OB) : CARD is
-- This routine returns a hash value associated with an element. This
-- must have the property that if "elt_eq(first,second)" then
-- "elt_hash(first)=elt_hash(second)". It could be defined always to return 0,
-- but many routines will then become quadratic. This uses the object "id" by
-- default. It may be redefined in descendants.
return ELT_HASH::elt_hash(elem)
end ;
elt_nil : ETP is
-- This routine returns the NIL value. If the element class is a
-- subclass of $NIL then it returns nil, otherwise void.
return ELT_NIL{ETP}::elt_nil
end ;
is_elt_nil( elem : ETP) : BOOL is
-- This predicate returns true if and only if elem is NIL.
return ELT_NIL{ETP}::is_elt_nil(elem)
end ;
end ; -- COMPARE
partial class COMPARABLE
partial class COMPARABLE is
-- This partial class implements the generalized equality routine. Where
-- classes require comparison routines they should provide an is_eq(SAME)
-- and include this class to provide the more general versions
-- Version 1.0 Dec 96. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 11 Dec 96 kh Original from standard Sather dist.
stub is_eq(other : SAME) : BOOL ;
-- This stub is a 'forward' definition notifier for the is_eq routine
-- which an importing class must provide.
is_eq(other : $OB) : BOOL is
-- This is the generic equality predicate. c.f. the class $IS_EQ
typecase other
when SAME then return is_eq(other)
else
#OUT+"class mismatch:"+SYS::str_for_tp(SYS::tp(self))
+"::is_eq("+SYS::str_for_tp(SYS::tp(other))+")\n";
raise 2;
--return false;
end
end ;
end ; -- COMPARABLE