Parser.st 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995
  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, ('>>' asParser / ('>' asParser not, PPAnyParser new)) star flatten, '>' asParser
  471. ==> [:node | JSStatementNode new
  472. source: node second;
  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
  550. ==> [:node | Chunk new contents: (node second replace: '!!!!' with: '!!') trimBoth]]
  551. !
  552. emptyChunk
  553. ^emptyChunk ifNil: [emptyChunk := self separator plus, '!!' asParser, self ws ==> [:node | EmptyChunk new]]
  554. ! !
  555. Object subclass: #Importer
  556. instanceVariableNames: 'chunkParser'
  557. category: 'Parser'!
  558. !Importer methodsFor: 'accessing'!
  559. chunkParser
  560. ^chunkParser ifNil: [chunkParser := ChunkParser new parser]
  561. ! !
  562. !Importer methodsFor: 'fileIn'!
  563. import: aStream
  564. aStream atEnd ifFalse: [
  565. | nextChunk |
  566. nextChunk := self chunkParser parse: aStream.
  567. nextChunk ifNotNil: [
  568. nextChunk isInstructionChunk
  569. ifTrue: [(Compiler new loadExpression: nextChunk contents)
  570. scanFrom: aStream]
  571. ifFalse: [Compiler new loadExpression: nextChunk contents].
  572. self import: aStream]]
  573. ! !
  574. Object subclass: #Exporter
  575. instanceVariableNames: ''
  576. category: 'Parser'!
  577. !Exporter methodsFor: 'fileOut'!
  578. exportCategory: aString
  579. | stream |
  580. stream := '' writeStream.
  581. (Smalltalk current classes
  582. select: [:each | each category = aString])
  583. do: [:each | stream nextPutAll: (self export: each)].
  584. self exportCategoryExtensions: aString on: stream.
  585. ^stream contents
  586. !
  587. export: aClass
  588. | stream |
  589. stream := '' writeStream.
  590. self exportDefinitionOf: aClass on: stream.
  591. self exportMethodsOf: aClass on: stream.
  592. self exportMetaDefinitionOf: aClass on: stream.
  593. self exportMethodsOf: aClass class on: stream.
  594. ^stream contents
  595. ! !
  596. !Exporter methodsFor: 'private'!
  597. exportDefinitionOf: aClass on: aStream
  598. aStream
  599. nextPutAll: 'smalltalk.addClass(';
  600. nextPutAll: '''', (self classNameFor: aClass), ''', ';
  601. nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
  602. nextPutAll: ', ['.
  603. aClass instanceVariableNames
  604. do: [:each | aStream nextPutAll: '''', each, '''']
  605. separatedBy: [aStream nextPutAll: ', '].
  606. aStream
  607. nextPutAll: '], ''';
  608. nextPutAll: aClass category, '''';
  609. nextPutAll: ');'.
  610. aClass comment notEmpty ifTrue: [
  611. aStream
  612. lf;
  613. nextPutAll: 'smalltalk.';
  614. nextPutAll: (self classNameFor: aClass);
  615. nextPutAll: '.comment=';
  616. nextPutAll: 'unescape(''', aClass comment escaped, ''')'].
  617. aStream lf
  618. !
  619. exportMetaDefinitionOf: aClass on: aStream
  620. aClass class instanceVariableNames isEmpty ifFalse: [
  621. aStream
  622. nextPutAll: 'smalltalk.', (self classNameFor: aClass class);
  623. nextPutAll: '.iVarNames = ['.
  624. aClass class instanceVariableNames
  625. do: [:each | aStream nextPutAll: '''', each, '''']
  626. separatedBy: [aStream nextPutAll: ','].
  627. aStream nextPutAll: '];', String lf]
  628. !
  629. exportMethodsOf: aClass on: aStream
  630. aClass methodDictionary values do: [:each |
  631. (each category match: '^\*') ifFalse: [
  632. self exportMethod: each of: aClass on: aStream]].
  633. aStream lf
  634. !
  635. classNameFor: aClass
  636. ^aClass isMetaclass
  637. ifTrue: [aClass instanceClass name, '.klass']
  638. ifFalse: [
  639. aClass isNil
  640. ifTrue: ['nil']
  641. ifFalse: [aClass name]]
  642. !
  643. exportMethod: aMethod of: aClass on: aStream
  644. aStream
  645. nextPutAll: 'smalltalk.addMethod(';lf;
  646. nextPutAll: '''', aMethod selector asSelector, ''',';lf;
  647. nextPutAll: 'smalltalk.method({';lf;
  648. nextPutAll: 'selector: ''', aMethod selector, ''',';lf;
  649. nextPutAll: 'category: ''', aMethod category, ''',';lf;
  650. nextPutAll: 'fn: ', aMethod fn compiledSource, ',';lf;
  651. nextPutAll: 'source: unescape(''', aMethod source escaped, '''),';lf;
  652. nextPutAll: 'messageSends: ', aMethod messageSends asJavascript, ',';lf;
  653. nextPutAll: 'referencedClasses: ['.
  654. aMethod referencedClasses
  655. do: [:each | aStream nextPutAll: 'smalltalk.', (self classNameFor: each)]
  656. separatedBy: [aStream nextPutAll: ','].
  657. aStream
  658. nextPutAll: ']';lf;
  659. nextPutAll: '}),';lf;
  660. nextPutAll: 'smalltalk.', (self classNameFor: aClass);
  661. nextPutAll: ');';lf;lf
  662. !
  663. exportCategoryExtensions: aString on: aStream
  664. Smalltalk current classes, (Smalltalk current classes collect: [:each | each class]) do: [:each |
  665. each methodDictionary values do: [:method |
  666. method category = ('*', aString) ifTrue: [
  667. self exportMethod: method of: each on: aStream]]]
  668. ! !
  669. Exporter subclass: #ChunkExporter
  670. instanceVariableNames: ''
  671. category: 'Parser'!
  672. !ChunkExporter methodsFor: 'not yet classified'!
  673. exportDefinitionOf: aClass on: aStream
  674. "Chunk format."
  675. aStream
  676. nextPutAll: (self classNameFor: aClass superclass);
  677. nextPutAll: ' subclass: #', (self classNameFor: aClass); lf;
  678. nextPutAll: ' instanceVariableNames: '''.
  679. aClass instanceVariableNames
  680. do: [:each | aStream nextPutAll: each]
  681. separatedBy: [aStream nextPutAll: ' '].
  682. aStream
  683. nextPutAll: ''''; lf;
  684. nextPutAll: ' category: ''', aClass category, '''!!'; lf.
  685. aClass comment notEmpty ifTrue: [
  686. aStream
  687. nextPutAll: '!!', (self classNameFor: aClass), ' commentStamp!!';lf;
  688. nextPutAll: (self chunkEscape: aClass comment), '!!';lf].
  689. aStream lf
  690. !
  691. exportMethod: aMethod of: aClass on: aStream
  692. aStream
  693. lf; lf; nextPutAll: (self chunkEscape: aMethod source); lf;
  694. nextPutAll: '!!'
  695. !
  696. exportMethodsOf: aClass on: aStream
  697. aClass protocolsDo: [:category :methods |
  698. (category match: '^\*') ifFalse: [
  699. self
  700. exportMethods: methods
  701. category: category
  702. of: aClass
  703. on: aStream]]
  704. !
  705. exportMetaDefinitionOf: aClass on: aStream
  706. aClass class instanceVariableNames isEmpty ifFalse: [
  707. aStream
  708. nextPutAll: (self classNameFor: aClass class);
  709. nextPutAll: ' instanceVariableNames: '''.
  710. aClass class instanceVariableNames
  711. do: [:each | aStream nextPutAll: each]
  712. separatedBy: [aStream nextPutAll: ' '].
  713. aStream
  714. nextPutAll: '''!!'; lf; lf]
  715. !
  716. classNameFor: aClass
  717. ^aClass isMetaclass
  718. ifTrue: [aClass instanceClass name, ' class']
  719. ifFalse: [
  720. aClass isNil
  721. ifTrue: ['nil']
  722. ifFalse: [aClass name]]
  723. !
  724. chunkEscape: aString
  725. "Replace all occurrences of !! with !!!! and trim at both ends."
  726. ^(aString replace: '!!' with: '!!!!') trimBoth
  727. !
  728. exportCategoryExtensions: aString on: aStream
  729. "We need to override this one too since we need to group
  730. all methods in a given protocol under a leading methodsFor: chunk
  731. for that class."
  732. Smalltalk current classes, (Smalltalk current classes collect: [:each | each class]) do: [:each |
  733. each protocolsDo: [:category :methods |
  734. category = ('*', aString) ifTrue: [
  735. self exportMethods: methods category: category of: each on: aStream]]]
  736. !
  737. exportMethods: methods category: category of: aClass on: aStream
  738. aStream
  739. nextPutAll: '!!', (self classNameFor: aClass);
  740. nextPutAll: ' methodsFor: ''', category, '''!!'.
  741. methods do: [:each |
  742. self exportMethod: each of: aClass on: aStream].
  743. aStream nextPutAll: ' !!'; lf; lf
  744. ! !
  745. Exporter subclass: #StrippedExporter
  746. instanceVariableNames: ''
  747. category: 'Parser'!
  748. !StrippedExporter methodsFor: 'private'!
  749. exportDefinitionOf: aClass on: aStream
  750. aStream
  751. nextPutAll: 'smalltalk.addClass(';
  752. nextPutAll: '''', (self classNameFor: aClass), ''', ';
  753. nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
  754. nextPutAll: ', ['.
  755. aClass instanceVariableNames
  756. do: [:each | aStream nextPutAll: '''', each, '''']
  757. separatedBy: [aStream nextPutAll: ', '].
  758. aStream
  759. nextPutAll: '], ''';
  760. nextPutAll: aClass category, '''';
  761. nextPutAll: ');'.
  762. aStream lf
  763. !
  764. exportMethod: aMethod of: aClass on: aStream
  765. aStream
  766. nextPutAll: 'smalltalk.addMethod(';lf;
  767. nextPutAll: '''', aMethod selector asSelector, ''',';lf;
  768. nextPutAll: 'smalltalk.method({';lf;
  769. nextPutAll: 'selector: ''', aMethod selector, ''',';lf;
  770. nextPutAll: 'fn: ', aMethod fn compiledSource;lf;
  771. nextPutAll: '}),';lf;
  772. nextPutAll: 'smalltalk.', (self classNameFor: aClass);
  773. nextPutAll: ');';lf;lf
  774. ! !