2
0

Kernel-Classes.st 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870
  1. Smalltalk current createPackage: 'Kernel-Classes'!
  2. Object subclass: #Behavior
  3. instanceVariableNames: ''
  4. package: 'Kernel-Classes'!
  5. !Behavior commentStamp!
  6. I am the superclass of all class objects.
  7. I define the protocol for creating instances of a class with `#basicNew` and `#new` (see `boot.js` for class constructors details).
  8. My instances know about the subclass/superclass relationships between classes, contain the description that instances are created from,
  9. and hold the method dictionary that's associated with each class.
  10. I also provides methods for compiling methods, examining the method dictionary, and iterating over the class hierarchy.!
  11. !Behavior methodsFor: 'accessing'!
  12. >> aString
  13. ^ self methodAt: aString
  14. !
  15. allInstanceVariableNames
  16. | result |
  17. result := self instanceVariableNames copy.
  18. self superclass ifNotNil: [
  19. result addAll: self superclass allInstanceVariableNames ].
  20. ^ result
  21. !
  22. allSelectors
  23. ^ self allSuperclasses
  24. inject: self selectors
  25. into: [ :acc :each | acc addAll: each selectors; yourself ]
  26. !
  27. allSubclasses
  28. "Answer an collection of the receiver's and the receiver's descendent's subclasses. "
  29. | subclasses index |
  30. subclasses := self subclasses.
  31. index := 1.
  32. [ index > subclasses size ]
  33. whileFalse: [ subclasses addAll: (subclasses at: index) subclasses.
  34. index := index + 1 ].
  35. ^ subclasses
  36. !
  37. allSuperclasses
  38. self superclass ifNil: [ ^ #() ].
  39. ^ (OrderedCollection with: self superclass)
  40. addAll: self superclass allSuperclasses;
  41. yourself
  42. !
  43. comment
  44. ^ (self basicAt: 'comment') ifNil: [ '' ]
  45. !
  46. comment: aString
  47. self basicAt: 'comment' put: aString.
  48. SystemAnnouncer current
  49. announce: (ClassCommentChanged new
  50. theClass: self;
  51. yourself)
  52. !
  53. commentStamp
  54. ^ ClassCommentReader new
  55. class: self;
  56. yourself
  57. !
  58. commentStamp: aStamp prior: prior
  59. ^ self commentStamp
  60. !
  61. definition
  62. ^ ''
  63. !
  64. instanceVariableNames
  65. <return self.iVarNames>
  66. !
  67. javascriptConstructor
  68. "Answer the JS constructor used to instantiate. See boot.js"
  69. <return self.fn>
  70. !
  71. javascriptConstructor: aJavaScriptFunction
  72. "Set the JS constructor used to instantiate.
  73. See the JS counter-part in boot.js `smalltalk.setClassConstructor'"
  74. <smalltalk.setClassConstructor(self, aJavaScriptFunction);>
  75. !
  76. lookupSelector: selector
  77. "Look up the given selector in my methodDictionary.
  78. Return the corresponding method if found.
  79. Otherwise chase the superclass chain and try again.
  80. Return nil if no method is found."
  81. | lookupClass |
  82. lookupClass := self.
  83. [ lookupClass = nil ] whileFalse: [
  84. (lookupClass includesSelector: selector)
  85. ifTrue: [ ^ lookupClass methodAt: selector ].
  86. lookupClass := lookupClass superclass ].
  87. ^ nil
  88. !
  89. methodAt: aString
  90. ^ self methodDictionary at: aString
  91. !
  92. methodDictionary
  93. <var dict = smalltalk.HashedCollection._new();
  94. var methods = self.methods;
  95. Object.keys(methods).forEach(function(i) {
  96. if(methods[i].selector) {
  97. dict._at_put_(methods[i].selector, methods[i]);
  98. }
  99. });
  100. return dict>
  101. !
  102. methods
  103. ^ self methodDictionary values
  104. !
  105. methodsFor: aString
  106. ^ ClassCategoryReader new
  107. class: self category: aString;
  108. yourself
  109. !
  110. methodsFor: aString stamp: aStamp
  111. "Added for compatibility, right now ignores stamp."
  112. ^ self methodsFor: aString
  113. !
  114. methodsInProtocol: aString
  115. ^ self methods select: [ :each | each protocol = aString ]
  116. !
  117. name
  118. <return self.className || nil>
  119. !
  120. organization
  121. ^ self basicAt: 'organization'
  122. !
  123. ownMethods
  124. "Answer the methods of the receiver that are not package extensions"
  125. ^ (self ownProtocols
  126. inject: OrderedCollection new
  127. into: [ :acc :each | acc, (self methodsInProtocol: each) ])
  128. sorted: [ :a :b | a selector <= b selector ]
  129. !
  130. ownProtocols
  131. "Answer the protocols of the receiver that are not package extensions"
  132. ^ self protocols reject: [ :each |
  133. each match: '^\*' ]
  134. !
  135. protocols
  136. ^ self organization elements sorted
  137. !
  138. prototype
  139. <return self.fn.prototype>
  140. !
  141. removeProtocolIfEmpty: aString
  142. self methods
  143. detect: [ :each | each protocol = aString ]
  144. ifNone: [ self organization removeElement: aString ]
  145. !
  146. selectors
  147. ^ self methodDictionary keys
  148. !
  149. subclasses
  150. self subclassResponsibility
  151. !
  152. superclass
  153. <return self.superclass || nil>
  154. !
  155. theMetaClass
  156. ^ self class
  157. !
  158. theNonMetaClass
  159. ^ self
  160. !
  161. withAllSubclasses
  162. ^ (Array with: self) addAll: self allSubclasses; yourself
  163. ! !
  164. !Behavior methodsFor: 'compiling'!
  165. addCompiledMethod: aMethod
  166. | oldMethod announcement |
  167. oldMethod := self methodDictionary
  168. at: aMethod selector
  169. ifAbsent: [ nil ].
  170. (self protocols includes: aMethod protocol)
  171. ifFalse: [ self organization addElement: aMethod protocol ].
  172. self basicAddCompiledMethod: aMethod.
  173. oldMethod ifNotNil: [
  174. self removeProtocolIfEmpty: oldMethod protocol ].
  175. announcement := oldMethod
  176. ifNil: [
  177. MethodAdded new
  178. method: aMethod;
  179. yourself ]
  180. ifNotNil: [
  181. MethodModified new
  182. oldMethod: oldMethod;
  183. method: aMethod;
  184. yourself ].
  185. SystemAnnouncer current
  186. announce: announcement
  187. !
  188. compile: aString
  189. ^ self compile: aString protocol: ''
  190. !
  191. compile: aString protocol: anotherString
  192. ^ Compiler new
  193. install: aString
  194. forClass: self
  195. protocol: anotherString
  196. !
  197. recompile
  198. ^ Compiler new recompile: self
  199. !
  200. removeCompiledMethod: aMethod
  201. self basicRemoveCompiledMethod: aMethod.
  202. self removeProtocolIfEmpty: aMethod protocol.
  203. SystemAnnouncer current
  204. announce: (MethodRemoved new
  205. method: aMethod;
  206. yourself)
  207. ! !
  208. !Behavior methodsFor: 'enumerating'!
  209. allSubclassesDo: aBlock
  210. "Evaluate the argument, aBlock, for each of the receiver's subclasses."
  211. self allSubclasses do: [ :each |
  212. aBlock value: each ]
  213. !
  214. protocolsDo: aBlock
  215. "Execute aBlock for each method protocol with
  216. its collection of methods in the sort order of protocol name."
  217. | methodsByProtocol |
  218. methodsByProtocol := HashedCollection new.
  219. self methodDictionary valuesDo: [ :m |
  220. (methodsByProtocol at: m protocol ifAbsentPut: [ Array new ])
  221. add: m ].
  222. self protocols do: [ :protocol |
  223. aBlock value: protocol value: (methodsByProtocol at: protocol) ]
  224. ! !
  225. !Behavior methodsFor: 'instance creation'!
  226. basicNew
  227. <return new self.fn()>
  228. !
  229. new
  230. ^ self basicNew initialize
  231. ! !
  232. !Behavior methodsFor: 'private'!
  233. basicAddCompiledMethod: aMethod
  234. <smalltalk.addMethod(aMethod, self)>
  235. !
  236. basicRemoveCompiledMethod: aMethod
  237. <smalltalk.removeMethod(aMethod,self)>
  238. ! !
  239. !Behavior methodsFor: 'testing'!
  240. canUnderstand: aSelector
  241. ^ (self includesSelector: aSelector asString) or: [
  242. self superclass notNil and: [ self superclass canUnderstand: aSelector ]]
  243. !
  244. includesBehavior: aClass
  245. ^ self == aClass or: [
  246. self inheritsFrom: aClass ]
  247. !
  248. includesSelector: aString
  249. ^ self methodDictionary includesKey: aString
  250. !
  251. inheritsFrom: aClass
  252. self superclass ifNil: [ ^ false ].
  253. ^ aClass == self superclass or: [
  254. self superclass inheritsFrom: aClass ]
  255. !
  256. isBehavior
  257. ^ true
  258. ! !
  259. Behavior subclass: #Class
  260. instanceVariableNames: ''
  261. package: 'Kernel-Classes'!
  262. !Class commentStamp!
  263. I am __the__ class object.
  264. My instances are the classes of the system.
  265. Class creation is done throught a `ClassBuilder` instance.!
  266. !Class methodsFor: 'accessing'!
  267. category
  268. ^ self package ifNil: [ 'Unclassified' ] ifNotNil: [ self package name ]
  269. !
  270. definition
  271. ^ String streamContents: [ :stream |
  272. stream
  273. nextPutAll: self superclass asString;
  274. nextPutAll: ' subclass: #';
  275. nextPutAll: self name;
  276. nextPutAll: String lf, String tab;
  277. nextPutAll: 'instanceVariableNames: '''.
  278. self instanceVariableNames
  279. do: [ :each | stream nextPutAll: each ]
  280. separatedBy: [ stream nextPutAll: ' ' ].
  281. stream
  282. nextPutAll: '''', String lf, String tab;
  283. nextPutAll: 'package: ''';
  284. nextPutAll: self category;
  285. nextPutAll: '''' ]
  286. !
  287. package
  288. ^ self basicAt: 'pkg'
  289. !
  290. package: aPackage
  291. | oldPackage |
  292. self package = aPackage ifTrue: [ ^ self ].
  293. oldPackage := self package.
  294. self basicAt: 'pkg' put: aPackage.
  295. oldPackage organization removeElement: self.
  296. aPackage organization addElement: self.
  297. SystemAnnouncer current announce: (ClassMoved new
  298. theClass: self;
  299. oldPackage: oldPackage;
  300. yourself)
  301. !
  302. rename: aString
  303. ClassBuilder new renameClass: self to: aString
  304. !
  305. subclasses
  306. <return self.subclasses._copy()>
  307. ! !
  308. !Class methodsFor: 'class creation'!
  309. subclass: aString instanceVariableNames: anotherString
  310. "Kept for compatibility."
  311. ^ self subclass: aString instanceVariableNames: anotherString package: nil
  312. !
  313. subclass: aString instanceVariableNames: aString2 category: aString3
  314. "Kept for compatibility."
  315. self deprecatedAPI.
  316. ^ self subclass: aString instanceVariableNames: aString2 package: aString3
  317. !
  318. subclass: aString instanceVariableNames: aString2 classVariableNames: classVars poolDictionaries: pools category: aString3
  319. "Just ignore class variables and pools. Added for compatibility."
  320. ^ self subclass: aString instanceVariableNames: aString2 package: aString3
  321. !
  322. subclass: aString instanceVariableNames: aString2 package: aString3
  323. ^ ClassBuilder new
  324. superclass: self subclass: aString asString instanceVariableNames: aString2 package: aString3
  325. ! !
  326. !Class methodsFor: 'converting'!
  327. asJavascript
  328. ^ 'smalltalk.', self name
  329. ! !
  330. !Class methodsFor: 'printing'!
  331. printOn: aStream
  332. aStream nextPutAll: self name
  333. ! !
  334. !Class methodsFor: 'testing'!
  335. isClass
  336. ^ true
  337. ! !
  338. Behavior subclass: #Metaclass
  339. instanceVariableNames: ''
  340. package: 'Kernel-Classes'!
  341. !Metaclass commentStamp!
  342. I am the root of the class hierarchy.
  343. My instances are metaclasses, one for each real class, and have a single instance, which they hold onto: the class that they are the metaclass of.!
  344. !Metaclass methodsFor: 'accessing'!
  345. definition
  346. ^ String streamContents: [ :stream |
  347. stream
  348. nextPutAll: self asString;
  349. nextPutAll: ' instanceVariableNames: '''.
  350. self instanceVariableNames
  351. do: [ :each | stream nextPutAll: each ]
  352. separatedBy: [ stream nextPutAll: ' ' ].
  353. stream nextPutAll: '''' ]
  354. !
  355. instanceClass
  356. <return self.instanceClass>
  357. !
  358. instanceVariableNames: aCollection
  359. ClassBuilder new
  360. class: self instanceVariableNames: aCollection
  361. !
  362. subclasses
  363. ^ (self instanceClass subclasses
  364. select: [ :each | each isMetaclass not ])
  365. collect: [ :each | each theMetaClass ]
  366. !
  367. theMetaClass
  368. ^ self
  369. !
  370. theNonMetaClass
  371. ^ self instanceClass
  372. ! !
  373. !Metaclass methodsFor: 'converting'!
  374. asJavascript
  375. ^ 'smalltalk.', self instanceClass name, '.klass'
  376. ! !
  377. !Metaclass methodsFor: 'printing'!
  378. printOn: aStream
  379. aStream
  380. nextPutAll: self instanceClass name;
  381. nextPutAll: ' class'
  382. ! !
  383. !Metaclass methodsFor: 'testing'!
  384. isMetaclass
  385. ^ true
  386. ! !
  387. Object subclass: #ClassBuilder
  388. instanceVariableNames: ''
  389. package: 'Kernel-Classes'!
  390. !ClassBuilder commentStamp!
  391. I am responsible for compiling new classes or modifying existing classes in the system.
  392. Rather than using me directly to compile a class, use `Class >> subclass:instanceVariableNames:package:`.!
  393. !ClassBuilder methodsFor: 'accessing'!
  394. instanceVariableNamesFor: aString
  395. ^ (aString tokenize: ' ') reject: [ :each | each isEmpty ]
  396. ! !
  397. !ClassBuilder methodsFor: 'class definition'!
  398. addSubclassOf: aClass named: className instanceVariableNames: aCollection package: packageName
  399. | theClass thePackage |
  400. theClass := Smalltalk current at: className.
  401. thePackage := self createPackageNamed: packageName.
  402. theClass ifNotNil: [
  403. theClass package: thePackage.
  404. theClass superclass == aClass ifFalse: [
  405. ^ self
  406. migrateClassNamed: className
  407. superclass: aClass
  408. instanceVariableNames: aCollection
  409. package: packageName ] ].
  410. ^ self
  411. basicAddSubclassOf: aClass
  412. named: className
  413. instanceVariableNames: aCollection
  414. package: packageName
  415. !
  416. class: aClass instanceVariableNames: ivarNames
  417. self basicClass: aClass instanceVariableNames: ivarNames.
  418. self setupClass: aClass.
  419. SystemAnnouncer current
  420. announce: (ClassDefinitionChanged new
  421. theClass: aClass;
  422. yourself)
  423. !
  424. superclass: aClass subclass: className
  425. ^ self superclass: aClass subclass: className instanceVariableNames: '' package: nil
  426. !
  427. superclass: aClass subclass: className instanceVariableNames: ivarNames package: packageName
  428. | newClass |
  429. newClass := self addSubclassOf: aClass
  430. named: className instanceVariableNames: (self instanceVariableNamesFor: ivarNames)
  431. package: (packageName ifNil: [ 'unclassified' ]).
  432. self setupClass: newClass.
  433. SystemAnnouncer current
  434. announce: (ClassAdded new
  435. theClass: newClass;
  436. yourself).
  437. ^ newClass
  438. ! !
  439. !ClassBuilder methodsFor: 'class migration'!
  440. migrateClass: aClass superclass: anotherClass
  441. ^ self
  442. migrateClassNamed: aClass name
  443. superclass: anotherClass
  444. instanceVariableNames: aClass instanceVariableNames
  445. package: aClass package name
  446. !
  447. migrateClassNamed: className superclass: aClass instanceVariableNames: aCollection package: packageName
  448. | oldClass newClass tmp |
  449. tmp := 'new*', className.
  450. oldClass := Smalltalk current at: className.
  451. newClass := self
  452. addSubclassOf: aClass
  453. named: tmp
  454. instanceVariableNames: aCollection
  455. package: packageName.
  456. self basicSwapClassNames: oldClass with: newClass.
  457. [ self copyClass: oldClass to: newClass ]
  458. on: Error
  459. do: [ :exception |
  460. self
  461. basicSwapClassNames: oldClass with: newClass;
  462. basicRemoveClass: newClass.
  463. exception signal ].
  464. self
  465. rawRenameClass: oldClass to: tmp;
  466. rawRenameClass: newClass to: className.
  467. oldClass subclasses
  468. do: [ :each | self migrateClass: each superclass: newClass ]
  469. displayingProgress: 'Recompiling ', newClass name, '...'.
  470. self basicRemoveClass: oldClass.
  471. SystemAnnouncer current announce: (ClassMigrated new
  472. theClass: newClass;
  473. oldClass: oldClass;
  474. yourself).
  475. ^ newClass
  476. !
  477. renameClass: aClass to: className
  478. self basicRenameClass: aClass to: className.
  479. "Recompile the class to fix potential issues with super sends"
  480. aClass recompile.
  481. SystemAnnouncer current
  482. announce: (ClassRenamed new
  483. theClass: aClass;
  484. yourself)
  485. ! !
  486. !ClassBuilder methodsFor: 'copying'!
  487. copyClass: aClass named: className
  488. | newClass |
  489. newClass := self
  490. addSubclassOf: aClass superclass
  491. named: className
  492. instanceVariableNames: aClass instanceVariableNames
  493. package: aClass package name.
  494. self copyClass: aClass to: newClass.
  495. SystemAnnouncer current
  496. announce: (ClassAdded new
  497. theClass: newClass;
  498. yourself).
  499. ^ newClass
  500. !
  501. copyClass: aClass to: anotherClass
  502. anotherClass comment: aClass comment.
  503. aClass methodDictionary valuesDo: [ :each |
  504. Compiler new install: each source forClass: anotherClass protocol: each protocol ].
  505. self basicClass: anotherClass class instanceVariables: aClass class instanceVariableNames.
  506. aClass class methodDictionary valuesDo: [ :each |
  507. Compiler new install: each source forClass: anotherClass class protocol: each protocol ].
  508. self setupClass: anotherClass
  509. ! !
  510. !ClassBuilder methodsFor: 'method definition'!
  511. installMethod: aCompiledMethod forClass: aBehavior protocol: aString
  512. aCompiledMethod protocol: aString.
  513. aBehavior addCompiledMethod: aCompiledMethod.
  514. self setupClass: aBehavior.
  515. ^ aCompiledMethod
  516. ! !
  517. !ClassBuilder methodsFor: 'private'!
  518. basicAddSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
  519. <
  520. smalltalk.addClass(aString, aClass, aCollection, packageName);
  521. return smalltalk[aString]
  522. >
  523. !
  524. basicClass: aClass instanceVariableNames: aString
  525. self basicClass: aClass instanceVariables: (self instanceVariableNamesFor: aString)
  526. !
  527. basicClass: aClass instanceVariables: aCollection
  528. aClass isMetaclass ifFalse: [ self error: aClass name, ' is not a metaclass' ].
  529. aClass basicAt: 'iVarNames' put: aCollection
  530. !
  531. basicRemoveClass: aClass
  532. <smalltalk.removeClass(aClass)>
  533. !
  534. basicRenameClass: aClass to: aString
  535. <
  536. smalltalk[aString] = aClass;
  537. delete smalltalk[aClass.className];
  538. aClass.className = aString;
  539. >
  540. !
  541. basicSwapClassNames: aClass with: anotherClass
  542. <
  543. var tmp = aClass.className;
  544. aClass.className = anotherClass.className;
  545. anotherClass.className = tmp;
  546. >
  547. !
  548. createPackageNamed: aString
  549. ^ Package named: aString ifAbsent: [
  550. Smalltalk current createPackage: aString ]
  551. !
  552. rawRenameClass: aClass to: aString
  553. <
  554. smalltalk[aString] = aClass;
  555. >
  556. ! !
  557. !ClassBuilder methodsFor: 'public'!
  558. setupClass: aClass
  559. <smalltalk.init(aClass);>
  560. ! !
  561. Object subclass: #ClassCategoryReader
  562. instanceVariableNames: 'class category'
  563. package: 'Kernel-Classes'!
  564. !ClassCategoryReader commentStamp!
  565. I provide a mechanism for retrieving class descriptions stored on a file in the Smalltalk chunk format.!
  566. !ClassCategoryReader methodsFor: 'accessing'!
  567. class: aClass category: aString
  568. class := aClass.
  569. category := aString
  570. ! !
  571. !ClassCategoryReader methodsFor: 'fileIn'!
  572. scanFrom: aChunkParser
  573. | chunk |
  574. [ chunk := aChunkParser nextChunk.
  575. chunk isEmpty ] whileFalse: [
  576. self compileMethod: chunk ].
  577. ClassBuilder new setupClass: class
  578. ! !
  579. !ClassCategoryReader methodsFor: 'initialization'!
  580. initialize
  581. super initialize.
  582. ! !
  583. !ClassCategoryReader methodsFor: 'private'!
  584. compileMethod: aString
  585. Compiler new install: aString forClass: class protocol: category
  586. ! !
  587. Object subclass: #ClassCommentReader
  588. instanceVariableNames: 'class'
  589. package: 'Kernel-Classes'!
  590. !ClassCommentReader commentStamp!
  591. I provide a mechanism for retrieving class comments stored on a file.
  592. See also `ClassCategoryReader`.!
  593. !ClassCommentReader methodsFor: 'accessing'!
  594. class: aClass
  595. class := aClass
  596. ! !
  597. !ClassCommentReader methodsFor: 'fileIn'!
  598. scanFrom: aChunkParser
  599. | chunk |
  600. chunk := aChunkParser nextChunk.
  601. chunk isEmpty ifFalse: [
  602. self setComment: chunk ].
  603. ! !
  604. !ClassCommentReader methodsFor: 'initialization'!
  605. initialize
  606. super initialize.
  607. ! !
  608. !ClassCommentReader methodsFor: 'private'!
  609. setComment: aString
  610. class comment: aString
  611. ! !
  612. Object subclass: #ClassSorterNode
  613. instanceVariableNames: 'theClass level nodes'
  614. package: 'Kernel-Classes'!
  615. !ClassSorterNode commentStamp!
  616. I provide an algorithm for sorting classes alphabetically.
  617. See [Issue #143](https://github.com/amber-smalltalk/amber/issues/143) on GitHub.!
  618. !ClassSorterNode methodsFor: 'accessing'!
  619. getNodesFrom: aCollection
  620. | children others |
  621. children := #().
  622. others := #().
  623. aCollection do: [ :each |
  624. (each superclass = self theClass)
  625. ifTrue: [ children add: each ]
  626. ifFalse: [ others add: each ]].
  627. nodes:= children collect: [ :each |
  628. ClassSorterNode on: each classes: others level: self level + 1 ]
  629. !
  630. level
  631. ^ level
  632. !
  633. level: anInteger
  634. level := anInteger
  635. !
  636. nodes
  637. ^ nodes
  638. !
  639. theClass
  640. ^ theClass
  641. !
  642. theClass: aClass
  643. theClass := aClass
  644. ! !
  645. !ClassSorterNode methodsFor: 'visiting'!
  646. traverseClassesWith: aCollection
  647. "sort classes alphabetically Issue #143"
  648. aCollection add: self theClass.
  649. (self nodes sorted: [ :a :b | a theClass name <= b theClass name ]) do: [ :aNode |
  650. aNode traverseClassesWith: aCollection ].
  651. ! !
  652. !ClassSorterNode class methodsFor: 'instance creation'!
  653. on: aClass classes: aCollection level: anInteger
  654. ^ self new
  655. theClass: aClass;
  656. level: anInteger;
  657. getNodesFrom: aCollection;
  658. yourself
  659. ! !