home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 1 / RISC_DISC_1.iso / pd_share / code / smalltalk / !GNUst / st / Class < prev    next >
Encoding:
Text File  |  1991-09-13  |  7.2 KB  |  258 lines
  1. "======================================================================
  2. |
  3. |   Class Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  11. | Written by Steve Byrne.
  12. |
  13. | This file is part of GNU Smalltalk.
  14. |
  15. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  16. | under the terms of the GNU General Public License as published by the Free
  17. | Software Foundation; either version 1, or (at your option) any later version.
  18. | 
  19. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  20. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  21. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  22. | details.
  23. | 
  24. | You should have received a copy of the GNU General Public License along with
  25. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  26. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  27. |
  28.  ======================================================================"
  29.  
  30.  
  31. "
  32. |     Change Log
  33. | ============================================================================
  34. | Author       Date       Change 
  35. | sbyrne     16 May 90      Improved error checking: you now cannot create a
  36. |              subclass of a class whose type is not compatible
  37. |              (i.e. non-variable subclass of a variable byte
  38. |              class).
  39. |
  40. | sbyrne     16 May 90      Minor changes to support preserving class definitions
  41. |              as long as possible (i.e. if you re-invoke the class
  42. |              definition method, it tries to re-use the existing
  43. |              class if possible).
  44. |
  45. | sbyrne     13 Jan 90      Began experimental addition of actual class
  46. |              definitions. 
  47. |
  48. | sbyrne     25 Apr 89      created.
  49. |
  50. "
  51.  
  52. ClassDescription subclass: #Class
  53.          instanceVariableNames: 'classVariables sharedPools'
  54.          classVariableNames: ''
  55.          poolDictionaries: ''
  56.          category: nil.
  57.  
  58. Class comment: 
  59. 'I am THE class object.  My instances are the classes of the system' !
  60.  
  61.  
  62.  
  63. !Class methodsFor: 'accessing instances and variables'!
  64.  
  65. addClassVarName: aString
  66.     | sym |
  67.     sym _ aString asSymbol.    "### maybe this should remain a string? "
  68.     (classVariables includesKey: sym)
  69.         ifTrue: [ ^self error: 'class variable already present' ]
  70.     ifFalse: [ classVariables at: sym put: nil ]
  71. !
  72.  
  73. removeClassVarName: aString
  74.     "Removes the class variable from the class, error if not present, or
  75.      still in use."
  76.     | sym |
  77.     sym _ aString asSymbol.    "### maybe this should remain a string? "
  78.     " ### test for use in sub method "
  79.     (classVariables includesKey: sym)
  80.         ifTrue: [ classVariables removeKey: sym ]
  81.     ifFalse: [ self error: 'class variable not present' ]
  82. !
  83.  
  84. classPool
  85.     ^classVariables
  86. !
  87.  
  88. addSharedPool: aDictionary
  89.     (sharedPools includes: aDictionary)
  90.         ifTrue: [ ^self error: 'Attempt to add an already-present shared pool' ].
  91.     sharedPools _ sharedPools copyWith: aDictionary
  92. !
  93.  
  94. removeSharedPool: aDictionary
  95.     (sharedPools includes: aDictionary)
  96.         ifFalse: [ ^self error: 'Attempt to remove non-existent shared pool' ].
  97.     sharedPools _ sharedPools copyWithout: aDictionary
  98. !
  99.  
  100. initialize            "redefined in children (?)"
  101.     ^self
  102. !!
  103.  
  104.  
  105.  
  106. !Class methodsFor: 'testing'!
  107.  
  108. = aClass
  109.     "Returns true if the two class objects are to be considered equal."
  110.     ^name = aClass name
  111. !!
  112.  
  113.  
  114.  
  115. !Class methodsFor: 'instance creation'!
  116.  
  117.  
  118. subclass: classNameString
  119.   instanceVariableNames: stringInstVarNames
  120.   classVariableNames: stringOfClassVarNames
  121.   poolDictionaries: stringOfPoolNames
  122.   category: categoryNameString
  123.     | meta |
  124.     KernelInitialized ifFalse: [ ^nil ].
  125.     self isVariable
  126.     ifTrue: [ ^self error: 'cannot create a non-variable subclass 
  127. of a variable class' ].
  128.     meta _ self metaclassFor: classNameString.
  129.     ^meta name: classNameString
  130.             environment: Smalltalk
  131.         subclassOf: self
  132.         instanceVariableNames: stringInstVarNames
  133.         variable: false
  134.         words: true
  135.         pointers: true
  136.             classVariableNames: stringOfClassVarNames
  137.         poolDictionaries: stringOfPoolNames
  138.         category: categoryNameString
  139.         comment: nil
  140.         changed: nil
  141. !
  142.  
  143. variableSubclass: classNameString
  144.   instanceVariableNames: stringInstVarNames
  145.   classVariableNames: stringOfClassVarNames
  146.   poolDictionaries: stringOfPoolNames
  147.   category: categoryNameString
  148.     | meta |
  149.     KernelInitialized ifFalse: [ ^nil ].
  150.     self isVariable & (self isWords | self isBytes) 
  151.     ifTrue: [ ^self error: 'cannot create a variable subclass from a 
  152. non-pointer variable parent class' ].
  153.     meta _ self metaclassFor: classNameString.
  154.     ^meta name: classNameString
  155.             environment: Smalltalk
  156.         subclassOf: self
  157.         instanceVariableNames: stringInstVarNames
  158.         variable: true
  159.         words: true
  160.         pointers: true
  161.             classVariableNames: stringOfClassVarNames
  162.         poolDictionaries: stringOfPoolNames
  163.         category: categoryNameString
  164.         comment: nil
  165.         changed: nil
  166. !
  167.  
  168. variableWordSubclass: classNameString
  169.   instanceVariableNames: stringInstVarNames
  170.   classVariableNames: stringOfClassVarNames
  171.   poolDictionaries: stringOfPoolNames
  172.   category: categoryNameString
  173.     | meta |
  174.     KernelInitialized ifFalse: [ ^nil ].
  175.     self isVariable & (self isPointers | self isBytes) 
  176.     ifTrue: [ ^self error: 'cannot create a word subclass from a non-word 
  177. variable parent class' ].
  178.     meta _ self metaclassFor: classNameString.
  179.     ^meta name: classNameString
  180.             environment: Smalltalk
  181.         subclassOf: self
  182.         instanceVariableNames: stringInstVarNames
  183.         variable: true
  184.         words: true
  185.         pointers: false
  186.             classVariableNames: stringOfClassVarNames
  187.         poolDictionaries: stringOfPoolNames
  188.         category: categoryNameString
  189.         comment: nil
  190.         changed: nil
  191. !
  192.  
  193. variableByteSubclass: classNameString
  194.   instanceVariableNames: stringInstVarNames
  195.   classVariableNames: stringOfClassVarNames
  196.   poolDictionaries: stringOfPoolNames
  197.   category: categoryNameString
  198.     | meta |
  199.     KernelInitialized ifFalse: [ ^nil ].
  200.     self isVariable & (self isPointers | self isWords)
  201.     ifTrue: [ ^self error: 'Cannot create variable byte subclass from 
  202. non-byte parent class' ].
  203.     meta _ self metaclassFor: classNameString.
  204.     ^meta name: classNameString
  205.             environment: Smalltalk
  206.         subclassOf: self
  207.         instanceVariableNames: stringInstVarNames
  208.         variable: true
  209.         words: false
  210.         pointers: false
  211.             classVariableNames: stringOfClassVarNames
  212.         poolDictionaries: stringOfPoolNames
  213.         category: categoryNameString
  214.         comment: nil
  215.         changed: nil
  216. !!
  217.  
  218.  
  219.  
  220. !Class methodsFor: 'printing'!
  221.  
  222. printOn: aStream
  223.     self name printOn: aStream
  224. !
  225.  
  226. storeOn: aStream
  227.     self printOn: aStream
  228. !!
  229.  
  230.  
  231.  
  232. !Class methodsFor: 'private'!
  233.  
  234. setClassVariables: aDictionary
  235.     classVariables _ aDictionary
  236. !
  237.  
  238. setSharedPools: aDictionary
  239.     sharedPools _ aDictionary
  240. !
  241.  
  242. metaclassFor: classNameString
  243.     | className class |
  244.     className _ classNameString asSymbol.
  245.     class _ Smalltalk at: className 
  246.               ifAbsent: [ ^Metaclass subclassOf: self class ].
  247.     ^class class
  248. !
  249.  
  250. setSuperclass: aClass
  251.     self superclass == aClass
  252.     ifTrue: [ ^self ].    "don't need to change anything"
  253.     self superclass notNil    "remove any old knowledge of this class"
  254.     ifTrue: [ self superclass removeSubclass: self ].
  255.     self superclass: aClass.
  256.     aClass addSubclass: self
  257. !!
  258.