Kernel-Classes.st 17 KB

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