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