Kernel-Classes.st 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110
  1. Smalltalk createPackage: 'Kernel-Classes'!
  2. Object subclass: #Behavior
  3. instanceVariableNames: 'organization'
  4. package: 'Kernel-Classes'!
  5. !Behavior commentStamp!
  6. I am the superclass of all class objects.
  7. In addition to BehaviorBody, I define superclass/subclass relationships and instantiation.
  8. I define the protocol for creating instances of a class with `#basicNew` and `#new` (see `boot.js` for class constructors details).
  9. My instances know about the subclass/superclass relationships between classes and contain the description that instances are created from.
  10. I also provide 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: [ :acc :each | acc addAll: each selectors; yourself ]
  23. !
  24. allSubclasses
  25. "Answer an collection of the receiver's and the receiver's descendent's subclasses. "
  26. ^ Array streamContents: [ :str | self allSubclassesDo: [ :each | str nextPut: each ] ]
  27. !
  28. allSuperclasses
  29. self superclass ifNil: [ ^ #() ].
  30. ^ (OrderedCollection with: self superclass)
  31. addAll: self superclass allSuperclasses;
  32. yourself
  33. !
  34. basicOrganization
  35. ^ organization
  36. !
  37. basicOrganization: aClassOrganizer
  38. organization := aClassOrganizer
  39. !
  40. instanceVariableNames
  41. <inlineJS: 'return self.iVarNames'>
  42. !
  43. javascriptConstructor
  44. "Answer the JS constructor used to instantiate. See boot.js"
  45. <inlineJS: 'return self.fn'>
  46. !
  47. javascriptConstructor: aJavaScriptFunction
  48. "Set the JS constructor used to instantiate.
  49. See the JS counter-part in boot.js `$core.setClassConstructor'"
  50. <inlineJS: '$core.setClassConstructor(self, aJavaScriptFunction);'>
  51. !
  52. lookupSelector: selector
  53. "Look up the given selector in my methodDictionary.
  54. Return the corresponding method if found.
  55. Otherwise chase the superclass chain and try again.
  56. Return nil if no method is found."
  57. | lookupClass |
  58. lookupClass := self.
  59. [ lookupClass = nil ] whileFalse: [
  60. (lookupClass includesSelector: selector)
  61. ifTrue: [ ^ lookupClass methodAt: selector ].
  62. lookupClass := lookupClass superclass ].
  63. ^ nil
  64. !
  65. prototype
  66. <inlineJS: 'return self.fn.prototype'>
  67. !
  68. subclasses
  69. self subclassResponsibility
  70. !
  71. superclass
  72. <inlineJS: 'return self.superclass'>
  73. !
  74. theMetaClass
  75. self subclassResponsibility
  76. !
  77. theNonMetaClass
  78. self subclassResponsibility
  79. !
  80. withAllSubclasses
  81. ^ (Array with: self) addAll: self allSubclasses; yourself
  82. ! !
  83. !Behavior methodsFor: 'enumerating'!
  84. allSubclassesDo: aBlock
  85. "Evaluate the argument, aBlock, for each of the receiver's subclasses."
  86. <inlineJS: '$core.traverseClassTree(self, function(subclass) {
  87. if (subclass !!== self) aBlock._value_(subclass);
  88. })'>
  89. ! !
  90. !Behavior methodsFor: 'instance creation'!
  91. basicNew
  92. <inlineJS: 'return new self.fn()'>
  93. !
  94. new
  95. ^ self basicNew initialize
  96. ! !
  97. !Behavior methodsFor: 'testing'!
  98. canUnderstand: aSelector
  99. ^ (self includesSelector: aSelector asString) or: [
  100. self superclass notNil and: [ self superclass canUnderstand: aSelector ]]
  101. !
  102. includesBehavior: aClass
  103. ^ self == aClass or: [
  104. self inheritsFrom: aClass ]
  105. !
  106. inheritsFrom: aClass
  107. self superclass ifNil: [ ^ false ].
  108. ^ aClass == self superclass or: [
  109. self superclass inheritsFrom: aClass ]
  110. !
  111. isBehavior
  112. ^ true
  113. ! !
  114. Behavior subclass: #Class
  115. instanceVariableNames: ''
  116. package: 'Kernel-Classes'!
  117. !Class commentStamp!
  118. I am __the__ class object.
  119. My instances are the classes of the system.
  120. Class creation is done throught a `ClassBuilder` instance.!
  121. !Class methodsFor: 'accessing'!
  122. classTag
  123. "Returns a tag or general category for this class.
  124. Typically used to help tools do some reflection.
  125. Helios, for example, uses this to decide what icon the class should display."
  126. ^ 'class'
  127. !
  128. definition
  129. ^ String streamContents: [ :stream | stream
  130. print: self superclass; write: ' subclass: '; printSymbol: self name; lf;
  131. write: (self traitCompositionDefinition ifNotEmpty: [ :tcd | { String tab. 'uses: '. tcd. String lf }]);
  132. tab; write: 'instanceVariableNames: '; print: (' ' join: self instanceVariableNames); lf;
  133. tab; write: 'package: '; print: self category ]
  134. !
  135. rename: aString
  136. ClassBuilder new renameClass: self to: aString
  137. !
  138. subclasses
  139. <inlineJS: 'return self.subclasses._copy()'>
  140. !
  141. theMetaClass
  142. ^ self class
  143. ! !
  144. !Class methodsFor: 'testing'!
  145. isClass
  146. ^ true
  147. ! !
  148. Behavior subclass: #Metaclass
  149. instanceVariableNames: ''
  150. package: 'Kernel-Classes'!
  151. !Metaclass commentStamp!
  152. I am the root of the class hierarchy.
  153. 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.!
  154. !Metaclass methodsFor: 'accessing'!
  155. definition
  156. ^ String streamContents: [ :stream | stream
  157. print: self;
  158. write: (self traitCompositionDefinition
  159. ifEmpty: [' ']
  160. ifNotEmpty: [ :tcd | { String lf. String tab. 'uses: '. tcd. String lf. String tab }]);
  161. write: 'instanceVariableNames: ';
  162. print: (' ' join: self instanceVariableNames) ]
  163. !
  164. instanceClass
  165. <inlineJS: 'return self.instanceClass'>
  166. !
  167. instanceVariableNames: aCollection
  168. ClassBuilder new
  169. class: self instanceVariableNames: aCollection.
  170. ^ self
  171. !
  172. name
  173. ^ self instanceClass name, ' class'
  174. !
  175. package
  176. ^ self instanceClass package
  177. !
  178. subclasses
  179. <inlineJS: 'return $core.metaSubclasses(self)'>
  180. !
  181. theMetaClass
  182. ^ self
  183. !
  184. theNonMetaClass
  185. ^ self instanceClass
  186. !
  187. uses: aTraitCompositionDescription instanceVariableNames: aCollection
  188. | metaclass |
  189. metaclass := self instanceVariableNames: aCollection.
  190. metaclass setTraitComposition: aTraitCompositionDescription asTraitComposition.
  191. ^ metaclass
  192. ! !
  193. !Metaclass methodsFor: 'converting'!
  194. asJavaScriptSource
  195. ^ '$globals.', self instanceClass name, '.a$cls'
  196. ! !
  197. !Metaclass methodsFor: 'testing'!
  198. isMetaclass
  199. ^ true
  200. ! !
  201. Object subclass: #ClassBuilder
  202. instanceVariableNames: ''
  203. package: 'Kernel-Classes'!
  204. !ClassBuilder commentStamp!
  205. I am responsible for compiling new classes or modifying existing classes in the system.
  206. Rather than using me directly to compile a class, use `Class >> subclass:instanceVariableNames:package:`.!
  207. !ClassBuilder methodsFor: 'accessing'!
  208. instanceVariableNamesFor: aString
  209. ^ (aString tokenize: ' ') reject: [ :each | each isEmpty ]
  210. ! !
  211. !ClassBuilder methodsFor: 'class definition'!
  212. addSubclassOf: aClass named: className instanceVariableNames: aCollection package: packageName
  213. | theClass thePackage |
  214. theClass := Smalltalk globals at: className.
  215. thePackage := Package named: packageName.
  216. theClass ifNotNil: [
  217. theClass package: thePackage.
  218. theClass superclass == aClass
  219. ifFalse: [ ^ self
  220. migrateClassNamed: className
  221. superclass: aClass
  222. instanceVariableNames: aCollection
  223. package: packageName ] ].
  224. ^ (self
  225. basicAddSubclassOf: aClass
  226. named: className
  227. instanceVariableNames: aCollection
  228. package: packageName) recompile; yourself
  229. !
  230. addTraitNamed: traitName package: packageName
  231. | theTrait thePackage |
  232. theTrait := Smalltalk globals at: traitName.
  233. thePackage := Package named: packageName.
  234. theTrait ifNotNil: [ ^ theTrait package: thePackage; recompile; yourself ].
  235. ^ self
  236. basicAddTraitNamed: traitName
  237. package: packageName
  238. !
  239. class: aClass instanceVariableNames: ivarNames
  240. self basicClass: aClass instanceVariableNames: ivarNames.
  241. SystemAnnouncer current
  242. announce: (ClassDefinitionChanged new
  243. theClass: aClass;
  244. yourself)
  245. !
  246. superclass: aClass subclass: className
  247. ^ self superclass: aClass subclass: className instanceVariableNames: '' package: nil
  248. !
  249. superclass: aClass subclass: className instanceVariableNames: ivarNames package: packageName
  250. | newClass |
  251. newClass := self addSubclassOf: aClass
  252. named: className instanceVariableNames: (self instanceVariableNamesFor: ivarNames)
  253. package: (packageName ifNil: [ 'unclassified' ]).
  254. SystemAnnouncer current
  255. announce: (ClassAdded new
  256. theClass: newClass;
  257. yourself).
  258. ^ newClass
  259. ! !
  260. !ClassBuilder methodsFor: 'class migration'!
  261. migrateClass: aClass superclass: anotherClass
  262. ^ self
  263. migrateClassNamed: aClass name
  264. superclass: anotherClass
  265. instanceVariableNames: aClass instanceVariableNames
  266. package: aClass package name
  267. !
  268. migrateClassNamed: className superclass: aClass instanceVariableNames: aCollection package: packageName
  269. | oldClass newClass tmp |
  270. tmp := 'new*', className.
  271. oldClass := Smalltalk globals at: className.
  272. newClass := self
  273. addSubclassOf: aClass
  274. named: tmp
  275. instanceVariableNames: aCollection
  276. package: packageName.
  277. self basicSwapClassNames: oldClass with: newClass.
  278. [ self copyClass: oldClass to: newClass ]
  279. on: Error
  280. do: [ :exception |
  281. self
  282. basicSwapClassNames: oldClass with: newClass;
  283. basicRemoveClass: newClass.
  284. exception resignal ].
  285. self
  286. rawRenameClass: oldClass to: tmp;
  287. rawRenameClass: newClass to: className.
  288. oldClass subclasses
  289. do: [ :each | self migrateClass: each superclass: newClass ].
  290. self basicRemoveClass: oldClass.
  291. SystemAnnouncer current announce: (ClassMigrated new
  292. theClass: newClass;
  293. oldClass: oldClass;
  294. yourself).
  295. ^ newClass
  296. !
  297. renameClass: aClass to: className
  298. self basicRenameClass: aClass to: className.
  299. "Recompile the class to fix potential issues with super sends"
  300. aClass recompile.
  301. SystemAnnouncer current
  302. announce: (ClassRenamed new
  303. theClass: aClass;
  304. yourself)
  305. ! !
  306. !ClassBuilder methodsFor: 'copying'!
  307. copyClass: aClass named: className
  308. | newClass |
  309. newClass := self
  310. addSubclassOf: aClass superclass
  311. named: className
  312. instanceVariableNames: aClass instanceVariableNames
  313. package: aClass package name.
  314. self copyClass: aClass to: newClass.
  315. SystemAnnouncer current
  316. announce: (ClassAdded new
  317. theClass: newClass;
  318. yourself).
  319. ^ newClass
  320. !
  321. copyClass: aClass to: anotherClass
  322. anotherClass comment: aClass comment.
  323. aClass methodDictionary valuesDo: [ :each |
  324. each methodClass = aClass ifTrue: [
  325. Compiler new install: each source forClass: anotherClass protocol: each protocol ] ].
  326. anotherClass setTraitComposition: aClass traitComposition.
  327. self basicClass: anotherClass class instanceVariables: aClass class instanceVariableNames.
  328. aClass class methodDictionary valuesDo: [ :each |
  329. each methodClass = aClass class ifTrue: [
  330. Compiler new install: each source forClass: anotherClass class protocol: each protocol ] ].
  331. anotherClass class setTraitComposition: aClass class traitComposition
  332. ! !
  333. !ClassBuilder methodsFor: 'method definition'!
  334. installMethod: aCompiledMethod forClass: aBehavior protocol: aString
  335. aCompiledMethod protocol: aString.
  336. aBehavior addCompiledMethod: aCompiledMethod.
  337. ^ aCompiledMethod
  338. ! !
  339. !ClassBuilder methodsFor: 'private'!
  340. basicAddSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
  341. <inlineJS: '
  342. return $core.addClass(aString, aClass, aCollection, packageName);
  343. '>
  344. !
  345. basicAddTraitNamed: aString package: anotherString
  346. <inlineJS: 'return $core.addTrait(aString, anotherString)'>
  347. !
  348. basicClass: aClass instanceVariableNames: aString
  349. self basicClass: aClass instanceVariables: (self instanceVariableNamesFor: aString)
  350. !
  351. basicClass: aClass instanceVariables: aCollection
  352. aClass isMetaclass ifFalse: [ self error: aClass name, ' is not a metaclass' ].
  353. aClass basicAt: 'iVarNames' put: aCollection
  354. !
  355. basicRemoveClass: aClass
  356. <inlineJS: '$core.removeClass(aClass)'>
  357. !
  358. basicRenameClass: aClass to: aString
  359. <inlineJS: '
  360. $globals[aString] = aClass;
  361. delete $globals[aClass.className];
  362. aClass.className = aString;
  363. '>
  364. !
  365. basicSwapClassNames: aClass with: anotherClass
  366. <inlineJS: '
  367. var tmp = aClass.className;
  368. aClass.className = anotherClass.className;
  369. anotherClass.className = tmp;
  370. '>
  371. !
  372. rawRenameClass: aClass to: aString
  373. <inlineJS: '
  374. $globals[aString] = aClass;
  375. '>
  376. ! !
  377. !ClassBuilder methodsFor: 'public'!
  378. setupClass: aClass
  379. self deprecatedAPI: 'Classes are now auto-inited.'
  380. ! !
  381. Object subclass: #ClassSorterNode
  382. instanceVariableNames: 'theClass level nodes'
  383. package: 'Kernel-Classes'!
  384. !ClassSorterNode commentStamp!
  385. I provide an algorithm for sorting classes alphabetically.
  386. See [Issue #143](https://lolg.it/amber/amber/issues/143).!
  387. !ClassSorterNode methodsFor: 'accessing'!
  388. getNodesFrom: aCollection
  389. | children others |
  390. children := #().
  391. others := #().
  392. aCollection do: [ :each |
  393. (each superclass = self theClass)
  394. ifTrue: [ children add: each ]
  395. ifFalse: [ others add: each ]].
  396. nodes:= children collect: [ :each |
  397. ClassSorterNode on: each classes: others level: self level + 1 ]
  398. !
  399. level
  400. ^ level
  401. !
  402. level: anInteger
  403. level := anInteger
  404. !
  405. nodes
  406. ^ nodes
  407. !
  408. theClass
  409. ^ theClass
  410. !
  411. theClass: aClass
  412. theClass := aClass
  413. ! !
  414. !ClassSorterNode methodsFor: 'visiting'!
  415. traverseClassesWith: aCollection
  416. "sort classes alphabetically Issue #143"
  417. aCollection add: self theClass.
  418. (self nodes sorted: [ :a :b | a theClass name <= b theClass name ]) do: [ :aNode |
  419. aNode traverseClassesWith: aCollection ].
  420. ! !
  421. !ClassSorterNode class methodsFor: 'instance creation'!
  422. on: aClass classes: aCollection level: anInteger
  423. ^ self new
  424. theClass: aClass;
  425. level: anInteger;
  426. getNodesFrom: aCollection;
  427. yourself
  428. ! !
  429. Trait named: #TBehaviorDefaults
  430. package: 'Kernel-Classes'!
  431. !TBehaviorDefaults methodsFor: 'accessing'!
  432. allInstanceVariableNames
  433. "Default for non-classes; to be able to send #allInstanceVariableNames to any class / trait."
  434. ^ #()
  435. !
  436. name
  437. ^ nil
  438. !
  439. superclass
  440. "Default for non-classes; to be able to send #superclass to any class / trait."
  441. ^ nil
  442. !
  443. traitUsers
  444. "Default for non-traits; to be able to send #traitUsers to any class / trait"
  445. ^ #()
  446. ! !
  447. !TBehaviorDefaults methodsFor: 'enumerating'!
  448. allSubclassesDo: aBlock
  449. "Default for non-classes; to be able to send #allSubclassesDo: to any class / trait."
  450. ! !
  451. !TBehaviorDefaults methodsFor: 'printing'!
  452. printOn: aStream
  453. self name
  454. ifNil: [ super printOn: aStream ]
  455. ifNotNil: [ :name | aStream nextPutAll: name ]
  456. ! !
  457. Trait named: #TBehaviorProvider
  458. package: 'Kernel-Classes'!
  459. !TBehaviorProvider commentStamp!
  460. I have method dictionary and organization.!
  461. !TBehaviorProvider methodsFor: 'accessing'!
  462. >> aString
  463. ^ self methodAt: aString
  464. !
  465. methodAt: aString
  466. ^ self methodDictionary at: aString
  467. !
  468. methodDictionary
  469. <inlineJS: 'var dict = $globals.HashedCollection._new();
  470. var methods = self.methods;
  471. Object.keys(methods).forEach(function(i) {
  472. if(methods[i].selector) {
  473. dict._at_put_(methods[i].selector, methods[i]);
  474. }
  475. });
  476. return dict'>
  477. !
  478. methodOrganizationEnter: aMethod andLeave: oldMethod
  479. aMethod ifNotNil: [
  480. self organization addElement: aMethod protocol ].
  481. oldMethod ifNotNil: [
  482. self removeProtocolIfEmpty: oldMethod protocol ]
  483. !
  484. methodTemplate
  485. ^ String streamContents: [ :stream | stream
  486. write: 'messageSelectorAndArgumentNames'; lf;
  487. tab; write: '"comment stating purpose of message"'; lf;
  488. lf;
  489. tab; write: '| temporary variable names |'; lf;
  490. tab; write: 'statements' ]
  491. !
  492. methods
  493. ^ self methodDictionary values
  494. !
  495. methodsInProtocol: aString
  496. ^ self methods select: [ :each | each protocol = aString ]
  497. !
  498. organization
  499. ^ self basicOrganization ifNil: [
  500. self basicOrganization: (ClassOrganizer on: self).
  501. self basicOrganization ]
  502. !
  503. ownMethods
  504. "Answer the methods of the receiver that are not package extensions
  505. nor obtained via trait composition"
  506. ^ (self ownProtocols
  507. inject: OrderedCollection new
  508. into: [ :acc :each | acc, (self ownMethodsInProtocol: each) ])
  509. sorted: [ :a :b | a selector <= b selector ]
  510. !
  511. ownMethodsInProtocol: aString
  512. ^ (self methodsInProtocol: aString) select: [ :each | each methodClass = self ]
  513. !
  514. ownProtocols
  515. "Answer the protocols of the receiver that are not package extensions"
  516. ^ self protocols reject: [ :each |
  517. each match: '^\*' ]
  518. !
  519. packageOfProtocol: aString
  520. "Answer the package the method of receiver belongs to:
  521. - if it is an extension method, answer the corresponding package
  522. - else answer the receiver's package"
  523. (aString beginsWith: '*') ifFalse: [
  524. ^ self package ].
  525. ^ Package
  526. named: aString allButFirst
  527. ifAbsent: [ nil ]
  528. !
  529. protocols
  530. ^ self organization elements asArray sorted
  531. !
  532. removeProtocolIfEmpty: aString
  533. self methods
  534. detect: [ :each | each protocol = aString ]
  535. ifNone: [ self organization removeElement: aString ]
  536. !
  537. selectors
  538. ^ self methodDictionary keys
  539. !
  540. traitComposition
  541. ^ (self basicAt: 'traitComposition')
  542. ifNil: [ #() ]
  543. ifNotNil: [ :aCollection | aCollection collect: [ :each | TraitTransformation fromJSON: each ] ]
  544. !
  545. traitCompositionDefinition
  546. ^ self traitComposition ifNotEmpty: [ :traitComposition |
  547. String streamContents: [ :str |
  548. str write: '{'.
  549. traitComposition
  550. do: [ :each | str write: each definition ]
  551. separatedBy: [ str write: '. ' ].
  552. str write: '}' ] ]
  553. ! !
  554. !TBehaviorProvider methodsFor: 'compiling'!
  555. addCompiledMethod: aMethod
  556. | oldMethod announcement |
  557. oldMethod := self methodDictionary
  558. at: aMethod selector
  559. ifAbsent: [ nil ].
  560. self basicAddCompiledMethod: aMethod.
  561. announcement := oldMethod
  562. ifNil: [
  563. MethodAdded new
  564. method: aMethod;
  565. yourself ]
  566. ifNotNil: [
  567. MethodModified new
  568. oldMethod: oldMethod;
  569. method: aMethod;
  570. yourself ].
  571. SystemAnnouncer current
  572. announce: announcement
  573. !
  574. compile: aString protocol: anotherString
  575. ^ Compiler new
  576. install: aString
  577. forClass: self
  578. protocol: anotherString
  579. !
  580. recompile
  581. ^ Compiler new recompile: self
  582. !
  583. removeCompiledMethod: aMethod
  584. self basicRemoveCompiledMethod: aMethod.
  585. SystemAnnouncer current
  586. announce: (MethodRemoved new
  587. method: aMethod;
  588. yourself)
  589. !
  590. setTraitComposition: aTraitComposition
  591. <inlineJS: '$core.setTraitComposition(aTraitComposition._asJavaScriptObject(), self)'>
  592. ! !
  593. !TBehaviorProvider methodsFor: 'enumerating'!
  594. protocolsDo: aBlock
  595. "Execute aBlock for each method protocol with
  596. its collection of methods in the sort order of protocol name."
  597. | methodsByProtocol |
  598. methodsByProtocol := HashedCollection new.
  599. self methodDictionary valuesDo: [ :m |
  600. (methodsByProtocol at: m protocol ifAbsentPut: [ Array new ])
  601. add: m ].
  602. self protocols do: [ :protocol |
  603. aBlock value: protocol value: (methodsByProtocol at: protocol) ]
  604. ! !
  605. !TBehaviorProvider methodsFor: 'private'!
  606. basicAddCompiledMethod: aMethod
  607. <inlineJS: '$core.addMethod(aMethod, self)'>
  608. !
  609. basicRemoveCompiledMethod: aMethod
  610. <inlineJS: '$core.removeMethod(aMethod,self)'>
  611. ! !
  612. !TBehaviorProvider methodsFor: 'testing'!
  613. includesSelector: aString
  614. ^ self methodDictionary includesKey: aString
  615. ! !
  616. Trait named: #TMasterBehavior
  617. package: 'Kernel-Classes'!
  618. !TMasterBehavior commentStamp!
  619. I am the behavior on the instance-side of the browser.
  620. I define things like package, category, name, comment etc.
  621. as opposed to derived behaviors (metaclass, class trait, ...)
  622. that relate to me.!
  623. !TMasterBehavior methodsFor: 'accessing'!
  624. category
  625. ^ self package ifNil: [ 'Unclassified' ] ifNotNil: [ self package name ]
  626. !
  627. classTag
  628. "Every master behavior should define a class tag."
  629. ^ self subclassResponsibility
  630. !
  631. comment
  632. ^ (self basicAt: 'comment') ifNil: [ '' ]
  633. !
  634. comment: aString
  635. self basicAt: 'comment' put: aString.
  636. SystemAnnouncer current
  637. announce: (ClassCommentChanged new
  638. theClass: self;
  639. yourself)
  640. !
  641. definedMethods
  642. "Answers methods of me and derived 'meta' part if present"
  643. | methods |
  644. methods := self methods.
  645. self theMetaClass
  646. ifNil: [ ^ methods ]
  647. ifNotNil: [ :meta | ^ methods, meta methods ]
  648. !
  649. enterOrganization
  650. Smalltalk ifNotNil: [
  651. self package isString ifTrue: [ self basicAt: 'pkg' put: (Package named: self package) ].
  652. self package organization addElement: self ]
  653. !
  654. leaveOrganization
  655. Smalltalk ifNotNil: [
  656. self package organization removeElement: self ]
  657. !
  658. name
  659. <inlineJS: 'return self.className'>
  660. !
  661. package
  662. ^ self basicAt: 'pkg'
  663. !
  664. package: aPackage
  665. | oldPackage |
  666. self package = aPackage ifTrue: [ ^ self ].
  667. oldPackage := self package.
  668. self
  669. leaveOrganization;
  670. basicAt: 'pkg' put: aPackage;
  671. enterOrganization.
  672. SystemAnnouncer current announce: (ClassMoved new
  673. theClass: self;
  674. oldPackage: oldPackage;
  675. yourself)
  676. !
  677. theNonMetaClass
  678. ^ self
  679. ! !
  680. !TMasterBehavior methodsFor: 'browsing'!
  681. browse
  682. Finder findClass: self
  683. ! !
  684. !TMasterBehavior methodsFor: 'converting'!
  685. asJavaScriptSource
  686. ^ '$globals.', self name
  687. ! !
  688. Object subclass: #Trait
  689. instanceVariableNames: 'organization'
  690. package: 'Kernel-Classes'!
  691. !Trait methodsFor: 'accessing'!
  692. basicOrganization
  693. ^ organization
  694. !
  695. basicOrganization: aClassOrganizer
  696. organization := aClassOrganizer
  697. !
  698. classTag
  699. ^ 'trait'
  700. !
  701. definition
  702. ^ String streamContents: [ :stream | stream
  703. write: 'Trait named: '; printSymbol: self name; lf;
  704. write: (self traitCompositionDefinition ifNotEmpty: [ :tcd | { String tab. 'uses: '. tcd. String lf }]);
  705. tab; write: 'package: '; print: self category ]
  706. !
  707. theMetaClass
  708. ^ nil
  709. !
  710. traitUsers
  711. ^ (self basicAt: 'traitUsers') copy
  712. ! !
  713. !Trait methodsFor: 'composition'!
  714. - anArray
  715. ^ self asTraitTransformation - anArray
  716. !
  717. @ anArrayOfAssociations
  718. ^ self asTraitTransformation @ anArrayOfAssociations
  719. ! !
  720. !Trait methodsFor: 'converting'!
  721. asTraitComposition
  722. ^ self asTraitTransformation asTraitComposition
  723. !
  724. asTraitTransformation
  725. ^ TraitTransformation on: self
  726. ! !
  727. !Trait class methodsFor: 'instance creation'!
  728. named: aString package: anotherString
  729. ^ ClassBuilder new addTraitNamed: aString package: anotherString
  730. !
  731. named: aString uses: aTraitCompositionDescription package: anotherString
  732. | trait |
  733. trait := self named: aString package: anotherString.
  734. trait setTraitComposition: aTraitCompositionDescription asTraitComposition.
  735. ^ trait
  736. ! !
  737. Object subclass: #TraitTransformation
  738. instanceVariableNames: 'trait aliases exclusions'
  739. package: 'Kernel-Classes'!
  740. !TraitTransformation commentStamp!
  741. I am a single step in trait composition.
  742. I represent one trait including its aliases and exclusions.!
  743. !TraitTransformation methodsFor: 'accessing'!
  744. addAliases: anArrayOfAssociations
  745. anArrayOfAssociations do: [ :each |
  746. | key |
  747. key := each key.
  748. aliases at: key
  749. ifPresent: [ self error: 'Cannot use same alias name twice.' ]
  750. ifAbsent: [ aliases at: key put: each value ] ].
  751. ^ anArrayOfAssociations
  752. !
  753. addExclusions: anArray
  754. exclusions addAll: anArray.
  755. ^ anArray
  756. !
  757. aliases
  758. ^ aliases
  759. !
  760. definition
  761. ^ String streamContents: [ :str |
  762. str print: self trait.
  763. self aliases ifNotEmpty: [ :al |
  764. str write: ' @ {'.
  765. al associations
  766. do: [ :each | str printSymbol: each key; write: ' -> '; printSymbol: each value ]
  767. separatedBy: [ str write: '. ' ].
  768. str write: '}' ].
  769. self exclusions ifNotEmpty: [ :ex |
  770. str write: ' - #('.
  771. ex asArray sorted
  772. do: [ :each | str write: each symbolPrintString allButFirst ]
  773. separatedBy: [ str space ].
  774. str write: ')' ] ]
  775. !
  776. exclusions
  777. ^ exclusions
  778. !
  779. trait
  780. ^ trait
  781. !
  782. trait: anObject
  783. trait := anObject
  784. ! !
  785. !TraitTransformation methodsFor: 'composition'!
  786. - anArray
  787. ^ self copy addExclusions: anArray; yourself
  788. !
  789. @ anArrayOfAssociations
  790. ^ self copy addAliases: anArrayOfAssociations; yourself
  791. ! !
  792. !TraitTransformation methodsFor: 'converting'!
  793. asJavaScriptObject
  794. ^ #{
  795. 'trait' -> self trait.
  796. 'aliases' -> self aliases.
  797. 'exclusions' -> self exclusions asArray sorted }
  798. !
  799. asJavaScriptSource
  800. ^ String streamContents: [ :str | str write: {
  801. '{trait: '. self trait asJavaScriptSource.
  802. self aliases ifNotEmpty: [ :al |
  803. {', aliases: '. al asJSONString} ].
  804. self exclusions ifNotEmpty: [ :ex |
  805. {', exclusions: '. ex asArray sorted asJavaScriptSource} ].
  806. '}' } ]
  807. !
  808. asTraitComposition
  809. ^ { self }
  810. !
  811. asTraitTransformation
  812. ^ self
  813. ! !
  814. !TraitTransformation methodsFor: 'copying'!
  815. postCopy
  816. aliases := aliases copy.
  817. exclusions := exclusions copy
  818. ! !
  819. !TraitTransformation methodsFor: 'initialization'!
  820. initialize
  821. super initialize.
  822. aliases := #{}.
  823. exclusions := Set new.
  824. trait := nil
  825. ! !
  826. !TraitTransformation class methodsFor: 'instance creation'!
  827. fromJSON: aJSObject
  828. ^ super new
  829. trait: (aJSObject at: #trait);
  830. addAliases: (Smalltalk readJSObject: (aJSObject at: #aliases ifAbsent: [#{}])) associations;
  831. addExclusions: (aJSObject at: #exclusions ifAbsent: [#()]);
  832. yourself
  833. !
  834. on: aTrait
  835. ^ super new trait: aTrait; yourself
  836. ! !
  837. Behavior setTraitComposition: {TBehaviorDefaults. TBehaviorProvider} asTraitComposition!
  838. Class setTraitComposition: {TMasterBehavior. TSubclassable} asTraitComposition!
  839. Trait setTraitComposition: {TBehaviorDefaults. TBehaviorProvider. TMasterBehavior} asTraitComposition!
  840. ! !
  841. !Array methodsFor: '*Kernel-Classes'!
  842. asTraitComposition
  843. "not implemented yet, noop atm"
  844. ^ self collect: [ :each | each asTraitTransformation ]
  845. ! !