Kernel-Classes.st 18 KB

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