Kernel-Classes.st 24 KB

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