home *** CD-ROM | disk | FTP | other *** search
/ The CDPD Public Domain Collection for CDTV 3 / CDPDIII.bin / pd / programming / gnusmalltalk / classdescription.st < prev    next >
Encoding:
Text File  |  1992-02-15  |  8.0 KB  |  320 lines
  1. "======================================================================
  2. |
  3. |   ClassDescription 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         10 Nov 90      Implemented compile:classified: and
  38. |              compile:classified:notifying:.
  39. |
  40. | sbb         21 Sep 90      Fixed the implementation of instVarNames to just
  41. |              return the variables defined by the current class,
  42. |              and added implementatinos of allInstVarNames and
  43. |              subclassInstVarNames.
  44. |
  45. | sbyrne     23 Sep 89      fileOutCategory: is dangerous, so I make it write to
  46. |              a subdirectory called './categories'.
  47. |
  48. | sbyrne     25 Apr 89      created.
  49. |
  50. "
  51.  
  52. Behavior subclass: #ClassDescription
  53.      instanceVariableNames: 'name comment instanceVariables category'
  54.      classVariableNames: ''
  55.      poolDictionaries: ''
  56.      category: nil
  57. !
  58.  
  59. ClassDescription comment: 
  60. 'My instances record information generally attributed to classes and
  61. metaclasses; namely, the class name, class comment (you wouldn''t be
  62. reading this if it weren''t for me), a list of the instance variables
  63. of the class, and the class category.  I provide methods that
  64. access classes by category, and allow whole categories of classes to be
  65. filed out to external disk files.' !
  66.  
  67.  
  68.  
  69. !ClassDescription methodsFor: 'accessing class description'!
  70.  
  71. name
  72.     ^name
  73. !
  74.  
  75. comment
  76.     ^comment
  77. !
  78.  
  79. comment: aString
  80.     comment _ aString
  81. !
  82.  
  83. addInstVarName: aString
  84.     instanceVariables _ instanceVariables copyWith: aString
  85. !
  86.  
  87. removeInstVarName: aString
  88.     instanceVariables _ instanceVariables copyWithout: aString
  89. !!
  90.  
  91.  
  92.  
  93. !ClassDescription methodsFor: 'organization of messages and classes'!
  94.  
  95. category
  96.     ^category
  97. !
  98.  
  99. category: aString
  100.     aString isNil
  101.     ifTrue: [ category _ nil ]
  102.     ifFalse: [ category _ aString asSymbol ]
  103. !
  104.  
  105. removeCategory: aString
  106.     | selector method category |
  107.     methodDictionary isNil
  108.         ifTrue: [ ^self ].
  109.     category _ aString asSymbol.
  110.     methodDictionary associationsDo:
  111.         [ :assoc | method _ assoc key.
  112.                method methodCategory = category
  113.                ifTrue: [ methodDictionary remove: assoc ] ].
  114. !
  115.  
  116. whichCategoryIncludesSelector: selector
  117.     | method |
  118.     methodDictionary isNil
  119.         ifTrue: [ ^nil ].
  120.     method _ methodDictionary at: selector.
  121.     ^method methodCategory
  122. !!
  123.  
  124.  
  125.  
  126. !ClassDescription methodsFor: 'copying'!
  127.  
  128. copy: selector from: aClass
  129.     | method |
  130.     method _ aClass compiledMethodAt: selector.
  131.     methodDictionary at: selector put: method.
  132. !
  133.  
  134. copy: selector from: aClass classified: categoryName
  135.     | method |
  136.     method _ (aClass compiledMethodAt: selector) deepCopy.
  137.     method methodCategory: categoryName.
  138.     methodDictionary at: selector put: method
  139. !
  140.  
  141. copyAll: arrayOfSelectors from: class
  142.     arrayOfSelectors do:
  143.     [ :selector | self copy: selector
  144.                from: class ]
  145. !
  146.  
  147. copyAll: arrayOfSelectors from: class classified: categoryName
  148.     arrayOfSelectors do:
  149.     [ :selector | self copy: selector
  150.                from: class
  151.                classified: categoryName ]
  152. !
  153.  
  154. copyAllCategoriesFrom: aClass
  155.     | method |
  156.     aClass selectors do:
  157.     [ :selector | self copy: selector from: aClass ]
  158. !
  159.  
  160. copyCategory: categoryName from: aClass
  161.     | method |
  162.     aClass selectors do:
  163.     [ :selector | method _ aClass compiledMethodAt: selector.
  164.               method methodCategory = categoryName
  165.               ifTrue: [ self copy: selector from: aClass ] ]
  166. !
  167.  
  168. copyCategory: categoryName from: aClass classified: newCategoryName
  169.     | method |
  170.     aClass selectors do:
  171.     [ :selector | method _ aClass compiledMethodAt: selector.
  172.               method methodCategory = categoryName
  173.               ifTrue: [ self copy: selector
  174.                      from: aClass
  175.                      classified: newCategoryName ] ]
  176. !!
  177.  
  178.  
  179.  
  180. !ClassDescription methodsFor: 'compiling'!
  181.  
  182. compile: code classified: categoryName
  183.     | method |
  184.     method _ self compile: code.
  185.     method methodCategory: categoryName.
  186.     ^method
  187. !
  188.  
  189. compile: code classified: categoryName notifying: requestor
  190.     | method |
  191.     method _ self compile: code notifying: requestor.
  192.     method methodCategory: categoryName.
  193.     ^method
  194. !!
  195.  
  196.  
  197.  
  198. !ClassDescription methodsFor: 'accessing instances and variables'!
  199.  
  200. instVarNames
  201.     | superVars |
  202.     superClass isNil
  203.     ifTrue: [ ^instanceVariables copy ]
  204.     ifFalse: [ superVars _ superClass allInstVarNames.
  205.            ^instanceVariables copyFrom: superVars size+1 
  206.                       to: instanceVariables size ]
  207. !
  208.  
  209. subclassInstVarNames
  210.     | varNameSet |
  211.     varNameSet _ Set new.
  212.     self subclasses do: 
  213.     [ :class | Set addAll: (class instVarNames) ].
  214.     ^varNameSet
  215. !
  216.  
  217. allInstVarNames
  218.     ^instanceVariables
  219.  
  220. !!
  221.  
  222.  
  223.  
  224. !ClassDescription methodsFor: 'printing'!
  225.  
  226. classVariableString
  227.     self subclassResponsibility
  228. !
  229.  
  230. instanceVariableString
  231.     | aString |
  232.     instanceVariables isNil ifTrue: [ ^'' ].
  233.     aString _ String new: 0.
  234.     instanceVariables do: [ :instVarName | aString _ aString ,
  235.                                               instVarName , ' ' ].
  236.     ^aString
  237. !
  238.  
  239. sharedVariableString
  240.     self subclassResponsibility
  241. !!
  242.  
  243.  
  244.  
  245. !ClassDescription methodsFor: 'filing'!
  246.  
  247. fileOutOn: aFileStream
  248.     | categories now |
  249.     categories _ Set new.
  250.     methodDictionary isNil ifTrue: [ ^self ].
  251.     methodDictionary do:
  252.     [ :method | categories add: (method methodCategory) ].
  253.     aFileStream nextPutAll: '''Filed out from ';
  254.     nextPutAll: Version;
  255.     nextPutAll: ' on '.
  256.     now _ Date dateAndTimeNow.
  257.     aFileStream print: (now at: 1);
  258.     nextPutAll:  '  ';
  259.     print: (now at: 2);
  260.     nextPutAll: ' GMT''!'; nl; nl.
  261.     categories asSortedCollection do:
  262.         [ :category | self emitCategory: category toStream: aFileStream ]
  263. !
  264.  
  265. fileOutCategory: categoryName
  266.     | aFileStream fileName |
  267.     name notNil
  268.         ifTrue: [ fileName _ name ]
  269.     ifFalse: [ fileName _ (self instanceClass name) , '-class' ].
  270.     fileName _ './categories/', fileName , '.st' .
  271.     aFileStream _ FileStream open: fileName mode: 'w'.
  272.     self emitCategory: categoryName toStream: aFileStream.
  273.     aFileStream close
  274. !!
  275.  
  276.  
  277.  
  278. !ClassDescription methodsFor: 'private'!
  279.  
  280. emitCategory: category toStream: aFileStream
  281.     "I write legal Smalltalk load syntax definitions of all of my methods
  282.      are in the 'category' category to the aFileStream"
  283.     aFileStream nextPutAll: '!';
  284.     print: self;
  285.     nextPutAll: ' methodsFor: ''';
  286.     nextPutAll: category;
  287.     nextPutAll: '''!'.
  288.     methodDictionary notNil
  289.       ifTrue: [ methodDictionary do:
  290.               [ :method | (method methodCategory) = category
  291.                       ifTrue: [ aFileStream nextPutAll: '
  292.  
  293. '                                ;
  294.                         nextPutAll: method methodSourceString;
  295.                         nextPutAll: '!' ] ] ].
  296.     aFileStream nextPutAll: '!
  297.  
  298. '
  299.  
  300. !
  301.  
  302. setName: aSymbol
  303.     name _ aSymbol
  304. !
  305.  
  306. setInstanceVariables: instVariableArray
  307.     instanceVariables _ instVariableArray
  308. !
  309.  
  310. setSuperclass: aClass
  311.     "Set the superclass of the receiver to be 'aClass'.  Also adds the receiver
  312.      as a subclass of 'aClass'"
  313.     self superclass == aClass
  314.     ifTrue: [ ^self ].    "don't need to change anything"
  315.     self superclass notNil    "remove any old knowledge of this class"
  316.     ifTrue: [ self superclass removeSubclass: self ].
  317.     self superclass: aClass.
  318.     aClass addSubclass: self
  319. ! !
  320.