Kernel-Classes.st 17 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777
  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: 'enumerating'!
  185. allSubclassesDo: aBlock
  186. "Evaluate the argument, aBlock, for each of the receiver's subclasses."
  187. self subclasses do: [ :each |
  188. aBlock value: each.
  189. each allSubclassesDo: aBlock ].
  190. !
  191. protocolsDo: aBlock
  192. "Execute aBlock for each method category with
  193. its collection of methods in the sort order of category name."
  194. | methodsByCategory |
  195. methodsByCategory := HashedCollection new.
  196. self methodDictionary values do: [:m |
  197. (methodsByCategory at: m category ifAbsentPut: [Array new])
  198. add: m].
  199. self protocols do: [:category |
  200. aBlock value: category value: (methodsByCategory at: category)]
  201. ! !
  202. !Behavior methodsFor: 'instance creation'!
  203. basicNew
  204. <return new self.fn()>
  205. !
  206. new
  207. ^self basicNew initialize
  208. ! !
  209. !Behavior methodsFor: 'private'!
  210. basicAddCompiledMethod: aMethod
  211. <smalltalk.addMethod(aMethod.selector._asSelector(), aMethod, self)>
  212. !
  213. basicRemoveCompiledMethod: aMethod
  214. <
  215. smalltalk.removeMethod(aMethod)
  216. smalltalk.init(self);
  217. >
  218. ! !
  219. !Behavior methodsFor: 'testing'!
  220. canUnderstand: aSelector
  221. ^(self methodDictionary keys includes: aSelector asString) or: [
  222. self superclass notNil and: [self superclass canUnderstand: aSelector]]
  223. !
  224. includesSelector: aSymbol
  225. ^ self methodDictionary includesKey: aSymbol asString
  226. !
  227. inheritsFrom: aClass
  228. ^aClass allSubclasses includes: self
  229. ! !
  230. Behavior subclass: #Class
  231. instanceVariableNames: ''
  232. package: 'Kernel-Classes'!
  233. !Class commentStamp!
  234. Class is __the__ class object.
  235. Instances are the classes of the system.
  236. Class creation is done throught a `ClassBuilder`!
  237. !Class methodsFor: 'accessing'!
  238. category
  239. ^self package ifNil: ['Unclassified'] ifNotNil: [self package name]
  240. !
  241. definition
  242. ^ String streamContents: [ :stream |
  243. stream
  244. nextPutAll: self superclass asString;
  245. nextPutAll: ' subclass: #';
  246. nextPutAll: self name;
  247. nextPutAll: String lf, String tab;
  248. nextPutAll: 'instanceVariableNames: '''.
  249. self instanceVariableNames
  250. do: [ :each | stream nextPutAll: each ]
  251. separatedBy: [ stream nextPutAll: ' ' ].
  252. stream
  253. nextPutAll: '''', String lf, String tab;
  254. nextPutAll: 'package: ''';
  255. nextPutAll: self category;
  256. nextPutAll: '''' ]
  257. !
  258. package
  259. <return self.pkg>
  260. !
  261. package: aPackage
  262. <self.pkg = aPackage>
  263. !
  264. rename: aString
  265. ClassBuilder new renameClass: self to: aString
  266. ! !
  267. !Class methodsFor: 'class creation'!
  268. subclass: aString instanceVariableNames: anotherString
  269. "Kept for compatibility."
  270. ^self subclass: aString instanceVariableNames: anotherString package: nil
  271. !
  272. subclass: aString instanceVariableNames: aString2 category: aString3
  273. "Kept for compatibility."
  274. self deprecatedAPI.
  275. ^self subclass: aString instanceVariableNames: aString2 package: aString3
  276. !
  277. subclass: aString instanceVariableNames: aString2 classVariableNames: classVars poolDictionaries: pools category: aString3
  278. "Just ignore class variables and pools. Added for compatibility."
  279. ^self subclass: aString instanceVariableNames: aString2 package: aString3
  280. !
  281. subclass: aString instanceVariableNames: aString2 package: aString3
  282. ^ClassBuilder new
  283. superclass: self subclass: aString asString instanceVariableNames: aString2 package: aString3
  284. ! !
  285. !Class methodsFor: 'converting'!
  286. asJavascript
  287. ^ 'smalltalk.', self name
  288. ! !
  289. !Class methodsFor: 'printing'!
  290. printOn: aStream
  291. aStream nextPutAll: self name
  292. ! !
  293. !Class methodsFor: 'testing'!
  294. isClass
  295. ^true
  296. ! !
  297. Behavior subclass: #Metaclass
  298. instanceVariableNames: ''
  299. package: 'Kernel-Classes'!
  300. !Metaclass commentStamp!
  301. Metaclass is the root of the class hierarchy.
  302. Metaclass instances are metaclasses, one for each real class.
  303. Metaclass instances have a single instance, which they hold onto, which is the class that they are the metaclass of.!
  304. !Metaclass methodsFor: 'accessing'!
  305. definition
  306. ^ String streamContents: [ :stream |
  307. stream
  308. nextPutAll: self asString;
  309. nextPutAll: ' class ';
  310. nextPutAll: 'instanceVariableNames: '''.
  311. self instanceVariableNames
  312. do: [ :each | stream nextPutAll: each ]
  313. separatedBy: [ stream nextPutAll: ' ' ].
  314. stream nextPutAll: '''' ]
  315. !
  316. instanceClass
  317. <return self.instanceClass>
  318. !
  319. instanceVariableNames: aCollection
  320. ClassBuilder new
  321. class: self instanceVariableNames: aCollection
  322. !
  323. theMetaClass
  324. ^ self
  325. !
  326. theNonMetaClass
  327. ^ self instanceClass
  328. ! !
  329. !Metaclass methodsFor: 'converting'!
  330. asJavascript
  331. ^ 'smalltalk.', self instanceClass name, '.klass'
  332. ! !
  333. !Metaclass methodsFor: 'printing'!
  334. printOn: aStream
  335. aStream
  336. nextPutAll: self instanceClass name;
  337. nextPutAll: ' class'
  338. ! !
  339. !Metaclass methodsFor: 'testing'!
  340. isMetaclass
  341. ^true
  342. ! !
  343. Object subclass: #ClassBuilder
  344. instanceVariableNames: ''
  345. package: 'Kernel-Classes'!
  346. !ClassBuilder commentStamp!
  347. ClassBuilder is responsible for compiling new classes or modifying existing classes in the system.
  348. Rather than using ClassBuilder directly to compile a class, use `Class >> subclass:instanceVariableNames:package:`.!
  349. !ClassBuilder methodsFor: 'accessing'!
  350. instanceVariableNamesFor: aString
  351. ^(aString tokenize: ' ') reject: [ :each | each isEmpty ]
  352. ! !
  353. !ClassBuilder methodsFor: 'class definition'!
  354. addSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
  355. | theClass |
  356. theClass := Smalltalk current at: aString.
  357. theClass ifNotNil: [
  358. theClass superclass == aClass ifFalse: [
  359. ^ self
  360. migrateClassNamed: aString
  361. superclass: aClass
  362. instanceVariableNames: aCollection
  363. package: packageName ] ].
  364. ^ self
  365. basicAddSubclassOf: aClass
  366. named: aString
  367. instanceVariableNames: aCollection
  368. package: packageName
  369. !
  370. class: aClass instanceVariableNames: aString
  371. self basicClass: aClass instanceVariableNames: aString.
  372. self setupClass: aClass.
  373. SystemAnnouncer current
  374. announce: (ClassDefinitionChanged new
  375. theClass: aClass;
  376. yourself)
  377. !
  378. superclass: aClass subclass: aString
  379. ^self superclass: aClass subclass: aString instanceVariableNames: '' package: nil
  380. !
  381. superclass: aClass subclass: aString instanceVariableNames: aString2 package: aString3
  382. | newClass |
  383. newClass := self addSubclassOf: aClass
  384. named: aString instanceVariableNames: (self instanceVariableNamesFor: aString2)
  385. package: (aString3 ifNil: ['unclassified']).
  386. self setupClass: newClass.
  387. SystemAnnouncer current
  388. announce: (ClassAdded new
  389. theClass: newClass;
  390. yourself).
  391. ^newClass
  392. ! !
  393. !ClassBuilder methodsFor: 'class migration'!
  394. migrateClass: aClass superclass: anotherClass
  395. console log: aClass name.
  396. self
  397. migrateClassNamed: aClass name
  398. superclass: anotherClass
  399. instanceVariableNames: aClass instanceVariableNames
  400. package: aClass package name
  401. !
  402. migrateClassNamed: aString superclass: aClass instanceVariableNames: aCollection package: packageName
  403. | oldClass newClass tmp |
  404. tmp := 'new*', aString.
  405. oldClass := Smalltalk current at: aString.
  406. newClass := self
  407. addSubclassOf: aClass
  408. named: tmp
  409. instanceVariableNames: aCollection
  410. package: packageName.
  411. self basicSwapClassNames: oldClass with: newClass.
  412. [ self copyClass: oldClass to: newClass ]
  413. on: Error
  414. do: [ :exception |
  415. self
  416. basicSwapClassNames: oldClass with: newClass;
  417. basicRemoveClass: newClass.
  418. exception signal ].
  419. self
  420. rawRenameClass: oldClass to: tmp;
  421. rawRenameClass: newClass to: aString.
  422. oldClass subclasses do: [ :each |
  423. self migrateClass: each superclass: newClass ].
  424. self basicRemoveClass: oldClass.
  425. ^newClass
  426. !
  427. renameClass: aClass to: aString
  428. self basicRenameClass: aClass to: aString.
  429. SystemAnnouncer current
  430. announce: (ClassRenamed new
  431. theClass: aClass;
  432. yourself)
  433. ! !
  434. !ClassBuilder methodsFor: 'copying'!
  435. copyClass: aClass named: aString
  436. | newClass |
  437. newClass := self
  438. addSubclassOf: aClass superclass
  439. named: aString
  440. instanceVariableNames: aClass instanceVariableNames
  441. package: aClass package name.
  442. self copyClass: aClass to: newClass.
  443. ^newClass
  444. !
  445. copyClass: aClass to: anotherClass
  446. anotherClass comment: aClass comment.
  447. aClass methodDictionary values do: [ :each |
  448. Compiler new install: each source forClass: anotherClass category: each category ].
  449. self basicClass: anotherClass class instanceVariables: aClass class instanceVariableNames.
  450. aClass class methodDictionary values do: [ :each |
  451. Compiler new install: each source forClass: anotherClass class category: each category ].
  452. self setupClass: anotherClass
  453. ! !
  454. !ClassBuilder methodsFor: 'method definition'!
  455. installMethod: aCompiledMethod forClass: aBehavior category: aString
  456. aCompiledMethod category: aString.
  457. aBehavior addCompiledMethod: aCompiledMethod.
  458. self setupClass: aBehavior.
  459. ^aCompiledMethod
  460. ! !
  461. !ClassBuilder methodsFor: 'private'!
  462. basicAddSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
  463. <
  464. smalltalk.addClass(aString, aClass, aCollection, packageName);
  465. return smalltalk[aString]
  466. >
  467. !
  468. basicClass: aClass instanceVariableNames: aString
  469. self basicClass: aClass instanceVariables: (self instanceVariableNamesFor: aString)
  470. !
  471. basicClass: aClass instanceVariables: aCollection
  472. aClass isMetaclass ifFalse: [self error: aClass name, ' is not a metaclass'].
  473. aClass basicAt: 'iVarNames' put: aCollection
  474. !
  475. basicRemoveClass: aClass
  476. <smalltalk.removeClass(aClass)>
  477. !
  478. basicRenameClass: aClass to: aString
  479. <
  480. smalltalk[aString] = aClass;
  481. delete smalltalk[aClass.className];
  482. aClass.className = aString;
  483. >
  484. !
  485. basicSwapClassNames: aClass with: anotherClass
  486. <
  487. var tmp = aClass.className;
  488. aClass.className = anotherClass.className;
  489. anotherClass.className = tmp;
  490. >
  491. !
  492. rawRenameClass: aClass to: aString
  493. <
  494. smalltalk[aString] = aClass;
  495. >
  496. ! !
  497. !ClassBuilder methodsFor: 'public'!
  498. setupClass: aClass
  499. <smalltalk.init(aClass);>
  500. ! !
  501. Object subclass: #ClassCategoryReader
  502. instanceVariableNames: 'class category'
  503. package: 'Kernel-Classes'!
  504. !ClassCategoryReader commentStamp!
  505. ClassCategoryReader represents a mechanism for retrieving class descriptions stored on a file.!
  506. !ClassCategoryReader methodsFor: 'accessing'!
  507. class: aClass category: aString
  508. class := aClass.
  509. category := aString
  510. ! !
  511. !ClassCategoryReader methodsFor: 'fileIn'!
  512. scanFrom: aChunkParser
  513. | chunk |
  514. [chunk := aChunkParser nextChunk.
  515. chunk isEmpty] whileFalse: [
  516. self compileMethod: chunk].
  517. ClassBuilder new setupClass: class
  518. ! !
  519. !ClassCategoryReader methodsFor: 'initialization'!
  520. initialize
  521. super initialize.
  522. ! !
  523. !ClassCategoryReader methodsFor: 'private'!
  524. compileMethod: aString
  525. Compiler new install: aString forClass: class category: category
  526. ! !
  527. Object subclass: #ClassCommentReader
  528. instanceVariableNames: 'class'
  529. package: 'Kernel-Classes'!
  530. !ClassCommentReader commentStamp!
  531. ClassCommentReader represents a mechanism for retrieving class comments stored on a file.
  532. See `ClassCategoryReader` too.!
  533. !ClassCommentReader methodsFor: 'accessing'!
  534. class: aClass
  535. class := aClass
  536. ! !
  537. !ClassCommentReader methodsFor: 'fileIn'!
  538. scanFrom: aChunkParser
  539. | chunk |
  540. chunk := aChunkParser nextChunk.
  541. chunk isEmpty ifFalse: [
  542. self setComment: chunk].
  543. ! !
  544. !ClassCommentReader methodsFor: 'initialization'!
  545. initialize
  546. super initialize.
  547. ! !
  548. !ClassCommentReader methodsFor: 'private'!
  549. setComment: aString
  550. class comment: aString
  551. ! !
  552. Object subclass: #ClassSorterNode
  553. instanceVariableNames: 'theClass level nodes'
  554. package: 'Kernel-Classes'!
  555. !ClassSorterNode methodsFor: 'accessing'!
  556. getNodesFrom: aCollection
  557. | children others |
  558. children := #().
  559. others := #().
  560. aCollection do: [:each |
  561. (each superclass = self theClass)
  562. ifTrue: [children add: each]
  563. ifFalse: [others add: each]].
  564. nodes:= children collect: [:each |
  565. ClassSorterNode on: each classes: others level: self level + 1]
  566. !
  567. level
  568. ^level
  569. !
  570. level: anInteger
  571. level := anInteger
  572. !
  573. nodes
  574. ^nodes
  575. !
  576. theClass
  577. ^theClass
  578. !
  579. theClass: aClass
  580. theClass := aClass
  581. ! !
  582. !ClassSorterNode methodsFor: 'visiting'!
  583. traverseClassesWith: aCollection
  584. "sort classes alphabetically Issue #143"
  585. aCollection add: self theClass.
  586. (self nodes sorted: [:a :b | a theClass name <= b theClass name ]) do: [:aNode |
  587. aNode traverseClassesWith: aCollection ].
  588. ! !
  589. !ClassSorterNode class methodsFor: 'instance creation'!
  590. on: aClass classes: aCollection level: anInteger
  591. ^self new
  592. theClass: aClass;
  593. level: anInteger;
  594. getNodesFrom: aCollection;
  595. yourself
  596. ! !