1
0

Parser.st 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994
  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. | r start end node |
  42. start := aStream position.
  43. self log: 'memoizedParse' block: [r := 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. ^r
  53. ! !
  54. !PPParser methodsFor: 'parsing'!
  55. parse: aStream
  56. self subclassResponsibility
  57. !
  58. parseAll: aStream
  59. | result |
  60. result := (PPSequenceParser with: self with: PPEOFParser new) memoizedParse: aStream.
  61. ^result isParseFailure
  62. ifTrue: [self error: (result messageFor: aStream contents)]
  63. ifFalse: [result first]
  64. ! !
  65. PPParser subclass: #PPEOFParser
  66. instanceVariableNames: ''
  67. category: 'Parser'!
  68. !PPEOFParser methodsFor: 'parsing'!
  69. parse: aStream
  70. ^aStream atEnd
  71. ifFalse: [
  72. PPFailure new reason: aStream contents, String lf, '---------------', String lf, 'EOF expected' at: aStream position]
  73. ifTrue: [nil]
  74. ! !
  75. PPParser subclass: #PPAnyParser
  76. instanceVariableNames: ''
  77. category: 'Parser'!
  78. !PPAnyParser methodsFor: 'parsing'!
  79. parse: aStream
  80. ^aStream atEnd
  81. ifTrue: [PPFailure new
  82. reason: 'did not expect EOF' at: aStream position]
  83. ifFalse: [aStream next]
  84. ! !
  85. PPParser subclass: #PPEpsilonParser
  86. instanceVariableNames: ''
  87. category: 'Parser'!
  88. !PPEpsilonParser methodsFor: 'parsing'!
  89. parse: aStream
  90. ^nil
  91. ! !
  92. PPParser subclass: #PPStringParser
  93. instanceVariableNames: 'string'
  94. category: 'Parser'!
  95. !PPStringParser methodsFor: 'accessing'!
  96. string
  97. ^string
  98. !
  99. string: aString
  100. string := aString
  101. ! !
  102. !PPStringParser methodsFor: 'parsing'!
  103. parse: aStream
  104. | position result |
  105. position := aStream position.
  106. result := aStream next: self string size.
  107. ^result = self string
  108. ifTrue: [result]
  109. ifFalse: [
  110. aStream position: position.
  111. PPFailure new reason: 'Expected ', self string, ' but got ', (result at: position) printString; yourself]
  112. ! !
  113. PPParser subclass: #PPCharacterParser
  114. instanceVariableNames: 'regexp'
  115. category: 'Parser'!
  116. !PPCharacterParser methodsFor: 'accessing'!
  117. string: aString
  118. regexp := RegularExpression fromString: '[', aString, ']'
  119. ! !
  120. !PPCharacterParser methodsFor: 'parsing'!
  121. parse: aStream
  122. ^(aStream peek notNil and: [self match: aStream peek])
  123. ifTrue: [aStream next]
  124. ifFalse: [PPFailure new reason: 'Could not match' at: aStream position]
  125. ! !
  126. !PPCharacterParser methodsFor: 'private'!
  127. match: aString
  128. ^aString match: regexp
  129. ! !
  130. PPParser subclass: #PPListParser
  131. instanceVariableNames: 'parsers'
  132. category: 'Parser'!
  133. !PPListParser methodsFor: 'accessing'!
  134. parsers
  135. ^parsers ifNil: [#()]
  136. !
  137. parsers: aCollection
  138. parsers := aCollection
  139. ! !
  140. !PPListParser methodsFor: 'copying'!
  141. copyWith: aParser
  142. ^self class withAll: (self parsers copyWith: aParser)
  143. ! !
  144. !PPListParser class methodsFor: 'instance creation'!
  145. withAll: aCollection
  146. ^self new
  147. parsers: aCollection;
  148. yourself
  149. !
  150. with: aParser with: anotherParser
  151. ^self withAll: (Array with: aParser with: anotherParser)
  152. ! !
  153. PPListParser subclass: #PPSequenceParser
  154. instanceVariableNames: ''
  155. category: 'Parser'!
  156. !PPSequenceParser methodsFor: 'copying'!
  157. , aRule
  158. ^self copyWith: aRule
  159. ! !
  160. !PPSequenceParser methodsFor: 'parsing'!
  161. parse: aStream
  162. | start elements element |
  163. start := aStream position.
  164. elements := #().
  165. self parsers
  166. detect: [:each |
  167. element := each memoizedParse: aStream.
  168. elements add: element.
  169. element isParseFailure]
  170. ifNone: [].
  171. ^element isParseFailure
  172. ifFalse: [elements]
  173. ifTrue: [aStream position: start. element]
  174. ! !
  175. PPListParser subclass: #PPChoiceParser
  176. instanceVariableNames: ''
  177. category: 'Parser'!
  178. !PPChoiceParser methodsFor: 'copying'!
  179. / aRule
  180. ^self copyWith: aRule
  181. ! !
  182. !PPChoiceParser methodsFor: 'parsing'!
  183. parse: aStream
  184. | result |
  185. self parsers
  186. detect: [:each |
  187. result := each memoizedParse: aStream.
  188. result isParseFailure not]
  189. ifNone: [].
  190. ^result
  191. ! !
  192. PPParser subclass: #PPDelegateParser
  193. instanceVariableNames: 'parser'
  194. category: 'Parser'!
  195. !PPDelegateParser methodsFor: 'accessing'!
  196. parser
  197. ^parser
  198. !
  199. parser: aParser
  200. parser := aParser
  201. ! !
  202. !PPDelegateParser methodsFor: 'parsing'!
  203. parse: aStream
  204. ^self parser memoizedParse: aStream
  205. ! !
  206. !PPDelegateParser class methodsFor: 'instance creation'!
  207. on: aParser
  208. ^self new
  209. parser: aParser;
  210. yourself
  211. ! !
  212. PPDelegateParser subclass: #PPAndParser
  213. instanceVariableNames: ''
  214. category: 'Parser'!
  215. !PPAndParser methodsFor: 'parsing'!
  216. parse: aStream
  217. ^self basicParse: aStream
  218. !
  219. basicParse: aStream
  220. | element position |
  221. position := aStream position.
  222. element := self parser memoizedParse: aStream.
  223. aStream position: position.
  224. ^element
  225. ! !
  226. PPAndParser subclass: #PPNotParser
  227. instanceVariableNames: ''
  228. category: 'Parser'!
  229. !PPNotParser methodsFor: 'parsing'!
  230. parse: aStream
  231. | element |
  232. element := self basicParse: aStream.
  233. ^element isParseFailure
  234. ifTrue: [nil]
  235. ifFalse: [PPFailure reason: element at: aStream position]
  236. ! !
  237. PPDelegateParser subclass: #PPActionParser
  238. instanceVariableNames: 'block'
  239. category: 'Parser'!
  240. !PPActionParser methodsFor: 'accessing'!
  241. block
  242. ^block
  243. !
  244. block: aBlock
  245. block := aBlock
  246. ! !
  247. !PPActionParser methodsFor: 'parsing'!
  248. parse: aStream
  249. | element |
  250. element := self parser memoizedParse: aStream.
  251. ^element isParseFailure
  252. ifFalse: [self block value: element]
  253. ifTrue: [element]
  254. ! !
  255. !PPActionParser class methodsFor: 'instance creation'!
  256. on: aParser block: aBlock
  257. ^self new
  258. parser: aParser;
  259. block: aBlock;
  260. yourself
  261. ! !
  262. PPDelegateParser subclass: #PPFlattenParser
  263. instanceVariableNames: ''
  264. category: 'Parser'!
  265. !PPFlattenParser methodsFor: 'parsing'!
  266. parse: aStream
  267. | start element stop |
  268. start := aStream position.
  269. element := self parser memoizedParse: aStream.
  270. ^element isParseFailure
  271. ifTrue: [element]
  272. ifFalse: [aStream collection
  273. copyFrom: start + 1
  274. to: aStream position]
  275. ! !
  276. PPDelegateParser subclass: #PPSourceParser
  277. instanceVariableNames: ''
  278. category: 'Parser'!
  279. !PPSourceParser methodsFor: 'parsing'!
  280. parse: aStream
  281. | start element stop result |
  282. start := aStream position.
  283. element := self parser memoizedParse: aStream.
  284. ^element isParseFailure
  285. ifTrue: [element]
  286. ifFalse: [result := aStream collection copyFrom: start + 1 to: aStream position.
  287. Array with: element with: result].
  288. ! !
  289. PPDelegateParser subclass: #PPRepeatingParser
  290. instanceVariableNames: 'min'
  291. category: 'Parser'!
  292. !PPRepeatingParser methodsFor: 'accessing'!
  293. min
  294. ^min
  295. !
  296. min: aNumber
  297. min := aNumber
  298. ! !
  299. !PPRepeatingParser methodsFor: 'parsing'!
  300. parse: aStream
  301. | start element elements failure |
  302. start := aStream position.
  303. elements := Array new.
  304. [(elements size < self min) and: [failure isNil]] whileTrue: [
  305. element := self parser memoizedParse: aStream.
  306. element isParseFailure
  307. ifFalse: [elements addLast: element]
  308. ifTrue: [aStream position: start.
  309. failure := element]].
  310. ^failure ifNil: [
  311. [failure isNil] whileTrue: [
  312. element := self parser memoizedParse: aStream.
  313. element isParseFailure
  314. ifTrue: [failure := element]
  315. ifFalse: [elements addLast: element]].
  316. elements]
  317. ifNotNil: [failure].
  318. ! !
  319. !PPRepeatingParser class methodsFor: 'instance creation'!
  320. on: aParser min: aNumber
  321. ^self new
  322. parser: aParser;
  323. min: aNumber;
  324. yourself
  325. ! !
  326. Object subclass: #PPFailure
  327. instanceVariableNames: 'position reason'
  328. category: 'Parser'!
  329. !PPFailure methodsFor: 'accessing'!
  330. position
  331. ^position ifNil: [0]
  332. !
  333. position: aNumber
  334. position := aNumber
  335. !
  336. reason
  337. ^reason ifNil: ['']
  338. !
  339. reason: aString
  340. reason := aString
  341. !
  342. reason: aString at: anInteger
  343. self
  344. reason: aString;
  345. position: anInteger
  346. !
  347. accept: aVisitor
  348. aVisitor visitFailure: self
  349. ! !
  350. !PPFailure methodsFor: 'testing'!
  351. isParseFailure
  352. ^true
  353. !
  354. asString
  355. ^reason, ' at ', position asString
  356. ! !
  357. !PPFailure class methodsFor: 'instance creation'!
  358. reason: aString at: anInteger
  359. ^self new
  360. reason: aString at: anInteger;
  361. yourself
  362. ! !
  363. Object subclass: #SmalltalkParser
  364. instanceVariableNames: ''
  365. category: 'Parser'!
  366. !SmalltalkParser methodsFor: 'grammar'!
  367. parser
  368. | 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 |
  369. separator := (String cr, String space, String lf, String tab) asChoiceParser.
  370. comment := ('"' asCharacterParser, ('"' asParser not, PPAnyParser new) star, '"' asCharacterParser) flatten.
  371. ws := (separator / comment) star.
  372. identifier := ('a-z' asCharacterParser, 'a-zA-Z0-9' asCharacterParser star) flatten.
  373. keyword := (identifier, ':' asParser) flatten.
  374. className := ('A-Z' asCharacterParser, 'a-zA-Z0-9' asCharacterParser star) flatten.
  375. string := '''' asParser, ('''''' asParser / ('''' asParser not, PPAnyParser new)) star flatten, '''' asParser
  376. ==> [:node | ValueNode new value: ((node at: 2) replace: '''''' with: '''')].
  377. symbol := '#' asParser, 'a-zA-Z0-9' asCharacterParser plus flatten
  378. ==> [:node | ValueNode new value: node second].
  379. number := ('0-9' asCharacterParser plus, ('.' asParser, '0-9' asCharacterParser plus) optional) flatten
  380. ==> [:node | ValueNode new value: node asNumber].
  381. literal := PPDelegateParser new.
  382. literalArray := '#(' asParser, (ws, literal, ws) star, ')' asParser
  383. ==> [:node | ValueNode new value: (Array withAll: (node second collect: [:each | each second value]))].
  384. variable := identifier ==> [:token | VariableNode new value: token].
  385. classReference := className ==> [:token | ClassReferenceNode new value: token].
  386. reference := variable / classReference.
  387. binarySelector := '+*/=><,@%~|&-' asCharacterParser plus flatten.
  388. unarySelector := identifier.
  389. keywordPattern := (ws, keyword, ws, identifier) plus
  390. ==> [:nodes | Array
  391. with: ((nodes collect: [:each | each at: 2]) join: '')
  392. with: (nodes collect: [:each | each at: 4])].
  393. binaryPattern := ws, binarySelector, ws, identifier
  394. ==> [:node | Array with: node second with: (Array with: node fourth)].
  395. unaryPattern := ws, unarySelector
  396. ==> [:node | Array with: node second with: Array new].
  397. expression := PPDelegateParser new.
  398. expressions := expression, ((ws, '.' asParser, ws, expression) ==> [:node | node fourth]) star
  399. ==> [:node || result |
  400. result := Array with: node first.
  401. node second do: [:each | result add: each].
  402. result].
  403. assignment := reference, ws, ':=' asParser, ws, expression
  404. ==> [:node | AssignmentNode new left: node first; right: (node at: 5)].
  405. ret := '^' asParser, ws, expression, ws, '.' asParser optional
  406. ==> [:node | ReturnNode new
  407. addNode: node third;
  408. yourself].
  409. temps := '|' asParser, (ws, identifier) star, ws, '|' asParser
  410. ==> [:node | node second collect: [:each | each second]].
  411. blockParamList := (':' asParser, identifier, ws) plus, '|' asParser
  412. ==> [:node | node first collect: [:each | each second]].
  413. subexpression := '(' asParser, ws, expression, ws, ')' asParser
  414. ==> [:node | node third].
  415. 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]).
  416. sequence := temps optional, ws, statements optional, ws
  417. ==> [:node | SequenceNode new
  418. temps: node first;
  419. nodes: node third;
  420. yourself].
  421. block := '[' asParser, ws, blockParamList optional, ws, sequence optional, ws, ']' asParser
  422. ==> [:node |
  423. BlockNode new
  424. parameters: node third;
  425. addNode: (node at: 5) asBlockSequenceNode].
  426. operand := literal / reference / subexpression.
  427. literal parser: number / string / literalArray / symbol / block.
  428. unaryMessage := ws, unarySelector, ':' asParser not
  429. ==> [:node | SendNode new selector: node second].
  430. unaryTail := PPDelegateParser new.
  431. unaryTail parser: (unaryMessage, unaryTail optional
  432. ==> [:node |
  433. node second
  434. ifNil: [node first]
  435. ifNotNil: [node second valueForReceiver: node first]]).
  436. unarySend := operand, unaryTail optional
  437. ==> [:node |
  438. node second
  439. ifNil: [node first]
  440. ifNotNil: [node second valueForReceiver: node first]].
  441. binaryMessage := ws, binarySelector, ws, (unarySend / operand)
  442. ==> [:node |
  443. SendNode new
  444. selector: node second;
  445. arguments: (Array with: node fourth)].
  446. binaryTail := PPDelegateParser new.
  447. binaryTail parser: (binaryMessage, binaryTail optional
  448. ==> [:node |
  449. node second
  450. ifNil: [node first]
  451. ifNotNil: [ node second valueForReceiver: node first]]).
  452. binarySend := unarySend, binaryTail optional
  453. ==> [:node |
  454. node second
  455. ifNil: [node first]
  456. ifNotNil: [node second valueForReceiver: node first]].
  457. keywordPair := keyword, ws, binarySend.
  458. keywordMessage := (ws, keywordPair) plus
  459. ==> [:nodes |
  460. SendNode new
  461. selector: ((nodes collect: [:each | each second first]) join: '');
  462. arguments: (nodes collect: [:each | each second third])].
  463. keywordSend := binarySend, keywordMessage
  464. ==> [:node |
  465. node second valueForReceiver: node first].
  466. message := binaryMessage / unaryMessage / keywordMessage.
  467. cascade := (keywordSend / binarySend), (ws, ';' asParser, message) plus
  468. ==> [:node |
  469. node first cascadeNodeWithMessages:
  470. (node second collect: [:each | each third])].
  471. jsStatement := '<' asParser, ('>>' asParser / ('>' asParser not, PPAnyParser new)) star flatten, '>' asParser
  472. ==> [:node | JSStatementNode new
  473. source: node second;
  474. yourself].
  475. expression parser: assignment / cascade / keywordSend / binarySend / jsStatement.
  476. method := (ws, (keywordPattern / binaryPattern / unaryPattern), ws, sequence optional, ws) withSource
  477. ==> [:node |
  478. MethodNode new
  479. selector: node first second first;
  480. arguments: node first second second;
  481. addNode: node first fourth;
  482. source: node second;
  483. yourself].
  484. ^method, PPEOFParser new ==> [:node | node first]
  485. ! !
  486. !SmalltalkParser methodsFor: 'parsing'!
  487. parse: aStream
  488. ^self parser parse: aStream
  489. ! !
  490. !SmalltalkParser class methodsFor: 'instance creation'!
  491. parse: aStream
  492. ^self new
  493. parse: aStream
  494. ! !
  495. Object subclass: #Chunk
  496. instanceVariableNames: 'contents'
  497. category: 'Parser'!
  498. !Chunk methodsFor: 'accessing'!
  499. contents
  500. ^contents ifNil: ['']
  501. !
  502. contents: aString
  503. contents := aString
  504. ! !
  505. !Chunk methodsFor: 'testing'!
  506. isEmptyChunk
  507. ^false
  508. !
  509. isInstructionChunk
  510. ^false
  511. ! !
  512. Chunk subclass: #InstructionChunk
  513. instanceVariableNames: ''
  514. category: 'Parser'!
  515. !InstructionChunk methodsFor: 'testing'!
  516. isInstructionChunk
  517. ^true
  518. ! !
  519. Chunk subclass: #EmptyChunk
  520. instanceVariableNames: ''
  521. category: 'Parser'!
  522. !EmptyChunk methodsFor: 'testing'!
  523. isEmptyChunk
  524. ^true
  525. ! !
  526. Object subclass: #ChunkParser
  527. instanceVariableNames: 'parser separator eof ws chunk emptyChunk instructionChunk'
  528. category: 'Parser'!
  529. !ChunkParser methodsFor: ''!
  530. instructionChunk
  531. ^instructionChunk ifNil: [
  532. instructionChunk := self ws, '!!' asParser, self chunk
  533. ==> [:node | InstructionChunk new contents: node last contents]]
  534. ! !
  535. !ChunkParser methodsFor: 'accessing'!
  536. parser
  537. ^parser ifNil: [
  538. parser := self instructionChunk / self emptyChunk / self chunk / self eof]
  539. !
  540. eof
  541. ^eof ifNil: [eof := self ws, PPEOFParser new ==> [:node | nil]]
  542. !
  543. separator
  544. ^separator ifNil: [separator := (String cr, String space, String lf, String tab) asChoiceParser]
  545. !
  546. ws
  547. ^ws ifNil: [ws := self separator star]
  548. !
  549. chunk
  550. ^chunk ifNil: [chunk := self ws, ('!!!!' asParser / ('!!' asParser not, PPAnyParser new)) plus flatten, '!!' asParser
  551. ==> [:node | Chunk new contents: (node second replace: '!!!!' with: '!!') trimBoth]]
  552. !
  553. emptyChunk
  554. ^emptyChunk ifNil: [emptyChunk := self separator plus, '!!' asParser, self ws ==> [:node | EmptyChunk new]]
  555. ! !
  556. Object subclass: #Importer
  557. instanceVariableNames: 'chunkParser'
  558. category: 'Parser'!
  559. !Importer methodsFor: 'accessing'!
  560. chunkParser
  561. ^chunkParser ifNil: [chunkParser := ChunkParser new parser]
  562. ! !
  563. !Importer methodsFor: 'fileIn'!
  564. import: aStream
  565. | nextChunk result |
  566. [aStream atEnd] whileFalse: [
  567. nextChunk := self chunkParser parse: aStream.
  568. nextChunk ifNil: [^self].
  569. result := Compiler new loadExpression: nextChunk contents.
  570. nextChunk isInstructionChunk
  571. ifTrue: [result scanFrom: 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. aClass protocolsDo: [:category :methods |
  697. (category match: '^\*') ifFalse: [
  698. self
  699. exportMethods: methods
  700. category: category
  701. of: aClass
  702. on: aStream]]
  703. !
  704. exportMetaDefinitionOf: aClass on: aStream
  705. aClass class instanceVariableNames isEmpty ifFalse: [
  706. aStream
  707. nextPutAll: (self classNameFor: aClass class);
  708. nextPutAll: ' instanceVariableNames: '''.
  709. aClass class instanceVariableNames
  710. do: [:each | aStream nextPutAll: each]
  711. separatedBy: [aStream nextPutAll: ' '].
  712. aStream
  713. nextPutAll: '''!!'; lf; lf]
  714. !
  715. classNameFor: aClass
  716. ^aClass isMetaclass
  717. ifTrue: [aClass instanceClass name, ' class']
  718. ifFalse: [
  719. aClass isNil
  720. ifTrue: ['nil']
  721. ifFalse: [aClass name]]
  722. !
  723. chunkEscape: aString
  724. "Replace all occurrences of !! with !!!! and trim at both ends."
  725. ^(aString replace: '!!' with: '!!!!') trimBoth
  726. !
  727. exportCategoryExtensions: aString on: aStream
  728. "We need to override this one too since we need to group
  729. all methods in a given protocol under a leading methodsFor: chunk
  730. for that class."
  731. Smalltalk current classes, (Smalltalk current classes collect: [:each | each class]) do: [:each |
  732. each protocolsDo: [:category :methods |
  733. category = ('*', aString) ifTrue: [
  734. self exportMethods: methods category: category of: each on: aStream]]]
  735. !
  736. exportMethods: methods category: category of: aClass on: aStream
  737. aStream
  738. nextPutAll: '!!', (self classNameFor: aClass);
  739. nextPutAll: ' methodsFor: ''', category, '''!!'.
  740. methods do: [:each |
  741. self exportMethod: each of: aClass on: aStream].
  742. aStream nextPutAll: ' !!'; lf; lf
  743. ! !
  744. Exporter subclass: #StrippedExporter
  745. instanceVariableNames: ''
  746. category: 'Parser'!
  747. !StrippedExporter methodsFor: 'private'!
  748. exportDefinitionOf: aClass on: aStream
  749. aStream
  750. nextPutAll: 'smalltalk.addClass(';
  751. nextPutAll: '''', (self classNameFor: aClass), ''', ';
  752. nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
  753. nextPutAll: ', ['.
  754. aClass instanceVariableNames
  755. do: [:each | aStream nextPutAll: '''', each, '''']
  756. separatedBy: [aStream nextPutAll: ', '].
  757. aStream
  758. nextPutAll: '], ''';
  759. nextPutAll: aClass category, '''';
  760. nextPutAll: ');'.
  761. aStream lf
  762. !
  763. exportMethod: aMethod of: aClass on: aStream
  764. aStream
  765. nextPutAll: 'smalltalk.addMethod(';lf;
  766. nextPutAll: '''', aMethod selector asSelector, ''',';lf;
  767. nextPutAll: 'smalltalk.method({';lf;
  768. nextPutAll: 'selector: ''', aMethod selector, ''',';lf;
  769. nextPutAll: 'fn: ', aMethod fn compiledSource;lf;
  770. nextPutAll: '}),';lf;
  771. nextPutAll: 'smalltalk.', (self classNameFor: aClass);
  772. nextPutAll: ');';lf;lf
  773. ! !