1"====================================================================== 2| 3| Smalltalk syntax conversion tool 4| 5| 6 ======================================================================" 7 8 9"====================================================================== 10| 11| Copyright 2007, 2008, 2009 Free Software Foundation, Inc. 12| Written by Daniele Sciascia. 13| 14| This file is part of the GNU Smalltalk class library. 15| 16| The GNU Smalltalk class library is free software; you can redistribute it 17| and/or modify it under the terms of the GNU Lesser General Public License 18| as published by the Free Software Foundation; either version 2.1, or (at 19| your option) any later version. 20| 21| The GNU Smalltalk class library is distributed in the hope that it will be 22| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of 23| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser 24| General Public License for more details. 25| 26| You should have received a copy of the GNU Lesser General Public License 27| along with the GNU Smalltalk class library; see the file COPYING.LIB. 28| If not, write to the Free Software Foundation, 59 Temple Place - Suite 29| 330, Boston, MA 02110-1301, USA. 30| 31 ======================================================================" 32 33PackageLoader fileInPackage: #Parser. 34 35STInST.OldSyntaxExporter class extend [ 36 emitEval: aBlock to: aStream for: namespace [ 37 namespace isNil 38 ifFalse: [ aStream nextPutAll: 'Namespace current: '; 39 store: namespace; nextPut: $!; nl ]. 40 41 aBlock value. 42 aStream nextPut: $!; nl; nl. 43 ] 44] 45 46STInST.SqueakSyntaxExporter class extend [ 47 emitEval: aBlock to: aStream for: namespace [ 48 aBlock value. 49 aStream nextPut: $!; nl; nl. 50 ] 51] 52 53STInST.NewSyntaxExporter class extend [ 54 emitEval: aBlock to: aStream for: namespace [ 55 namespace isNil 56 ifTrue: [ aStream nextPutAll: 'Eval' ] 57 ifFalse: [ aStream nextPutAll: 'Namespace current: '; 58 store: namespace ]. 59 60 aStream nextPutAll: ' ['. 61 aBlock value. 62 aStream nl; nextPut: $]; nl; nl. 63 ] 64] 65 66 67Object subclass: EmittedEntity [ 68 emitTo: aStream filteredBy: aBlock [ 69 self subclassResponsibility 70 ] 71] 72 73EmittedEntity subclass: EmittedComments [ 74 | comments | 75 EmittedComments class >> comments: aCollection source: aString [ 76 ^self new comments: (aCollection collect: [ :c | 77 aString copyFrom: c first to: c last ]) 78 ] 79 80 emitTo: outStream filteredBy: aBlock [ 81 comments do: [ :c | 82 STInST.FileOutExporter defaultExporter fileOutComment: c to: outStream. 83 outStream nl; nl] 84 ] 85 86 comments: anArray [ 87 comments := anArray 88 ] 89] 90 91EmittedEntity subclass: EmittedClass [ 92 | class methodsToEmit classMethodsToEmit isComplete | 93 94 <comment: 'This class is responsible for emitting a class 95 by using a FormattingExporter.'> 96 97 EmittedClass class >> forClass: aClass [ 98 (aClass superclass notNil and: [ 99 aClass superclass isDefined not ]) ifTrue: [ 100 Warning signal: 101 ('superclass %1 is undefined' % {aClass superclass}) ]. 102 ^super new initializeWithClass: aClass complete: true 103 ] 104 105 EmittedClass class >> forExtension: aClass [ 106 aClass isDefined ifFalse: [ 107 Warning signal: 108 ('extensions for undefined class %1' % {aClass}) ]. 109 ^super new initializeWithClass: aClass complete: false 110 ] 111 112 initializeWithClass: aClass complete: aBoolean [ 113 class := aClass. 114 methodsToEmit := STInST.OrderedSet new. 115 classMethodsToEmit := STInST.OrderedSet new. 116 isComplete := aBoolean 117 ] 118 119 forClass [ 120 ^class 121 ] 122 123 addMethod: aMethod [ 124 methodsToEmit add: aMethod selector asSymbol. 125 ] 126 127 addClassMethod: aMethod [ 128 classMethodsToEmit add: aMethod selector asSymbol. 129 ] 130 131 emitTo: aStream filteredBy: aBlock [ 132 (aBlock value: class) 133 ifFalse: [ 134 Notification signal: ('Skipping %1' % {class}). 135 ^self ]. 136 137 Notification signal: ('Converting %1...' % {class}). 138 (STInST.FileOutExporter defaultExporter on: class to: aStream) 139 completeFileOut: isComplete; 140 fileOutSelectors: methodsToEmit classSelectors: classMethodsToEmit. 141 ] 142] 143 144EmittedEntity subclass: EmittedEval [ 145 | statements comments namespace | 146 147 <comment: 'This class is responsible for emitting a set of 148 statements that should be inside an Eval declaration.'> 149 150 EmittedEval class >> new [ 151 ^super new initialize 152 ] 153 154 initialize [ 155 statements := OrderedCollection new 156 ] 157 158 namespace [ 159 ^namespace 160 ] 161 162 namespace: aNamespace [ 163 namespace := aNamespace 164 ] 165 166 addStatement: aStatement [ 167 statements add: aStatement 168 ] 169 170 emitTo: aStream filteredBy: aBlock [ 171 statements isEmpty ifTrue: [ ^self ]. 172 STInST.FileOutExporter defaultExporter 173 emitEval: [ 174 | formatter | 175 formatter := STInST.RBFormatter new. 176 formatter indent: 1 while: [ 177 formatter indent. 178 aStream nextPutAll: (formatter formatAll: statements) ]] 179 to: aStream 180 for: namespace. 181 ] 182] 183 184 185 186STInST.STClassLoader subclass: SyntaxConverter [ 187 | stuffToEmit classesToEmit createdNamespaces filter outStream rewriter | 188 189 <comment: 'A class loader that creates a set of "EmittedEntity" 190 based on the contents of the given file being loaded. 191 When the contents of the file are loaded, the responsibilty of 192 emitting code using the new syntax belongs to those various 193 entities that have been constructed.'> 194 195 196 SyntaxConverter class >> convertSqueakStream: in to: out [ 197 <category: 'instance creation'> 198 ^self convertStream: in with: STInST.SqueakFileInParser to: out 199 ] 200 201 SyntaxConverter class >> convertSIFStream: in to: out [ 202 <category: 'instance creation'> 203 ^self convertStream: in with: STInST.SIFFileInParser to: out 204 ] 205 206 SyntaxConverter class >> convertStream: in to: out [ 207 <category: 'instance creation'> 208 ^self convertStream: in with: STInST.STFileInParser to: out 209 ] 210 211 SyntaxConverter class >> convertStream: in with: aParserClass to: out [ 212 <category: 'instance creation'> 213 ^self new convertStream: in with: aParserClass to: out 214 ] 215 216 initialize [ 217 <category: 'initialization'> 218 super initialize. 219 filter := [ :class | [true] ]. 220 stuffToEmit := OrderedSet new. 221 classesToEmit := Dictionary new. 222 createdNamespaces := OrderedSet new. 223 ] 224 225 convertStream: in with: aParserClass to: out onError: aBlock [ 226 <category: 'operation'> 227 self 228 outStream: out; 229 parseSmalltalkStream: in with: aParserClass onError: aBlock; 230 doEmitStuff. 231 ] 232 233 convertStream: in with: aParserClass to: out [ 234 <category: 'operation'> 235 self 236 outStream: out; 237 parseSmalltalkStream: in with: aParserClass; 238 doEmitStuff. 239 ] 240 241 filter: aBlock [ 242 <category: 'accessing'> 243 filter := aBlock. 244 ] 245 246 outStream: out [ 247 <category: 'accessing'> 248 outStream := out. 249 ] 250 251 rewrite: node [ 252 ^rewriter isNil 253 ifTrue: [ node ] 254 ifFalse: [ rewriter executeTree: node; tree ]. 255 ] 256 257 evaluate: node [ 258 <category: 'overrides'> 259 260 | rewritten | 261 rewritten := self rewrite: node. 262 node comments isEmpty ifFalse: [ 263 stuffToEmit add: (EmittedComments comments: node comments source: node source) ]. 264 265 ^super evaluate: rewritten 266 ] 267 268 addRule: searchString parser: aParserClass [ 269 | tree rule | 270 tree := aParserClass parseRewriteExpression: searchString. 271 tree isMessage ifFalse: [ self error: 'expected ->' ]. 272 tree selector = #-> ifFalse: [ self error: 'expected ->' ]. 273 rule := RBStringReplaceRule 274 searchForTree: tree receiver 275 replaceWith: tree arguments first. 276 277 rewriter isNil ifTrue: [ rewriter := ParseTreeRewriter new ]. 278 rewriter addRule: rule 279 ] 280 281 compile: node [ 282 <category: 'collecting entities'> 283 284 | rewritten method | 285 286 rewritten := self rewrite: node. 287 method := self defineMethod: rewritten. 288 (classesToEmit includesKey: currentClass asClass) 289 ifTrue: [ self addMethod: method toLoadedClass: currentClass ] 290 ifFalse: [ self addMethod: method toExtensionClass: currentClass ]. 291 ^method 292 ] 293 294 lastEval [ 295 <category: 'collecting entities'> 296 297 | lastIsEval evalNamespace | 298 299 evalNamespace := currentNamespace = self defaultNamespace 300 ifTrue: [ nil ] 301 ifFalse: [ currentNamespace ]. 302 303 lastIsEval := stuffToEmit notEmpty 304 and: [ (stuffToEmit last isKindOf: EmittedEval) 305 and: [ stuffToEmit last namespace = evalNamespace ]]. 306 307 ^lastIsEval 308 ifTrue: [ stuffToEmit last ] 309 ifFalse: [ stuffToEmit add: (EmittedEval new namespace: evalNamespace) ] 310 ] 311 312 createNamespaces [ 313 createdNamespaces do: [ :each || stmt | 314 stmt := RBMessageNode 315 receiver: (RBVariableNode named: (each superspace nameIn: self currentNamespace)) 316 selector: #addSubspace: 317 arguments: { RBLiteralNode value: each name asSymbol }. 318 self lastEval addStatement: stmt 319 ]. 320 createdNamespaces := OrderedSet new 321 ] 322 323 unknown: node [ 324 <category: 'collecting entities'> 325 326 self createNamespaces. 327 self lastEval addStatement: node. 328 ^false 329 ] 330 331 doSubclass: receiver selector: selector arguments: argumentNodes [ 332 <category: 'evaluating statements'> 333 334 | class emittedClass | 335 336 createdNamespaces remove: self currentNamespace ifAbsent: [ ]. 337 self createNamespaces. 338 339 class := super defineSubclass: receiver 340 selector: selector 341 arguments: argumentNodes. 342 343 Notification signal: ('Parsing %1' % {class}). 344 emittedClass := EmittedClass forClass: class. 345 346 classesToEmit at: class put: emittedClass. 347 stuffToEmit add: emittedClass. 348 349 ^false 350 ] 351 352 doAddNamespace: receiver selector: selector arguments: argumentNodes [ 353 | ns | 354 super doAddNamespace: receiver selector: selector arguments: argumentNodes. 355 356 ns := (self resolveNamespace: receiver) at: argumentNodes first value. 357 createdNamespaces add: ns. 358 ^false 359 ] 360 361 doEmitStuff [ 362 <category: 'emitting'> 363 364 stuffToEmit 365 do: [ :each | each emitTo: outStream filteredBy: filter ] 366 separatedBy: [ outStream nl; nextPut: 12 asCharacter; nl ]. 367 ] 368 369 addMethod: aMethod toLoadedClass: aClass [ 370 <category: 'collecting entities'> 371 372 (aClass isMetaclass) 373 ifTrue: [ (classesToEmit at: currentClass asClass) addClassMethod: aMethod ] 374 ifFalse: [ (classesToEmit at: currentClass) addMethod: aMethod ] 375 ] 376 377 addMethod: aMethod toExtensionClass: aClass [ 378 <category: 'collecting entities'> 379 380 ((stuffToEmit size > 0) 381 and: [ (stuffToEmit last isKindOf: EmittedClass) and: [ stuffToEmit last forClass = aClass ] ]) 382 ifTrue: [ stuffToEmit last addMethod: aMethod ] 383 ifFalse: [ stuffToEmit add: ((EmittedClass forExtension: currentClass) addMethod: aMethod) ] 384 ] 385] 386 387 388String extend [ 389 asFilterOn: aBlock through: valueBlock [ 390 | regex | 391 self first = $+ ifTrue: [ 392 regex := self allButFirst asRegex. 393 ^[ :obj | (aBlock value: obj) 394 or: [ (valueBlock value: obj) ~ regex ] ] ]. 395 396 self first = $- ifTrue: [ 397 regex := self allButFirst asRegex. 398 ^[ :obj | (aBlock value: obj) 399 and: [ ((valueBlock value: obj) ~ regex) not ] ] ]. 400 401 regex := self asRegex. 402 ^[ :obj | (aBlock value: obj) and: [ (valueBlock value: obj) ~ regex ] ] 403 ] 404] 405 406 407Eval [ 408 | helpString inFile outFile quiet verbose converter filter parser 409 args inFormats outFormats rules | 410 args := OrderedCollection new. 411 parser := STInST.STFileInParser. 412 quiet := false. 413 verbose := false. 414 outFile := nil. 415 filter := [ :class | true ]. 416 converter := SyntaxConverter new. 417 STInST.FileOutExporter defaultExporter: STInST.FormattingExporter. 418 outFormats := Dictionary from: { 419 'gst2' -> STInST.OldSyntaxExporter. 420 'gst' -> STInST.FormattingExporter. 421 'squeak' -> STInST.SqueakSyntaxExporter. 422 }. 423 inFormats := Dictionary from: { 424 'gst2' -> STInST.STFileInParser. 425 'gst' -> STInST.GSTFileInParser. 426 'squeak' -> STInST.SqueakFileInParser. 427 'sif' -> STInST.SIFFileInParser 428 }. 429 rules := OrderedCollection new. 430 431 helpString := 432'Usage: 433 gst-convert [OPTION]... [INFILE [OUTFILE]] 434 gst-convert [OPTION]... -o|--output OUTFILE INFILES 435 436Options: 437 -q, --quiet don''t show any message 438 -v, --verbose print extra information while processing 439 -f, --format=FORMAT convert from given input format (supported 440 formats are %1) 441 -F, --output-format=FORMAT convert to given output format (supported 442 formats are %2) 443 -C, --class=REGEX convert only classes matching REGEX 444 -C, --class=+REGEX in addition, convert classes matching REGEX 445 -C, --class=-REGEX do not convert classes matching REGEX 446 -c, --category=REGEX convert only classes whose category matches REGEX 447 -c, --category=+REGEX in addition, convert those whose category 448 matches REGEX 449 -c, --category=-REGEX do not convert classes whose category 450 matches REGEX 451 -r, --rule=''CODE->REPL'' look for CODE and replace it with REPL 452 453 -o, --output OUTFILE concatenate multiple input files into a single 454 converted output file 455 --help display this message and exit 456 --version print version information and exit 457 458' % {inFormats keys asSortedCollection fold: [ :a :b | a, ', ', b ]. 459 outFormats keys asSortedCollection fold: [ :a :b | a, ', ', b ]}. 460 461 Smalltalk 462 arguments: '-h|--help --version -q|--quiet -v|-V|--verbose -r|--rule: 463 -C|--class: -c|--category: -f|--format: -o|--output: 464 -F|--output-format: -I|--image-file: --kernel-directory:' 465 do: [ :opt :arg | 466 opt = 'help' ifTrue: [ 467 helpString displayOn: stdout. 468 ObjectMemory quit: 0 ]. 469 470 opt = 'version' ifTrue: [ 471 ('gst-convert - %1' % {Smalltalk version}) displayNl. 472 ObjectMemory quit: 0 ]. 473 474 opt = 'quiet' ifTrue: [ 475 quiet := true. 476 verbose := false ]. 477 478 opt = 'verbose' ifTrue: [ 479 quiet := false. 480 verbose := true ]. 481 482 opt = 'output' ifTrue: [ 483 outFile isNil ifFalse: [ 484 helpString displayOn: stderr. 485 ObjectMemory quit: 1 ]. 486 outFile := arg ]. 487 488 opt = 'rule' ifTrue: [ 489 rules add: arg]. 490 491 opt = 'class' ifTrue: [ 492 [ 'a' ~ arg ] on: Error do: [ :ex | 493 helpString displayOn: stderr. 494 ObjectMemory quit: 1 ]. 495 496 filter := arg 497 asFilterOn: filter 498 through: [ :class | class asClass nameIn: Smalltalk ] ]. 499 500 opt = 'category' ifTrue: [ 501 [ 'a' ~ arg ] on: Error do: [ :ex | 502 helpString displayOn: stderr. 503 ObjectMemory quit: 1 ]. 504 505 filter := arg 506 asFilterOn: filter 507 through: [ :class | class category ifNil: [ '' ] ] ]. 508 509 opt = 'output-format' ifTrue: [ 510 STInST.FileOutExporter defaultExporter: 511 (outFormats at: arg ifAbsent: [ 512 helpString displayOn: stderr. 513 ObjectMemory quit: 1 ]) ]. 514 515 opt = 'format' ifTrue: [ 516 parser := inFormats at: arg ifAbsent: [ 517 helpString displayOn: stderr. 518 ObjectMemory quit: 1 ] ]. 519 520 opt isNil ifTrue: [ 521 args addLast: arg ]. 522 ] 523 524 ifError: [ 525 helpString displayOn: stderr. 526 ObjectMemory quit: 1 ]. 527 528 "Post process the rules now we know the target." 529 rules do: [:rule | 530 converter addRule: rule parser: parser]. 531 532 [ 533 outFile isNil 534 ifTrue: [ 535 args size > 2 ifTrue: [ 536 helpString displayOn: stderr. 537 ObjectMemory quit: 1 ]. 538 539 inFile := (args size = 0 or: [ args first = '-' ]) 540 ifTrue: [ stdin ] 541 ifFalse: [ FileStream open: args first mode: FileStream read ]. 542 outFile := (args size <= 1 or: [ args last = '-' ]) 543 ifTrue: [ stdout ] 544 ifFalse: [ FileStream open: args last mode: FileStream write ] ] 545 ifFalse: [ 546 args := args collect: [ :f | 547 f = '-' 548 ifTrue: [ stdin ] 549 ifFalse: [ FileStream open: f mode: FileStream read ] ]. 550 inFile := args fold: [ :a :b | a, b ]. 551 552 outFile := outFile = '-' 553 ifTrue: [ stdout ] 554 ifFalse: [ FileStream open: outFile mode: FileStream write ] ]. 555 556 converter filter: filter. 557 converter 558 convertStream: inFile 559 with: parser 560 to: outFile. 561 562 inFile close. 563 outFile close 564 ] 565 on: Notification do: [ :ex | 566 verbose ifTrue: [ stderr nextPutAll: 'gst-convert: ', ex messageText; nl; flush ]. 567 ex resume ] 568 on: Warning do: [ :ex | 569 quiet ifFalse: [ stderr nextPutAll: 'gst-convert: warning: ', ex messageText; nl; flush ]. 570 ex resume ] 571 on: Error do: [ :ex | 572 stderr nextPutAll: 'gst-convert: error: ', ex messageText; nl; flush. 573 outFile = stdout ifFalse: [ 574 outFile close. 575 576 "TODO: don't do this on non-regular files. It will make 577 /dev/null disappear if you run gst-convert as root (which 578 you shouldn't)." 579 [ (File name: outFile name) remove ] on: Error do: [ :ex | ] ]. 580 "ex pass." ObjectMemory quit: 1 ]. 581] 582