/interpreter/tags/at2-build190607/src/edu/vub/at/objects/natives/NATTypeTag.java

http://ambienttalk.googlecode.com/ · Java · 188 lines · 94 code · 25 blank · 69 comment · 11 complexity · 401506260d31a7753b04293307d2d0c4 MD5 · raw file

  1. /**
  2. * AmbientTalk/2 Project
  3. * NATTypeTag.java created on 18-feb-2007 at 15:59:20
  4. * (c) Programming Technology Lab, 2006 - 2007
  5. * Authors: Tom Van Cutsem & Stijn Mostinckx
  6. *
  7. * Permission is hereby granted, free of charge, to any person
  8. * obtaining a copy of this software and associated documentation
  9. * files (the "Software"), to deal in the Software without
  10. * restriction, including without limitation the rights to use,
  11. * copy, modify, merge, publish, distribute, sublicense, and/or
  12. * sell copies of the Software, and to permit persons to whom the
  13. * Software is furnished to do so, subject to the following
  14. * conditions:
  15. *
  16. * The above copyright notice and this permission notice shall be
  17. * included in all copies or substantial portions of the Software.
  18. *
  19. * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20. * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  21. * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22. * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23. * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24. * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  25. * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  26. * OTHER DEALINGS IN THE SOFTWARE.
  27. */
  28. package edu.vub.at.objects.natives;
  29. import edu.vub.at.exceptions.InterpreterException;
  30. import edu.vub.at.objects.ATBoolean;
  31. import edu.vub.at.objects.ATObject;
  32. import edu.vub.at.objects.ATTable;
  33. import edu.vub.at.objects.ATTypeTag;
  34. import edu.vub.at.objects.coercion.NativeTypeTags;
  35. import edu.vub.at.objects.grammar.ATSymbol;
  36. import edu.vub.at.objects.mirrors.NativeClosure;
  37. import edu.vub.at.objects.natives.grammar.AGSymbol;
  38. /**
  39. * The native implementation of AmbientTalk type tag objects.
  40. *
  41. * @author tvcutsem
  42. */
  43. public class NATTypeTag extends NATByCopy implements ATTypeTag {
  44. private final ATSymbol typeName_;
  45. private final ATTable parentTypes_;
  46. public static ATTypeTag[] toTypeTagArray(ATTable types) throws InterpreterException {
  47. if (types == NATTable.EMPTY) {
  48. return NATObject._NO_TYPETAGS_;
  49. }
  50. ATObject[] unwrapped = types.asNativeTable().elements_;
  51. ATTypeTag[] unwrappedTypes = new ATTypeTag[unwrapped.length];
  52. for (int i = 0; i < unwrappedTypes.length; i++) {
  53. unwrappedTypes[i] = unwrapped[i].asTypeTag();
  54. }
  55. return unwrappedTypes;
  56. }
  57. public static NATTypeTag atValue(String typeName) {
  58. return atValue(AGSymbol.jAlloc(typeName));
  59. }
  60. public static NATTypeTag atValue(ATSymbol typeName) {
  61. return new NATTypeTag(typeName,
  62. NATTable.atValue(new ATObject[] { OBJRootType._INSTANCE_ }));
  63. }
  64. public static NATTypeTag atValue(String typeName, NATTypeTag singleParent) {
  65. return new NATTypeTag(AGSymbol.jAlloc(typeName),
  66. NATTable.atValue(new ATObject[] { singleParent }));
  67. }
  68. /**
  69. * Types should not be created directly because it should be verified
  70. * that their list of parent types is never empty. Types created
  71. * with an empty parent list automatically get assigned the root type
  72. * as their single parent.
  73. */
  74. public static NATTypeTag atValue(ATSymbol typeName, ATTable parentTypes) {
  75. if (parentTypes == NATTable.EMPTY) {
  76. return new NATTypeTag(typeName, NATTable.atValue(new ATObject[] { OBJRootType._INSTANCE_ }));
  77. } else {
  78. return new NATTypeTag(typeName, parentTypes);
  79. }
  80. }
  81. /**
  82. * The constructor is declared protected such that it cannot be used externally,
  83. * but can be used by the OBJRootType class to create a type with an empty
  84. * parent table, which is normally not allowed. Hence, by construction the only
  85. * type with an empty parent table is the root type.
  86. */
  87. protected NATTypeTag(ATSymbol typeName, ATTable parentTypes) {
  88. typeName_ = typeName;
  89. parentTypes_ = parentTypes;
  90. }
  91. public ATSymbol base_getTypeName() throws InterpreterException {
  92. return typeName_;
  93. }
  94. public ATTable base_getSuperTypes() throws InterpreterException {
  95. return parentTypes_;
  96. }
  97. /**
  98. * Native implementation of:
  99. *
  100. * def isSubtypeOf(supertype) {
  101. * (supertype.name() == name).or:
  102. * { (supertypes.find: { |type|
  103. * type.isSubtypeOf(supertype) }) != nil }
  104. * };
  105. */
  106. public ATBoolean base_isSubtypeOf(final ATTypeTag supertype) throws InterpreterException {
  107. if (supertype.base_getTypeName().equals(typeName_)) {
  108. return NATBoolean._TRUE_;
  109. } else {
  110. ATObject found = parentTypes_.base_find_(new NativeClosure(this) {
  111. public ATObject base_apply(ATTable args) throws InterpreterException {
  112. ATTypeTag type = get(args, 1).asTypeTag();
  113. return type.base_isSubtypeOf(supertype);
  114. }
  115. });
  116. return NATBoolean.atValue(found != NATNil._INSTANCE_);
  117. }
  118. }
  119. /**
  120. * Identity of types is based on their name
  121. */
  122. public ATBoolean base__opeql__opeql_(ATObject comparand) throws InterpreterException {
  123. if (comparand.isTypeTag()) {
  124. return comparand.asTypeTag().base_getTypeName().base__opeql__opeql_(typeName_);
  125. } else {
  126. return NATBoolean._FALSE_;
  127. }
  128. }
  129. public boolean isTypeTag() { return true; }
  130. public ATTypeTag asTypeTag() { return this; }
  131. public NATText meta_print() throws InterpreterException {
  132. return NATText.atValue("<type tag:"+typeName_+">");
  133. }
  134. /**
  135. * Types are singletons
  136. */
  137. public ATObject meta_clone() throws InterpreterException {
  138. return this;
  139. }
  140. public ATTable meta_getTypeTags() throws InterpreterException {
  141. return NATTable.of(NativeTypeTags._TYPETAG_);
  142. }
  143. /**
  144. * The root type of the type hierarchy: every type eventually
  145. * has this type as its parent.
  146. */
  147. public static class OBJRootType extends NATTypeTag implements ATTypeTag {
  148. private final static AGSymbol _ROOT_NAME_ = AGSymbol.jAlloc("Type");
  149. public static final OBJRootType _INSTANCE_ = new OBJRootType();
  150. /**
  151. * The root type is named `Type and has no parent types
  152. */
  153. private OBJRootType() {
  154. super(_ROOT_NAME_, NATTable.EMPTY);
  155. }
  156. /**
  157. * The root type is only a subtype of the root type itself
  158. */
  159. public ATBoolean base_isSubtypeOf(ATTypeTag supertype) throws InterpreterException {
  160. return NATBoolean.atValue(supertype.base_getTypeName().equals(_ROOT_NAME_));
  161. }
  162. }
  163. }