Kernel-Classes.st 24 KB

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