Kernel-Classes.st 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899
  1. Smalltalk 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 `$core.setClassConstructor'"
  74. <$core.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 = $globals.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. methodTemplate
  103. ^ String streamContents: [ :stream |
  104. stream
  105. nextPutAll: 'messageSelectorAndArgumentNames';
  106. nextPutAll: String lf, String tab;
  107. nextPutAll: '"comment stating purpose of message"';
  108. nextPutAll: String lf, String lf, String tab;
  109. nextPutAll: '| temporary variable names |';
  110. nextPutAll: String lf, String tab;
  111. nextPutAll: 'statements' ]
  112. !
  113. methods
  114. ^ self methodDictionary values
  115. !
  116. methodsFor: aString
  117. ^ ClassCategoryReader new
  118. class: self category: aString;
  119. yourself
  120. !
  121. methodsFor: aString stamp: aStamp
  122. "Added for file-in compatibility, ignores stamp."
  123. ^ self methodsFor: aString
  124. !
  125. methodsInProtocol: aString
  126. ^ self methods select: [ :each | each protocol = aString ]
  127. !
  128. name
  129. <return self.className || nil>
  130. !
  131. organization
  132. ^ self basicAt: 'organization'
  133. !
  134. ownMethods
  135. "Answer the methods of the receiver that are not package extensions"
  136. ^ (self ownProtocols
  137. inject: OrderedCollection new
  138. into: [ :acc :each | acc, (self methodsInProtocol: each) ])
  139. sorted: [ :a :b | a selector <= b selector ]
  140. !
  141. ownProtocols
  142. "Answer the protocols of the receiver that are not package extensions"
  143. ^ self protocols reject: [ :each |
  144. each match: '^\*' ]
  145. !
  146. protocols
  147. ^ self organization elements sorted
  148. !
  149. prototype
  150. <return self.fn.prototype>
  151. !
  152. removeProtocolIfEmpty: aString
  153. self methods
  154. detect: [ :each | each protocol = aString ]
  155. ifNone: [ self organization removeElement: aString ]
  156. !
  157. selectors
  158. ^ self methodDictionary keys
  159. !
  160. subclasses
  161. self subclassResponsibility
  162. !
  163. superclass
  164. <return self.superclass || nil>
  165. !
  166. theMetaClass
  167. self subclassResponsibility
  168. !
  169. theNonMetaClass
  170. self subclassResponsibility
  171. !
  172. withAllSubclasses
  173. ^ (Array with: self) addAll: self allSubclasses; yourself
  174. ! !
  175. !Behavior methodsFor: 'compiling'!
  176. addCompiledMethod: aMethod
  177. | oldMethod announcement |
  178. oldMethod := self methodDictionary
  179. at: aMethod selector
  180. ifAbsent: [ nil ].
  181. (self protocols includes: aMethod protocol)
  182. ifFalse: [ self organization addElement: aMethod protocol ].
  183. self basicAddCompiledMethod: aMethod.
  184. oldMethod ifNotNil: [
  185. self removeProtocolIfEmpty: oldMethod protocol ].
  186. announcement := oldMethod
  187. ifNil: [
  188. MethodAdded new
  189. method: aMethod;
  190. yourself ]
  191. ifNotNil: [
  192. MethodModified new
  193. oldMethod: oldMethod;
  194. method: aMethod;
  195. yourself ].
  196. SystemAnnouncer current
  197. announce: announcement
  198. !
  199. compile: aString
  200. ^ self compile: aString protocol: ''
  201. !
  202. compile: aString protocol: anotherString
  203. ^ Compiler new
  204. install: aString
  205. forClass: self
  206. protocol: anotherString
  207. !
  208. recompile
  209. ^ Compiler new recompile: self
  210. !
  211. removeCompiledMethod: aMethod
  212. self basicRemoveCompiledMethod: aMethod.
  213. self removeProtocolIfEmpty: aMethod protocol.
  214. SystemAnnouncer current
  215. announce: (MethodRemoved new
  216. method: aMethod;
  217. yourself)
  218. ! !
  219. !Behavior methodsFor: 'enumerating'!
  220. allSubclassesDo: aBlock
  221. "Evaluate the argument, aBlock, for each of the receiver's subclasses."
  222. self allSubclasses do: [ :each |
  223. aBlock value: each ]
  224. !
  225. protocolsDo: aBlock
  226. "Execute aBlock for each method protocol with
  227. its collection of methods in the sort order of protocol name."
  228. | methodsByProtocol |
  229. methodsByProtocol := HashedCollection new.
  230. self methodDictionary valuesDo: [ :m |
  231. (methodsByProtocol at: m protocol ifAbsentPut: [ Array new ])
  232. add: m ].
  233. self protocols do: [ :protocol |
  234. aBlock value: protocol value: (methodsByProtocol at: protocol) ]
  235. ! !
  236. !Behavior methodsFor: 'instance creation'!
  237. basicNew
  238. <return new self.fn()>
  239. !
  240. new
  241. ^ self basicNew initialize
  242. ! !
  243. !Behavior methodsFor: 'private'!
  244. basicAddCompiledMethod: aMethod
  245. <$core.addMethod(aMethod, self)>
  246. !
  247. basicRemoveCompiledMethod: aMethod
  248. <$core.removeMethod(aMethod,self)>
  249. ! !
  250. !Behavior methodsFor: 'testing'!
  251. canUnderstand: aSelector
  252. ^ (self includesSelector: aSelector asString) or: [
  253. self superclass notNil and: [ self superclass canUnderstand: aSelector ]]
  254. !
  255. includesBehavior: aClass
  256. ^ self == aClass or: [
  257. self inheritsFrom: aClass ]
  258. !
  259. includesSelector: aString
  260. ^ self methodDictionary includesKey: aString
  261. !
  262. inheritsFrom: aClass
  263. self superclass ifNil: [ ^ false ].
  264. ^ aClass == self superclass or: [
  265. self superclass inheritsFrom: aClass ]
  266. !
  267. isBehavior
  268. ^ true
  269. ! !
  270. Behavior subclass: #Class
  271. instanceVariableNames: ''
  272. package: 'Kernel-Classes'!
  273. !Class commentStamp!
  274. I am __the__ class object.
  275. My instances are the classes of the system.
  276. Class creation is done throught a `ClassBuilder` instance.!
  277. !Class methodsFor: 'accessing'!
  278. category
  279. ^ self package ifNil: [ 'Unclassified' ] ifNotNil: [ self package name ]
  280. !
  281. definition
  282. ^ String streamContents: [ :stream |
  283. stream
  284. nextPutAll: self superclass asString;
  285. nextPutAll: ' subclass: #';
  286. nextPutAll: self name;
  287. nextPutAll: String lf, String tab;
  288. nextPutAll: 'instanceVariableNames: '''.
  289. self instanceVariableNames
  290. do: [ :each | stream nextPutAll: each ]
  291. separatedBy: [ stream nextPutAll: ' ' ].
  292. stream
  293. nextPutAll: '''', String lf, String tab;
  294. nextPutAll: 'package: ''';
  295. nextPutAll: self category;
  296. nextPutAll: '''' ]
  297. !
  298. heliosClass
  299. "Should be an Helios extension. Unfortunately, since helios can browse remote
  300. environments, we can't extend base classes"
  301. ^ 'class'
  302. !
  303. package
  304. ^ self basicAt: 'pkg'
  305. !
  306. package: aPackage
  307. | oldPackage |
  308. self package = aPackage ifTrue: [ ^ self ].
  309. oldPackage := self package.
  310. self basicAt: 'pkg' put: aPackage.
  311. oldPackage organization removeElement: self.
  312. aPackage organization addElement: self.
  313. SystemAnnouncer current announce: (ClassMoved new
  314. theClass: self;
  315. oldPackage: oldPackage;
  316. yourself)
  317. !
  318. rename: aString
  319. ClassBuilder new renameClass: self to: aString
  320. !
  321. subclasses
  322. <return self.subclasses._copy()>
  323. !
  324. theMetaClass
  325. ^ self class
  326. !
  327. theNonMetaClass
  328. ^ self
  329. ! !
  330. !Class methodsFor: 'browsing'!
  331. browse
  332. Finder findClass: self
  333. ! !
  334. !Class methodsFor: 'class creation'!
  335. subclass: aString instanceVariableNames: anotherString
  336. "Kept for file-in compatibility."
  337. ^ self subclass: aString instanceVariableNames: anotherString package: nil
  338. !
  339. subclass: aString instanceVariableNames: aString2 category: aString3
  340. "Kept for file-in compatibility."
  341. ^ self subclass: aString instanceVariableNames: aString2 package: aString3
  342. !
  343. subclass: aString instanceVariableNames: aString2 classVariableNames: classVars poolDictionaries: pools category: aString3
  344. "Kept for file-in compatibility. ignores class variables and pools."
  345. ^ self subclass: aString instanceVariableNames: aString2 package: aString3
  346. !
  347. subclass: aString instanceVariableNames: aString2 package: aString3
  348. ^ ClassBuilder new
  349. superclass: self subclass: aString asString instanceVariableNames: aString2 package: aString3
  350. ! !
  351. !Class methodsFor: 'converting'!
  352. asJavascript
  353. ^ '$globals.', self name
  354. ! !
  355. !Class methodsFor: 'printing'!
  356. printOn: aStream
  357. aStream nextPutAll: self name
  358. ! !
  359. !Class methodsFor: 'testing'!
  360. isClass
  361. ^ true
  362. ! !
  363. Behavior subclass: #Metaclass
  364. instanceVariableNames: ''
  365. package: 'Kernel-Classes'!
  366. !Metaclass commentStamp!
  367. I am the root of the class hierarchy.
  368. 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.!
  369. !Metaclass methodsFor: 'accessing'!
  370. definition
  371. ^ String streamContents: [ :stream |
  372. stream
  373. nextPutAll: self asString;
  374. nextPutAll: ' instanceVariableNames: '''.
  375. self instanceVariableNames
  376. do: [ :each | stream nextPutAll: each ]
  377. separatedBy: [ stream nextPutAll: ' ' ].
  378. stream nextPutAll: '''' ]
  379. !
  380. instanceClass
  381. <return self.instanceClass>
  382. !
  383. instanceVariableNames: aCollection
  384. ClassBuilder new
  385. class: self instanceVariableNames: aCollection
  386. !
  387. package
  388. ^ self instanceClass package
  389. !
  390. subclasses
  391. ^ (self instanceClass subclasses
  392. select: [ :each | each isMetaclass not ])
  393. collect: [ :each | each theMetaClass ]
  394. !
  395. theMetaClass
  396. ^ self
  397. !
  398. theNonMetaClass
  399. ^ self instanceClass
  400. ! !
  401. !Metaclass methodsFor: 'converting'!
  402. asJavascript
  403. ^ '$globals.', self instanceClass name, '.klass'
  404. ! !
  405. !Metaclass methodsFor: 'printing'!
  406. printOn: aStream
  407. aStream
  408. nextPutAll: self instanceClass name;
  409. nextPutAll: ' class'
  410. ! !
  411. !Metaclass methodsFor: 'testing'!
  412. isMetaclass
  413. ^ true
  414. ! !
  415. Object subclass: #ClassBuilder
  416. instanceVariableNames: ''
  417. package: 'Kernel-Classes'!
  418. !ClassBuilder commentStamp!
  419. I am responsible for compiling new classes or modifying existing classes in the system.
  420. Rather than using me directly to compile a class, use `Class >> subclass:instanceVariableNames:package:`.!
  421. !ClassBuilder methodsFor: 'accessing'!
  422. instanceVariableNamesFor: aString
  423. ^ (aString tokenize: ' ') reject: [ :each | each isEmpty ]
  424. ! !
  425. !ClassBuilder methodsFor: 'class definition'!
  426. addSubclassOf: aClass named: className instanceVariableNames: aCollection package: packageName
  427. | theClass thePackage |
  428. theClass := Smalltalk globals at: className.
  429. thePackage := Package named: packageName.
  430. theClass ifNotNil: [
  431. theClass package: thePackage.
  432. theClass superclass == aClass ifFalse: [
  433. ^ self
  434. migrateClassNamed: className
  435. superclass: aClass
  436. instanceVariableNames: aCollection
  437. package: packageName ] ].
  438. ^ self
  439. basicAddSubclassOf: aClass
  440. named: className
  441. instanceVariableNames: aCollection
  442. package: packageName
  443. !
  444. class: aClass instanceVariableNames: ivarNames
  445. self basicClass: aClass instanceVariableNames: ivarNames.
  446. self setupClass: aClass.
  447. SystemAnnouncer current
  448. announce: (ClassDefinitionChanged new
  449. theClass: aClass;
  450. yourself)
  451. !
  452. superclass: aClass subclass: className
  453. ^ self superclass: aClass subclass: className instanceVariableNames: '' package: nil
  454. !
  455. superclass: aClass subclass: className instanceVariableNames: ivarNames package: packageName
  456. | newClass |
  457. newClass := self addSubclassOf: aClass
  458. named: className instanceVariableNames: (self instanceVariableNamesFor: ivarNames)
  459. package: (packageName ifNil: [ 'unclassified' ]).
  460. self setupClass: newClass.
  461. SystemAnnouncer current
  462. announce: (ClassAdded new
  463. theClass: newClass;
  464. yourself).
  465. ^ newClass
  466. ! !
  467. !ClassBuilder methodsFor: 'class migration'!
  468. migrateClass: aClass superclass: anotherClass
  469. ^ self
  470. migrateClassNamed: aClass name
  471. superclass: anotherClass
  472. instanceVariableNames: aClass instanceVariableNames
  473. package: aClass package name
  474. !
  475. migrateClassNamed: className superclass: aClass instanceVariableNames: aCollection package: packageName
  476. | oldClass newClass tmp |
  477. tmp := 'new*', className.
  478. oldClass := Smalltalk globals at: className.
  479. newClass := self
  480. addSubclassOf: aClass
  481. named: tmp
  482. instanceVariableNames: aCollection
  483. package: packageName.
  484. self basicSwapClassNames: oldClass with: newClass.
  485. [ self copyClass: oldClass to: newClass ]
  486. on: Error
  487. do: [ :exception |
  488. self
  489. basicSwapClassNames: oldClass with: newClass;
  490. basicRemoveClass: newClass.
  491. exception signal ].
  492. self
  493. rawRenameClass: oldClass to: tmp;
  494. rawRenameClass: newClass to: className.
  495. oldClass subclasses
  496. do: [ :each | self migrateClass: each superclass: newClass ].
  497. self basicRemoveClass: oldClass.
  498. SystemAnnouncer current announce: (ClassMigrated new
  499. theClass: newClass;
  500. oldClass: oldClass;
  501. yourself).
  502. ^ newClass
  503. !
  504. renameClass: aClass to: className
  505. self basicRenameClass: aClass to: className.
  506. "Recompile the class to fix potential issues with super sends"
  507. aClass recompile.
  508. SystemAnnouncer current
  509. announce: (ClassRenamed new
  510. theClass: aClass;
  511. yourself)
  512. ! !
  513. !ClassBuilder methodsFor: 'copying'!
  514. copyClass: aClass named: className
  515. | newClass |
  516. newClass := self
  517. addSubclassOf: aClass superclass
  518. named: className
  519. instanceVariableNames: aClass instanceVariableNames
  520. package: aClass package name.
  521. self copyClass: aClass to: newClass.
  522. SystemAnnouncer current
  523. announce: (ClassAdded new
  524. theClass: newClass;
  525. yourself).
  526. ^ newClass
  527. !
  528. copyClass: aClass to: anotherClass
  529. anotherClass comment: aClass comment.
  530. aClass methodDictionary valuesDo: [ :each |
  531. Compiler new install: each source forClass: anotherClass protocol: each protocol ].
  532. self basicClass: anotherClass class instanceVariables: aClass class instanceVariableNames.
  533. aClass class methodDictionary valuesDo: [ :each |
  534. Compiler new install: each source forClass: anotherClass class protocol: each protocol ].
  535. self setupClass: anotherClass
  536. ! !
  537. !ClassBuilder methodsFor: 'method definition'!
  538. installMethod: aCompiledMethod forClass: aBehavior protocol: aString
  539. aCompiledMethod protocol: aString.
  540. aBehavior addCompiledMethod: aCompiledMethod.
  541. ^ aCompiledMethod
  542. ! !
  543. !ClassBuilder methodsFor: 'private'!
  544. basicAddSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
  545. <
  546. $core.addClass(aString, aClass, aCollection, packageName);
  547. return $globals[aString]
  548. >
  549. !
  550. basicClass: aClass instanceVariableNames: aString
  551. self basicClass: aClass instanceVariables: (self instanceVariableNamesFor: aString)
  552. !
  553. basicClass: aClass instanceVariables: aCollection
  554. aClass isMetaclass ifFalse: [ self error: aClass name, ' is not a metaclass' ].
  555. aClass basicAt: 'iVarNames' put: aCollection
  556. !
  557. basicRemoveClass: aClass
  558. <$core.removeClass(aClass)>
  559. !
  560. basicRenameClass: aClass to: aString
  561. <
  562. $globals[aString] = aClass;
  563. delete $globals[aClass.className];
  564. aClass.className = aString;
  565. >
  566. !
  567. basicSwapClassNames: aClass with: anotherClass
  568. <
  569. var tmp = aClass.className;
  570. aClass.className = anotherClass.className;
  571. anotherClass.className = tmp;
  572. >
  573. !
  574. rawRenameClass: aClass to: aString
  575. <
  576. $globals[aString] = aClass;
  577. >
  578. ! !
  579. !ClassBuilder methodsFor: 'public'!
  580. setupClass: aClass
  581. <$core.init(aClass);>
  582. ! !
  583. Object subclass: #ClassCategoryReader
  584. instanceVariableNames: 'class category'
  585. package: 'Kernel-Classes'!
  586. !ClassCategoryReader commentStamp!
  587. I provide a mechanism for retrieving class descriptions stored on a file in the Smalltalk chunk format.!
  588. !ClassCategoryReader methodsFor: 'accessing'!
  589. class: aClass category: aString
  590. class := aClass.
  591. category := aString
  592. ! !
  593. !ClassCategoryReader methodsFor: 'fileIn'!
  594. scanFrom: aChunkParser
  595. | chunk |
  596. [ chunk := aChunkParser nextChunk.
  597. chunk isEmpty ] whileFalse: [
  598. self compileMethod: chunk ].
  599. ClassBuilder new setupClass: class
  600. ! !
  601. !ClassCategoryReader methodsFor: 'initialization'!
  602. initialize
  603. super initialize.
  604. ! !
  605. !ClassCategoryReader methodsFor: 'private'!
  606. compileMethod: aString
  607. Compiler new install: aString forClass: class protocol: category
  608. ! !
  609. Object subclass: #ClassCommentReader
  610. instanceVariableNames: 'class'
  611. package: 'Kernel-Classes'!
  612. !ClassCommentReader commentStamp!
  613. I provide a mechanism for retrieving class comments stored on a file.
  614. See also `ClassCategoryReader`.!
  615. !ClassCommentReader methodsFor: 'accessing'!
  616. class: aClass
  617. class := aClass
  618. ! !
  619. !ClassCommentReader methodsFor: 'fileIn'!
  620. scanFrom: aChunkParser
  621. | chunk |
  622. chunk := aChunkParser nextChunk.
  623. chunk isEmpty ifFalse: [
  624. self setComment: chunk ].
  625. ! !
  626. !ClassCommentReader methodsFor: 'initialization'!
  627. initialize
  628. super initialize.
  629. ! !
  630. !ClassCommentReader methodsFor: 'private'!
  631. setComment: aString
  632. class comment: aString
  633. ! !
  634. Object subclass: #ClassSorterNode
  635. instanceVariableNames: 'theClass level nodes'
  636. package: 'Kernel-Classes'!
  637. !ClassSorterNode commentStamp!
  638. I provide an algorithm for sorting classes alphabetically.
  639. See [Issue #143](https://github.com/amber-smalltalk/amber/issues/143) on GitHub.!
  640. !ClassSorterNode methodsFor: 'accessing'!
  641. getNodesFrom: aCollection
  642. | children others |
  643. children := #().
  644. others := #().
  645. aCollection do: [ :each |
  646. (each superclass = self theClass)
  647. ifTrue: [ children add: each ]
  648. ifFalse: [ others add: each ]].
  649. nodes:= children collect: [ :each |
  650. ClassSorterNode on: each classes: others level: self level + 1 ]
  651. !
  652. level
  653. ^ level
  654. !
  655. level: anInteger
  656. level := anInteger
  657. !
  658. nodes
  659. ^ nodes
  660. !
  661. theClass
  662. ^ theClass
  663. !
  664. theClass: aClass
  665. theClass := aClass
  666. ! !
  667. !ClassSorterNode methodsFor: 'visiting'!
  668. traverseClassesWith: aCollection
  669. "sort classes alphabetically Issue #143"
  670. aCollection add: self theClass.
  671. (self nodes sorted: [ :a :b | a theClass name <= b theClass name ]) do: [ :aNode |
  672. aNode traverseClassesWith: aCollection ].
  673. ! !
  674. !ClassSorterNode class methodsFor: 'instance creation'!
  675. on: aClass classes: aCollection level: anInteger
  676. ^ self new
  677. theClass: aClass;
  678. level: anInteger;
  679. getNodesFrom: aCollection;
  680. yourself
  681. ! !