1
0

Kernel-Classes.st 16 KB

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