1"======================================================================
2|
3|   Class fileout support
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
33
34FileOutExporter subclass: OldSyntaxExporter [
35    <comment: 'This class is responsible for filing out
36               a given class on a given stream'>
37
38    printFormattedSet: aSet [
39        outStream nextPut: $'.
40        aSet isNil ifTrue: [ ^self ].
41        aSet do: [ :element | outStream nextPutAll: element ]
42            separatedBy: [ outStream space ].
43        outStream nextPut: $'.
44    ]
45
46    fileOutDeclaration: aBlock [
47        (completeFileOut and: [ outClass environment ~= self defaultNamespace ])
48	    ifFalse: [ ^self fileOutClassBody: aBlock ].
49
50        outStream nextPutAll: 'Namespace current: ';
51                  store: outClass environment;
52		  nextPut: $!; nl; nl.
53
54	self fileOutClassBody: aBlock.
55        outStream nextPutAll: 'Namespace current: Smalltalk!'; nl; nl.
56    ]
57
58    fileOutClassExtension: aBlock [
59        aBlock value.
60        outStream nl.
61    ]
62
63    fileOutComment [
64	outStream
65            print: outClass;
66            nextPutAll: ' comment: ';
67            nl;
68            print: outClass comment;
69            nextPut: $!;
70            nl; nl.
71    ]
72
73    fileOutSelectors: selectors classSelectors: classSelectors [
74        self fileOutDeclaration: [
75            self fileOutSource: classSelectors class: outClass asMetaclass.
76            self fileOutSource: selectors class: outClass.
77        ]
78    ]
79
80    fileOutClassDeclaration: aBlock [
81        | superclassName |
82
83        superclassName := outClass superclass isNil
84            ifTrue: [ 'nil' ]
85            ifFalse: [ outClass superclass nameIn: outClass environment ].
86
87        outStream
88            nextPutAll: superclassName; space;
89            nextPutAll: outClass kindOfSubclass; space;
90            store: outClass name asSymbol.
91
92        outStream nl; tab; nextPutAll: 'instanceVariableNames: '.
93        self printFormattedSet: outClass instVarNames.
94
95        outStream nl; tab; nextPutAll: 'classVariableNames: '.
96        self printFormattedSet: outClass classVarNames.
97
98        outStream nl; tab; nextPutAll: 'poolDictionaries: '.
99        self printFormattedSet: outClass sharedPools.
100
101        outStream nl; tab; nextPutAll: 'category: ';
102            print: outClass category;
103            nextPut: $!;
104            nl; nl.
105
106	self fileOutComment.
107
108        outClass asMetaclass instVarNames isEmpty ifFalse: [
109            outStream print: outClass asMetaclass; nextPutAll: ' instanceVariableNames: '.
110            self printFormattedSet: outClass asMetaclass instVarNames.
111	    outStream nextPut: $!; nl; nl].
112	aBlock value.
113        outStream nl.
114    ]
115
116    fileOutMethods [
117        outClass asMetaclass collectCategories do:
118            [ :category | self fileOutCategory: category class: true ].
119
120        outClass collectCategories do:
121            [ :category | self fileOutCategory: category class: false ]
122    ]
123
124    fileOutCategory: category class: aBoolean [
125        | methods class |
126
127        class := aBoolean ifTrue: [ outClass asMetaclass ] ifFalse: [ outClass ].
128        methods := class selectors select: [ :selector |
129            (class compiledMethodAt: selector) methodCategory = category ].
130
131	self fileOutSource: methods class: class.
132    ]
133
134    fileOutSource: selectors class: aClass [
135	| categories catSB methodSB |
136	catSB := [ :a :b | (a key ifNil: ['~~']) < (b key ifNil: ['~~']) ].
137	methodSB := [ :a :b | a selector < b selector ].
138
139	categories := Dictionary new.
140	selectors do: [ :each || method |
141	    method := aClass >> each.
142	    (categories
143		at: method methodCategory
144		ifAbsentPut: [SortedCollection sortBlock: methodSB]) add: method].
145
146	(categories associations asSortedCollection: catSB) do: [ :each |
147	    self fileOutCategory: each key methods: each value class: aClass ]
148    ]
149
150    fileOutCategory: aString methods: methods class: aClass [
151        methods isEmpty ifTrue: [ ^self ].
152        outStream
153	     nextPut: $!; print: aClass;
154             nextPutAll: ' methodsFor: ';
155             print: aString;
156             nextPut: $!.
157
158        methods do: [ :method |
159	    outStream nl.
160	    self fileOutChunk: (self oldSyntaxSourceCodeFor: method) ].
161
162        outStream nextPutAll: ' !'; nl; nl
163    ]
164
165    fileOutChunk: aString [
166        outStream
167            nl;
168            nextPutAll: aString;
169            nextPut: $!
170    ]
171
172    oldSyntaxSourceCodeFor: aMethod [
173	| source cat |
174	source := aMethod methodFormattedSourceString.
175	source := source copyReplacingRegex: '\s*\[\s*(.*[\S\n])' with: '
176	%1'.
177	source := source copyReplacingRegex: '\s*]\s*$' with: '
178'.
179	cat := aMethod methodCategory printString escapeRegex.
180        ^source
181	    copyReplacingAllRegex: ('(?m:^)\s*<category: ', cat, '>\s*
182')
183	    with: ''.
184    ]
185
186    fileOutInitialize [
187        (outClass includesSelector: #initialize)
188            ifTrue: [ outStream nl;
189                        print: outClass;
190                        nextPutAll: ' initialize!'; nl. ]
191    ]
192]
193
194