home *** CD-ROM | disk | FTP | other *** search
/ The CDPD Public Domain Collection for CDTV 3 / CDPDIII.bin / pd / programming / gnusmalltalk / class.st < prev    next >
Text File  |  1992-02-15  |  8KB  |  288 lines
  1. "======================================================================
  2. |
  3. |   Class Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991, 1992 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. | sbb         16 Mar 91      Class creation now separate statement.
  36. |
  37. | sbb         22 Sep 90      Implemented classVarNames and allClassVarNames.
  38. |              Implemented sharedPools and allSharedPools.
  39. |
  40. | sbyrne     16 May 90      Improved error checking: you now cannot create a
  41. |              subclass of a class whose type is not compatible
  42. |              (i.e. non-variable subclass of a variable byte
  43. |              class).
  44. |
  45. | sbyrne     16 May 90      Minor changes to support preserving class definitions
  46. |              as long as possible (i.e. if you re-invoke the class
  47. |              definition method, it tries to re-use the existing
  48. |              class if possible).
  49. |
  50. | sbyrne     13 Jan 90      Began experimental addition of actual class
  51. |              definitions. 
  52. |
  53. | sbyrne     25 Apr 89      created.
  54. |
  55. "
  56.  
  57. ClassDescription subclass: #Class
  58.          instanceVariableNames: 'classVariables sharedPools'
  59.          classVariableNames: ''
  60.          poolDictionaries: ''
  61.          category: nil
  62. !
  63.  
  64. Class comment: 
  65. 'I am THE class object.  My instances are the classes of the system' !
  66.  
  67.  
  68.  
  69. !Class methodsFor: 'accessing instances and variables'!
  70.  
  71. addClassVarName: aString
  72.     | sym |
  73.     sym _ aString asSymbol.    "### maybe this should remain a string? "
  74.     (classVariables includesKey: sym)
  75.         ifTrue: [ ^self error: 'class variable already present' ]
  76.     ifFalse: [ classVariables at: sym put: nil ]
  77. !
  78.  
  79. removeClassVarName: aString
  80.     "Removes the class variable from the class, error if not present, or
  81.      still in use."
  82.     | sym |
  83.     sym _ aString asSymbol.    "### maybe this should remain a string? "
  84.     " ### test for use in sub method "
  85.     (classVariables includesKey: sym)
  86.         ifTrue: [ classVariables removeKey: sym ]
  87.     ifFalse: [ self error: 'class variable not present' ]
  88. !
  89.  
  90. classPool
  91.     ^classVariables
  92. !
  93.  
  94. classVarNames
  95.     | superVarNames |
  96.     self superclass isNil
  97.     ifTrue: [ ^self allClassVarNames ].
  98.     superVarNames _ self superclass allClassVarNames.
  99.     ^(self allClassVarNames) removeAll: superVarNames
  100. !
  101.  
  102. allClassVarNames
  103.     | s |
  104.     s _ Set new.
  105.     classVariables keysDo: [ :key | s add: key ].
  106.     ^s
  107. !
  108.  
  109. addSharedPool: aDictionary
  110.     (sharedPools includes: aDictionary)
  111.         ifTrue: [ ^self error: 'Attempt to add an already-present shared pool' ].
  112.     sharedPools _ sharedPools copyWith: aDictionary
  113. !
  114.  
  115. removeSharedPool: aDictionary
  116.     (sharedPools includes: aDictionary)
  117.         ifFalse: [ ^self error: 'Attempt to remove non-existent shared pool' ].
  118.     sharedPools _ sharedPools copyWithout: aDictionary
  119. !
  120.  
  121. sharedPools
  122.     | superPools |
  123.     self superclass isNil
  124.     ifTrue: [ ^self allSharedPools ].
  125.     superPools _ self superclass allSharedPools.
  126.     ^(self allSharedPools) removeAll: superPools
  127. !
  128.  
  129. allSharedPools
  130.     | s |
  131.     s _ Set new.
  132.     sharedPools do:
  133.     [ :sp | s add: (Smalltalk keyAtValue: sp) ].
  134.     ^s
  135. !
  136.  
  137. initialize            "redefined in children (?)"
  138.     ^self
  139. !!
  140.  
  141.  
  142.  
  143. !Class methodsFor: 'testing'!
  144.  
  145. = aClass
  146.     "Returns true if the two class objects are to be considered equal."
  147.     ^name = aClass name
  148. !!
  149.  
  150.  
  151.  
  152. !Class methodsFor: 'instance creation'!
  153.  
  154.  
  155. subclass: classNameString
  156.     instanceVariableNames: stringInstVarNames
  157.     classVariableNames: stringOfClassVarNames
  158.     poolDictionaries: stringOfPoolNames
  159.     category: categoryNameString
  160.     | meta |
  161.     KernelInitialized ifFalse: [ ^nil ].
  162.     self isVariable
  163.     ifTrue: [ ^self error: 'cannot create a non-variable subclass 
  164. of a variable class' ].
  165.     meta _ self metaclassFor: classNameString.
  166.     ^meta name: classNameString
  167.       environment: Smalltalk
  168.       subclassOf: self
  169.       instanceVariableNames: stringInstVarNames
  170.       variable: false
  171.       words: true
  172.       pointers: true
  173.       classVariableNames: stringOfClassVarNames
  174.       poolDictionaries: stringOfPoolNames
  175.       category: categoryNameString
  176.       comment: nil
  177.       changed: nil
  178. !
  179.  
  180. variableSubclass: classNameString
  181.     instanceVariableNames: stringInstVarNames
  182.     classVariableNames: stringOfClassVarNames
  183.     poolDictionaries: stringOfPoolNames
  184.     category: categoryNameString
  185.     | meta |
  186.     KernelInitialized ifFalse: [ ^nil ].
  187.     self isVariable & (self isWords | self isBytes) 
  188.     ifTrue: [ ^self error: 'cannot create a variable subclass from a 
  189. non-pointer variable parent class' ].
  190.     meta _ self metaclassFor: classNameString.
  191.     ^meta name: classNameString
  192.       environment: Smalltalk
  193.       subclassOf: self
  194.       instanceVariableNames: stringInstVarNames
  195.       variable: true
  196.       words: true
  197.       pointers: true
  198.       classVariableNames: stringOfClassVarNames
  199.       poolDictionaries: stringOfPoolNames
  200.         category: categoryNameString
  201.       comment: nil
  202.         changed: nil
  203. !
  204.  
  205. variableWordSubclass: classNameString
  206.   instanceVariableNames: stringInstVarNames
  207.   classVariableNames: stringOfClassVarNames
  208.   poolDictionaries: stringOfPoolNames
  209.   category: categoryNameString
  210.     | meta |
  211.     KernelInitialized ifFalse: [ ^nil ].
  212.     self isVariable & (self isPointers | self isBytes) 
  213.     ifTrue: [ ^self error: 'cannot create a word subclass from a non-word 
  214. variable parent class' ].
  215.     meta _ self metaclassFor: classNameString.
  216.     ^meta name: classNameString
  217.             environment: Smalltalk
  218.         subclassOf: self
  219.         instanceVariableNames: stringInstVarNames
  220.         variable: true
  221.         words: true
  222.         pointers: false
  223.             classVariableNames: stringOfClassVarNames
  224.         poolDictionaries: stringOfPoolNames
  225.         category: categoryNameString
  226.         comment: nil
  227.         changed: nil
  228. !
  229.  
  230. variableByteSubclass: classNameString
  231.   instanceVariableNames: stringInstVarNames
  232.   classVariableNames: stringOfClassVarNames
  233.   poolDictionaries: stringOfPoolNames
  234.   category: categoryNameString
  235.     | meta |
  236.     KernelInitialized ifFalse: [ ^nil ].
  237.     self isVariable & (self isPointers | self isWords)
  238.     ifTrue: [ ^self error: 'Cannot create variable byte subclass from 
  239. non-byte parent class' ].
  240.     meta _ self metaclassFor: classNameString.
  241.     ^meta name: classNameString
  242.             environment: Smalltalk
  243.         subclassOf: self
  244.         instanceVariableNames: stringInstVarNames
  245.         variable: true
  246.         words: false
  247.         pointers: false
  248.             classVariableNames: stringOfClassVarNames
  249.         poolDictionaries: stringOfPoolNames
  250.         category: categoryNameString
  251.         comment: nil
  252.         changed: nil
  253. ! !
  254.  
  255.  
  256.  
  257. !Class methodsFor: 'printing'!
  258.  
  259. printOn: aStream
  260.     self name printOn: aStream
  261. !
  262.  
  263. storeOn: aStream
  264.     self printOn: aStream
  265. ! !
  266.  
  267.  
  268.  
  269. !Class methodsFor: 'private'!
  270.  
  271. setClassVariables: aDictionary
  272.     classVariables _ aDictionary
  273. !
  274.  
  275. setSharedPools: aDictionary
  276.     sharedPools _ aDictionary
  277. !
  278.  
  279. metaclassFor: classNameString
  280.     | className class |
  281.     className _ classNameString asSymbol.
  282.     class _ Smalltalk at: className 
  283.               ifAbsent: [ nil ].
  284.     class isNil
  285.     ifTrue: [ ^Metaclass subclassOf: self class ].
  286.     ^class class
  287. ! !
  288.