2
0

Kernel-Classes.st 17 KB

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