--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/xquery/trunk/XQuery__CastingRules.st	Wed Apr 07 12:37:26 2010 +0000
@@ -0,0 +1,105 @@
+"{ Package: 'stx:goodies/xmlsuite/xquery' }"
+
+"{ NameSpace: XQuery }"
+
+Object subclass:#CastingRules
+	instanceVariableNames:'rules'
+	classVariableNames:''
+	poolDictionaries:''
+	category:'XQuery-TypeCasting'
+!
+
+
+!CastingRules methodsFor:'accessing'!
+
+rules
+    rules ifNil: 
+    [
+        self initRules.
+    ].
+    ^ rules
+
+    "Modified: / 18-11-2009 / 00:57:43 / Jan Kurs <kursj1@fel.cvut.cz>"
+!
+
+rules:something
+    rules := something.
+! !
+
+!CastingRules methodsFor:'casting'!
+
+cast: atomicValue to: anotherTypeName
+    | type anotherType castingRule |
+
+    type := TypeFactory getType: atomicValue typeName.
+    anotherType := TypeFactory getType: anotherTypeName.
+
+    ((TypeFactory current isType: type subtypeOf: TypeXSAnyAtomicType instance) and:
+        [ TypeFactory current isType: anotherType subtypeOf: TypeXSAnyAtomicType instance]) ifFalse:
+    [
+        TypeError raiseErrorString: 'casting is allowed only for simple atomic types'.
+    ].
+
+    castingRule := self selectCastingRuleFor: type and: anotherType.
+    ^ castingRule cast: atomicValue to: anotherType.
+
+    "Created: / 07-11-2009 / 16:19:16 / Jan Kurs <kursj1@fel.cvut.cz>"
+    "Modified: / 21-11-2009 / 18:50:13 / Jan Kurs <kursj1@fel.cvut.cz>"
+!
+
+selectCastingRuleFor: type and: anotherType
+    self rules do:
+    [ : rule |
+        (rule accept: type and: anotherType) ifTrue:
+        [
+"/            Transcript showCR: 'selected rule: ', rule asString.
+            ^ rule
+        ]
+    ].
+    self shouldNeverBeReached.
+
+"/    (self primitiveToPrimitive accept: type and: anotherType) ifTrue:
+"/    [
+"/        ^ self primitiveToPrimitive.
+"/    ].
+"/    (self parentToDerived accept: type and: anotherType) ifTrue:
+"/    [
+"/        ^ self parentToDerived.
+"/    ].
+"/    (self derivedToParent accept: type and: anotherType) ifTrue:
+"/    [
+"/        ^ self derivedToParent.
+"/    ].
+"/    (self withinBranch accept: type and: anotherType) ifTrue:
+"/    [
+"/        ^ self withinBranch.
+"/    ].
+"/    (self accrossType accept: type and: anotherType) ifTrue:
+"/    [
+"/    ].
+
+
+    self shouldNeverBeReached.
+
+    "Created: / 07-11-2009 / 16:40:44 / Jan Kurs <kursj1@fel.cvut.cz>"
+    "Modified: / 21-11-2009 / 18:34:59 / Jan Kurs <kursj1@fel.cvut.cz>"
+! !
+
+!CastingRules methodsFor:'initialization'!
+
+initRules
+    rules := OrderedCollection new.
+    rules add: PrimitiveToPrimitiveCasting new.
+    rules add: ParentToDerivedCasting new.
+    rules add: DerivedToParentCasting new.
+    rules add: WithinBranchCasting new.
+    rules add: CrossTypeHierarchyCasting new.
+
+    "Created: / 18-11-2009 / 00:40:33 / Jan Kurs <kursj1@fel.cvut.cz>"
+! !
+
+!CastingRules class methodsFor:'documentation'!
+
+version_SVN
+    ^ '$Id$'
+! !