1
0

Parser.st 22 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025
  1. Object subclass: #PPParser
  2. instanceVariableNames: 'memo'
  3. category: 'Parser'!
  4. !PPParser methodsFor: 'accessing'!
  5. memo
  6. ^memo
  7. ! !
  8. !PPParser methodsFor: 'initialization'!
  9. initialize
  10. memo := Dictionary new
  11. ! !
  12. !PPParser methodsFor: 'operations'!
  13. flatten
  14. ^PPFlattenParser on: self
  15. !
  16. withSource
  17. ^PPSourceParser on: self
  18. !
  19. ==> aBlock
  20. ^PPActionParser on: self block: aBlock
  21. !
  22. , aParser
  23. ^PPSequenceParser with: self with: aParser
  24. !
  25. / aParser
  26. ^PPChoiceParser with: self with: aParser
  27. !
  28. plus
  29. ^PPRepeatingParser on: self min: 1
  30. !
  31. star
  32. ^PPRepeatingParser on: self min: 0
  33. !
  34. not
  35. ^PPNotParser on: self
  36. !
  37. optional
  38. ^self / PPEpsilonParser new
  39. !
  40. memoizedParse: aStream
  41. | start end node |
  42. start := aStream position.
  43. ^self memo at: start
  44. ifPresent: [:value |
  45. aStream position: (self memo at: start) second.
  46. value first]
  47. ifAbsent: [
  48. node := self parse: aStream.
  49. end := aStream position.
  50. self memo at: start put: (Array with: node with: end).
  51. node]
  52. ! !
  53. !PPParser methodsFor: 'parsing'!
  54. parse: aStream
  55. self subclassResponsibility
  56. !
  57. parseAll: aStream
  58. | result |
  59. result := (PPSequenceParser with: self with: PPEOFParser new) memoizedParse: aStream.
  60. ^result isParseFailure
  61. ifTrue: [self error: (result messageFor: aStream contents)]
  62. ifFalse: [result first]
  63. ! !
  64. PPParser subclass: #PPEOFParser
  65. instanceVariableNames: ''
  66. category: 'Parser'!
  67. !PPEOFParser methodsFor: 'parsing'!
  68. parse: aStream
  69. ^aStream atEnd
  70. ifFalse: [
  71. PPFailure new reason: aStream contents, String lf, '---------------', String lf, 'EOF expected' at: aStream position]
  72. ifTrue: [nil]
  73. ! !
  74. PPParser subclass: #PPAnyParser
  75. instanceVariableNames: ''
  76. category: 'Parser'!
  77. !PPAnyParser methodsFor: 'parsing'!
  78. parse: aStream
  79. ^aStream atEnd
  80. ifTrue: [PPFailure new
  81. reason: 'did not expect EOF' at: aStream position]
  82. ifFalse: [aStream next]
  83. ! !
  84. PPParser subclass: #PPEpsilonParser
  85. instanceVariableNames: ''
  86. category: 'Parser'!
  87. !PPEpsilonParser methodsFor: 'parsing'!
  88. parse: aStream
  89. ^nil
  90. ! !
  91. PPParser subclass: #PPStringParser
  92. instanceVariableNames: 'string'
  93. category: 'Parser'!
  94. !PPStringParser methodsFor: 'accessing'!
  95. string
  96. ^string
  97. !
  98. string: aString
  99. string := aString
  100. ! !
  101. !PPStringParser methodsFor: 'parsing'!
  102. parse: aStream
  103. | position result |
  104. position := aStream position.
  105. result := aStream next: self string size.
  106. ^result = self string
  107. ifTrue: [result]
  108. ifFalse: [
  109. aStream position: position.
  110. PPFailure new reason: 'Expected ', self string, ' but got ', (result at: position) printString; yourself]
  111. ! !
  112. PPParser subclass: #PPCharacterParser
  113. instanceVariableNames: 'regexp'
  114. category: 'Parser'!
  115. !PPCharacterParser methodsFor: 'accessing'!
  116. string: aString
  117. regexp := RegularExpression fromString: '[', aString, ']'
  118. ! !
  119. !PPCharacterParser methodsFor: 'parsing'!
  120. parse: aStream
  121. ^(aStream peek notNil and: [self match: aStream peek])
  122. ifTrue: [aStream next]
  123. ifFalse: [PPFailure new reason: 'Could not match' at: aStream position]
  124. ! !
  125. !PPCharacterParser methodsFor: 'private'!
  126. match: aString
  127. ^aString match: regexp
  128. ! !
  129. PPParser subclass: #PPListParser
  130. instanceVariableNames: 'parsers'
  131. category: 'Parser'!
  132. !PPListParser methodsFor: 'accessing'!
  133. parsers
  134. ^parsers ifNil: [#()]
  135. !
  136. parsers: aCollection
  137. parsers := aCollection
  138. ! !
  139. !PPListParser methodsFor: 'copying'!
  140. copyWith: aParser
  141. ^self class withAll: (self parsers copyWith: aParser)
  142. ! !
  143. !PPListParser class methodsFor: 'instance creation'!
  144. withAll: aCollection
  145. ^self new
  146. parsers: aCollection;
  147. yourself
  148. !
  149. with: aParser with: anotherParser
  150. ^self withAll: (Array with: aParser with: anotherParser)
  151. ! !
  152. PPListParser subclass: #PPSequenceParser
  153. instanceVariableNames: ''
  154. category: 'Parser'!
  155. !PPSequenceParser methodsFor: 'copying'!
  156. , aRule
  157. ^self copyWith: aRule
  158. ! !
  159. !PPSequenceParser methodsFor: 'parsing'!
  160. parse: aStream
  161. | start elements element |
  162. start := aStream position.
  163. elements := #().
  164. self parsers
  165. detect: [:each |
  166. element := each memoizedParse: aStream.
  167. elements add: element.
  168. element isParseFailure]
  169. ifNone: [].
  170. ^element isParseFailure
  171. ifFalse: [elements]
  172. ifTrue: [aStream position: start. element]
  173. ! !
  174. PPListParser subclass: #PPChoiceParser
  175. instanceVariableNames: ''
  176. category: 'Parser'!
  177. !PPChoiceParser methodsFor: 'copying'!
  178. / aRule
  179. ^self copyWith: aRule
  180. ! !
  181. !PPChoiceParser methodsFor: 'parsing'!
  182. parse: aStream
  183. | result |
  184. self parsers
  185. detect: [:each |
  186. result := each memoizedParse: aStream.
  187. result isParseFailure not]
  188. ifNone: [].
  189. ^result
  190. ! !
  191. PPParser subclass: #PPDelegateParser
  192. instanceVariableNames: 'parser'
  193. category: 'Parser'!
  194. !PPDelegateParser methodsFor: 'accessing'!
  195. parser
  196. ^parser
  197. !
  198. parser: aParser
  199. parser := aParser
  200. ! !
  201. !PPDelegateParser methodsFor: 'parsing'!
  202. parse: aStream
  203. ^self parser memoizedParse: aStream
  204. ! !
  205. !PPDelegateParser class methodsFor: 'instance creation'!
  206. on: aParser
  207. ^self new
  208. parser: aParser;
  209. yourself
  210. ! !
  211. PPDelegateParser subclass: #PPAndParser
  212. instanceVariableNames: ''
  213. category: 'Parser'!
  214. !PPAndParser methodsFor: 'parsing'!
  215. parse: aStream
  216. ^self basicParse: aStream
  217. !
  218. basicParse: aStream
  219. | element position |
  220. position := aStream position.
  221. element := self parser memoizedParse: aStream.
  222. aStream position: position.
  223. ^element
  224. ! !
  225. PPAndParser subclass: #PPNotParser
  226. instanceVariableNames: ''
  227. category: 'Parser'!
  228. !PPNotParser methodsFor: 'parsing'!
  229. parse: aStream
  230. | element |
  231. element := self basicParse: aStream.
  232. ^element isParseFailure
  233. ifTrue: [nil]
  234. ifFalse: [PPFailure reason: element at: aStream position]
  235. ! !
  236. PPDelegateParser subclass: #PPActionParser
  237. instanceVariableNames: 'block'
  238. category: 'Parser'!
  239. !PPActionParser methodsFor: 'accessing'!
  240. block
  241. ^block
  242. !
  243. block: aBlock
  244. block := aBlock
  245. ! !
  246. !PPActionParser methodsFor: 'parsing'!
  247. parse: aStream
  248. | element |
  249. element := self parser memoizedParse: aStream.
  250. ^element isParseFailure
  251. ifFalse: [self block value: element]
  252. ifTrue: [element]
  253. ! !
  254. !PPActionParser class methodsFor: 'instance creation'!
  255. on: aParser block: aBlock
  256. ^self new
  257. parser: aParser;
  258. block: aBlock;
  259. yourself
  260. ! !
  261. PPDelegateParser subclass: #PPFlattenParser
  262. instanceVariableNames: ''
  263. category: 'Parser'!
  264. !PPFlattenParser methodsFor: 'parsing'!
  265. parse: aStream
  266. | start element stop |
  267. start := aStream position.
  268. element := self parser memoizedParse: aStream.
  269. ^element isParseFailure
  270. ifTrue: [element]
  271. ifFalse: [aStream collection
  272. copyFrom: start + 1
  273. to: aStream position]
  274. ! !
  275. PPDelegateParser subclass: #PPSourceParser
  276. instanceVariableNames: ''
  277. category: 'Parser'!
  278. !PPSourceParser methodsFor: 'parsing'!
  279. parse: aStream
  280. | start element stop result |
  281. start := aStream position.
  282. element := self parser memoizedParse: aStream.
  283. ^element isParseFailure
  284. ifTrue: [element]
  285. ifFalse: [result := aStream collection copyFrom: start + 1 to: aStream position.
  286. Array with: element with: result].
  287. ! !
  288. PPDelegateParser subclass: #PPRepeatingParser
  289. instanceVariableNames: 'min'
  290. category: 'Parser'!
  291. !PPRepeatingParser methodsFor: 'accessing'!
  292. min
  293. ^min
  294. !
  295. min: aNumber
  296. min := aNumber
  297. ! !
  298. !PPRepeatingParser methodsFor: 'parsing'!
  299. parse: aStream
  300. | start element elements failure |
  301. start := aStream position.
  302. elements := Array new.
  303. [(elements size < self min) and: [failure isNil]] whileTrue: [
  304. element := self parser memoizedParse: aStream.
  305. element isParseFailure
  306. ifFalse: [elements addLast: element]
  307. ifTrue: [aStream position: start.
  308. failure := element]].
  309. ^failure ifNil: [
  310. [failure isNil] whileTrue: [
  311. element := self parser memoizedParse: aStream.
  312. element isParseFailure
  313. ifTrue: [failure := element]
  314. ifFalse: [elements addLast: element]].
  315. elements]
  316. ifNotNil: [failure].
  317. ! !
  318. !PPRepeatingParser class methodsFor: 'instance creation'!
  319. on: aParser min: aNumber
  320. ^self new
  321. parser: aParser;
  322. min: aNumber;
  323. yourself
  324. ! !
  325. Object subclass: #PPFailure
  326. instanceVariableNames: 'position reason'
  327. category: 'Parser'!
  328. !PPFailure methodsFor: 'accessing'!
  329. position
  330. ^position ifNil: [0]
  331. !
  332. position: aNumber
  333. position := aNumber
  334. !
  335. reason
  336. ^reason ifNil: ['']
  337. !
  338. reason: aString
  339. reason := aString
  340. !
  341. reason: aString at: anInteger
  342. self
  343. reason: aString;
  344. position: anInteger
  345. !
  346. accept: aVisitor
  347. aVisitor visitFailure: self
  348. ! !
  349. !PPFailure methodsFor: 'testing'!
  350. isParseFailure
  351. ^true
  352. !
  353. asString
  354. ^reason, ' at ', position asString
  355. ! !
  356. !PPFailure class methodsFor: 'instance creation'!
  357. reason: aString at: anInteger
  358. ^self new
  359. reason: aString at: anInteger;
  360. yourself
  361. ! !
  362. Object subclass: #SmalltalkParser
  363. instanceVariableNames: ''
  364. category: 'Parser'!
  365. !SmalltalkParser methodsFor: 'grammar'!
  366. parser
  367. | method expression separator comment ws identifier keyword className string symbol number literalArray variable reference classReference literal ret methodParser expressionParser keyword unarySelector binarySelector keywordPattern unaryPattern binaryPattern assignment temps blockParamList block expression expressions subexpression statements sequence operand unaryMessage unarySend unaryTail binaryMessage binarySend binaryTail keywordMessage keywordSend keywordPair cascade message jsStatement |
  368. separator := (String cr, String space, String lf, String tab) asChoiceParser.
  369. comment := ('"' asCharacterParser, ('"' asParser not, PPAnyParser new) star, '"' asCharacterParser) flatten.
  370. ws := (separator / comment) star.
  371. identifier := ('a-z' asCharacterParser, 'a-zA-Z0-9' asCharacterParser star) flatten.
  372. keyword := (identifier, ':' asParser) flatten.
  373. className := ('A-Z' asCharacterParser, 'a-zA-Z0-9' asCharacterParser star) flatten.
  374. string := '''' asParser, ('''''' asParser / ('''' asParser not, PPAnyParser new)) star flatten, '''' asParser
  375. ==> [:node | ValueNode new value: ((node at: 2) replace: '''''' with: '''')].
  376. symbol := '#' asParser, 'a-zA-Z0-9' asCharacterParser plus flatten
  377. ==> [:node | ValueNode new value: node second].
  378. number := ('0-9' asCharacterParser plus, ('.' asParser, '0-9' asCharacterParser plus) optional) flatten
  379. ==> [:node | ValueNode new value: node asNumber].
  380. literal := PPDelegateParser new.
  381. literalArray := '#(' asParser, (ws, literal, ws) star, ')' asParser
  382. ==> [:node | ValueNode new value: (Array withAll: (node second collect: [:each | each second value]))].
  383. variable := identifier ==> [:token | VariableNode new value: token].
  384. classReference := className ==> [:token | ClassReferenceNode new value: token].
  385. reference := variable / classReference.
  386. binarySelector := '+*/=><,@%~-' asCharacterParser plus flatten.
  387. unarySelector := identifier.
  388. keywordPattern := (ws, keyword, ws, identifier) plus
  389. ==> [:nodes | Array
  390. with: ((nodes collect: [:each | each at: 2]) join: '')
  391. with: (nodes collect: [:each | each at: 4])].
  392. binaryPattern := ws, binarySelector, ws, identifier
  393. ==> [:node | Array with: node second with: (Array with: node fourth)].
  394. unaryPattern := ws, unarySelector
  395. ==> [:node | Array with: node second with: Array new].
  396. expression := PPDelegateParser new.
  397. expressions := expression, ((ws, '.' asParser, ws, expression) ==> [:node | node fourth]) star
  398. ==> [:node || result |
  399. result := Array with: node first.
  400. node second do: [:each | result add: each].
  401. result].
  402. assignment := reference, ws, ':=' asParser, ws, expression
  403. ==> [:node | AssignmentNode new left: node first; right: (node at: 5)].
  404. ret := '^' asParser, ws, expression, ws, '.' asParser optional
  405. ==> [:node | ReturnNode new
  406. addNode: node third;
  407. yourself].
  408. temps := '|' asParser, (ws, identifier) star, ws, '|' asParser
  409. ==> [:node | node second collect: [:each | each second]].
  410. blockParamList := (':' asParser, identifier, ws) plus, '|' asParser
  411. ==> [:node | node first collect: [:each | each second]].
  412. subexpression := '(' asParser, ws, expression, ws, ')' asParser
  413. ==> [:node | node third].
  414. statements := (ret ==> [:node | Array with: node]) / (expressions, ws, '.' asParser, ws, ret ==> [:node | node first add: (node at: 5); yourself]) / (expressions , '.' asParser optional ==> [:node | node first]).
  415. sequence := temps optional, ws, statements optional, ws
  416. ==> [:node | SequenceNode new
  417. temps: node first;
  418. nodes: node third;
  419. yourself].
  420. block := '[' asParser, ws, blockParamList optional, ws, sequence optional, ws, ']' asParser
  421. ==> [:node |
  422. BlockNode new
  423. parameters: node third;
  424. addNode: (node at: 5) asBlockSequenceNode].
  425. operand := literal / reference / subexpression.
  426. literal parser: number / string / literalArray / symbol / block.
  427. unaryMessage := ws, unarySelector, ':' asParser not
  428. ==> [:node | SendNode new selector: node second].
  429. unaryTail := PPDelegateParser new.
  430. unaryTail parser: (unaryMessage, unaryTail optional
  431. ==> [:node |
  432. node second
  433. ifNil: [node first]
  434. ifNotNil: [node second valueForReceiver: node first]]).
  435. unarySend := operand, unaryTail optional
  436. ==> [:node |
  437. node second
  438. ifNil: [node first]
  439. ifNotNil: [node second valueForReceiver: node first]].
  440. binaryMessage := ws, binarySelector, ws, (unarySend / operand)
  441. ==> [:node |
  442. SendNode new
  443. selector: node second;
  444. arguments: (Array with: node fourth)].
  445. binaryTail := PPDelegateParser new.
  446. binaryTail parser: (binaryMessage, binaryTail optional
  447. ==> [:node |
  448. node second
  449. ifNil: [node first]
  450. ifNotNil: [ node second valueForReceiver: node first]]).
  451. binarySend := unarySend, binaryTail optional
  452. ==> [:node |
  453. node second
  454. ifNil: [node first]
  455. ifNotNil: [node second valueForReceiver: node first]].
  456. keywordPair := keyword, ws, binarySend.
  457. keywordMessage := (ws, keywordPair) plus
  458. ==> [:nodes |
  459. SendNode new
  460. selector: ((nodes collect: [:each | each second first]) join: '');
  461. arguments: (nodes collect: [:each | each second third])].
  462. keywordSend := binarySend, keywordMessage
  463. ==> [:node |
  464. node second valueForReceiver: node first].
  465. message := binaryMessage / unaryMessage / keywordMessage.
  466. cascade := (keywordSend / binarySend), (ws, ';' asParser, message) plus
  467. ==> [:node |
  468. node first cascadeNodeWithMessages:
  469. (node second collect: [:each | each third])].
  470. jsStatement := '{' asParser, ws, string, ws, '}' asParser
  471. ==> [:node | JSStatementNode new
  472. source: node third;
  473. yourself].
  474. expression parser: assignment / cascade / keywordSend / binarySend / jsStatement.
  475. method := (ws, (keywordPattern / binaryPattern / unaryPattern), ws, sequence optional, ws) withSource
  476. ==> [:node |
  477. MethodNode new
  478. selector: node first second first;
  479. arguments: node first second second;
  480. addNode: node first fourth;
  481. source: node second;
  482. yourself].
  483. ^method, PPEOFParser new ==> [:node | node first]
  484. ! !
  485. !SmalltalkParser methodsFor: 'parsing'!
  486. parse: aStream
  487. ^self parser parse: aStream
  488. ! !
  489. !SmalltalkParser class methodsFor: 'instance creation'!
  490. parse: aStream
  491. ^self new
  492. parse: aStream
  493. ! !
  494. Object subclass: #Chunk
  495. instanceVariableNames: 'contents'
  496. category: 'Parser'!
  497. !Chunk methodsFor: 'accessing'!
  498. contents
  499. ^contents ifNil: ['']
  500. !
  501. contents: aString
  502. contents := aString
  503. ! !
  504. !Chunk methodsFor: 'testing'!
  505. isEmptyChunk
  506. ^false
  507. !
  508. isInstructionChunk
  509. ^false
  510. ! !
  511. Chunk subclass: #InstructionChunk
  512. instanceVariableNames: ''
  513. category: 'Parser'!
  514. !InstructionChunk methodsFor: 'testing'!
  515. isInstructionChunk
  516. ^true
  517. ! !
  518. Chunk subclass: #EmptyChunk
  519. instanceVariableNames: ''
  520. category: 'Parser'!
  521. !EmptyChunk methodsFor: 'testing'!
  522. isEmptyChunk
  523. ^true
  524. ! !
  525. Object subclass: #ChunkParser
  526. instanceVariableNames: 'parser separator eof ws chunk emptyChunk instructionChunk'
  527. category: 'Parser'!
  528. !ChunkParser methodsFor: ''!
  529. instructionChunk
  530. ^instructionChunk ifNil: [
  531. instructionChunk := self ws, '!!' asParser, self chunk
  532. ==> [:node | InstructionChunk new contents: node last contents]]
  533. ! !
  534. !ChunkParser methodsFor: 'accessing'!
  535. parser
  536. ^parser ifNil: [
  537. parser := self instructionChunk / self emptyChunk / self chunk / self eof]
  538. !
  539. eof
  540. ^eof ifNil: [eof := self ws, PPEOFParser new ==> [:node | nil]]
  541. !
  542. separator
  543. ^separator ifNil: [separator := (String cr, String space, String lf, String tab) asChoiceParser]
  544. !
  545. ws
  546. ^ws ifNil: [ws := self separator star]
  547. !
  548. chunk
  549. ^chunk ifNil: [chunk := self ws, ('!!!!' asParser / ('!!' asParser not, PPAnyParser new)) plus flatten, '!!' asParser ==> [:node | Chunk new contents: (node second replace: '!!!!' with: '!!')]]
  550. !
  551. emptyChunk
  552. ^emptyChunk ifNil: [emptyChunk := self separator plus, '!!' asParser, self ws ==> [:node | EmptyChunk new]]
  553. ! !
  554. Object subclass: #Importer
  555. instanceVariableNames: 'chunkParser'
  556. category: 'Parser'!
  557. !Importer methodsFor: 'accessing'!
  558. chunkParser
  559. ^chunkParser ifNil: [chunkParser := ChunkParser new parser]
  560. ! !
  561. !Importer methodsFor: 'fileIn'!
  562. import: aStream
  563. aStream atEnd ifFalse: [
  564. | nextChunk |
  565. nextChunk := self chunkParser parse: aStream.
  566. nextChunk ifNotNil: [
  567. nextChunk isInstructionChunk
  568. ifTrue: [(Compiler new loadExpression: nextChunk contents)
  569. scanFrom: aStream]
  570. ifFalse: [Compiler new loadExpression: nextChunk contents].
  571. self import: aStream]]
  572. ! !
  573. Object subclass: #Exporter
  574. instanceVariableNames: ''
  575. category: 'Parser'!
  576. !Exporter methodsFor: 'fileOut'!
  577. exportCategory: aString
  578. | stream |
  579. stream := '' writeStream.
  580. (Smalltalk current classes
  581. select: [:each | each category = aString])
  582. do: [:each | stream nextPutAll: (self export: each)].
  583. self exportCategoryExtensions: aString on: stream.
  584. ^stream contents
  585. !
  586. export: aClass
  587. | stream |
  588. stream := '' writeStream.
  589. self exportDefinitionOf: aClass on: stream.
  590. self exportMethodsOf: aClass on: stream.
  591. self exportMetaDefinitionOf: aClass on: stream.
  592. self exportMethodsOf: aClass class on: stream.
  593. ^stream contents
  594. ! !
  595. !Exporter methodsFor: 'private'!
  596. exportDefinitionOf: aClass on: aStream
  597. aStream
  598. nextPutAll: 'smalltalk.addClass(';
  599. nextPutAll: '''', (self classNameFor: aClass), ''', ';
  600. nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
  601. nextPutAll: ', ['.
  602. aClass instanceVariableNames
  603. do: [:each | aStream nextPutAll: '''', each, '''']
  604. separatedBy: [aStream nextPutAll: ', '].
  605. aStream
  606. nextPutAll: '], ''';
  607. nextPutAll: aClass category, '''';
  608. nextPutAll: ');'.
  609. aClass comment notEmpty ifTrue: [
  610. aStream
  611. lf;
  612. nextPutAll: 'smalltalk.';
  613. nextPutAll: (self classNameFor: aClass);
  614. nextPutAll: '.comment=';
  615. nextPutAll: 'unescape(''', aClass comment escaped, ''')'].
  616. aStream lf
  617. !
  618. exportMetaDefinitionOf: aClass on: aStream
  619. aClass class instanceVariableNames isEmpty ifFalse: [
  620. aStream
  621. nextPutAll: 'smalltalk.', (self classNameFor: aClass class);
  622. nextPutAll: '.iVarNames = ['.
  623. aClass class instanceVariableNames
  624. do: [:each | aStream nextPutAll: '''', each, '''']
  625. separatedBy: [aStream nextPutAll: ','].
  626. aStream nextPutAll: '];', String lf]
  627. !
  628. exportMethodsOf: aClass on: aStream
  629. aClass methodDictionary values do: [:each |
  630. (each category match: '^\*') ifFalse: [
  631. self exportMethod: each of: aClass on: aStream]].
  632. aStream lf
  633. !
  634. classNameFor: aClass
  635. ^aClass isMetaclass
  636. ifTrue: [aClass instanceClass name, '.klass']
  637. ifFalse: [
  638. aClass isNil
  639. ifTrue: ['nil']
  640. ifFalse: [aClass name]]
  641. !
  642. exportMethod: aMethod of: aClass on: aStream
  643. aStream
  644. nextPutAll: 'smalltalk.addMethod(';lf;
  645. nextPutAll: '''', aMethod selector asSelector, ''',';lf;
  646. nextPutAll: 'smalltalk.method({';lf;
  647. nextPutAll: 'selector: ''', aMethod selector, ''',';lf;
  648. nextPutAll: 'category: ''', aMethod category, ''',';lf;
  649. nextPutAll: 'fn: ', aMethod fn compiledSource, ',';lf;
  650. nextPutAll: 'source: unescape(''', aMethod source escaped, '''),';lf;
  651. nextPutAll: 'messageSends: ', aMethod messageSends asJavascript, ',';lf;
  652. nextPutAll: 'referencedClasses: ['.
  653. aMethod referencedClasses
  654. do: [:each | aStream nextPutAll: 'smalltalk.', (self classNameFor: each)]
  655. separatedBy: [aStream nextPutAll: ','].
  656. aStream
  657. nextPutAll: ']';lf;
  658. nextPutAll: '}),';lf;
  659. nextPutAll: 'smalltalk.', (self classNameFor: aClass);
  660. nextPutAll: ');';lf;lf
  661. !
  662. exportCategoryExtensions: aString on: aStream
  663. Smalltalk current classes, (Smalltalk current classes collect: [:each | each class]) do: [:each |
  664. each methodDictionary values do: [:method |
  665. method category = ('*', aString) ifTrue: [
  666. self exportMethod: method of: each on: aStream]]]
  667. ! !
  668. Exporter subclass: #ChunkExporter
  669. instanceVariableNames: ''
  670. category: 'Parser'!
  671. !ChunkExporter methodsFor: 'not yet classified'!
  672. exportDefinitionOf: aClass on: aStream
  673. "Chunk format."
  674. aStream
  675. nextPutAll: (self classNameFor: aClass superclass);
  676. nextPutAll: ' subclass: #', (self classNameFor: aClass); lf;
  677. nextPutAll: ' instanceVariableNames: '''.
  678. aClass instanceVariableNames
  679. do: [:each | aStream nextPutAll: each]
  680. separatedBy: [aStream nextPutAll: ' '].
  681. aStream
  682. nextPutAll: ''''; lf;
  683. nextPutAll: ' category: ''', aClass category, '''!!'; lf.
  684. aClass comment notEmpty ifTrue: [
  685. aStream
  686. nextPutAll: '!!', (self classNameFor: aClass), ' commentStamp!!';lf;
  687. nextPutAll: (self chunkEscape: aClass comment), '!!';lf].
  688. aStream lf
  689. !
  690. exportMethod: aMethod of: aClass on: aStream
  691. aStream
  692. lf; lf; nextPutAll: (self chunkEscape: aMethod source); lf;
  693. nextPutAll: '!!'
  694. !
  695. exportMethodsOf: aClass on: aStream
  696. | methodsByCategory |
  697. methodsByCategory := Dictionary new.
  698. aClass methodDictionary values do: [:m |
  699. (methodsByCategory at: m category ifAbsentPut: [Array new])
  700. add: m].
  701. aClass protocols do: [:category |
  702. aStream
  703. nextPutAll: '!!', (self classNameFor: aClass);
  704. nextPutAll: ' methodsFor: ''', category, '''!!'.
  705. (methodsByCategory at: category) do: [:each |
  706. self exportMethod: each of: aClass on: aStream].
  707. aStream nextPutAll: ' !!'; lf; lf]
  708. !
  709. exportMetaDefinitionOf: aClass on: aStream
  710. aClass class instanceVariableNames isEmpty ifFalse: [
  711. aStream
  712. nextPutAll: (self classNameFor: aClass class);
  713. nextPutAll: ' instanceVariableNames: '''.
  714. aClass class instanceVariableNames
  715. do: [:each | aStream nextPutAll: each]
  716. separatedBy: [aStream nextPutAll: ' '].
  717. aStream
  718. nextPutAll: '''!!'; lf; lf]
  719. !
  720. classNameFor: aClass
  721. ^aClass isMetaclass
  722. ifTrue: [aClass instanceClass name, ' class']
  723. ifFalse: [
  724. aClass isNil
  725. ifTrue: ['nil']
  726. ifFalse: [aClass name]]
  727. !
  728. chunkEscape: aString
  729. "Replace all occurrences of !! with !!!!"
  730. ^aString replace: '!!' with: '!!!!'
  731. ! !