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: NewSyntaxExporter [
35    <comment: 'This class is responsible for filing out
36               a given class on a given stream'>
37
38    printFormattedSet: aSet [
39        aSet isNil ifTrue: [ ^self ].
40        aSet do: [ :element | outStream nextPutAll: element ]
41            separatedBy: [ outStream space ]
42    ]
43
44    fileOutDeclaration: aBlock [
45        (completeFileOut and: [ outClass environment ~= self defaultNamespace ])
46	    ifFalse: [ ^self fileOutClassBody: aBlock ].
47
48        outStream nextPutAll: 'Namespace current: ';
49                  store: outClass environment;
50                  nextPutAll: ' ['; nl; nl.
51
52	self fileOutClassBody: aBlock.
53        outStream nextPut: $]; nl; nl.
54    ]
55
56    fileOutSelectors: selectors classSelectors: classSelectors [
57        self fileOutDeclaration: [
58            classSelectors do: [ :each | self fileOutSource: each class: true ].
59            selectors do: [ :each | self fileOutSource: each class: false ].
60        ]
61    ]
62
63    fileOutSource: selector class: isClass [
64        | class |
65
66        outStream nl; nextPutAll: '    '.
67        class := isClass
68                    ifTrue: [ outStream nextPutAll: outClass name; nextPutAll: ' class >> '.
69                              outClass asMetaclass ]
70                    ifFalse: [ outClass ].
71        outStream
72	    nextPutAll: (class >> selector) methodRecompilationSourceString;
73	    nl.
74    ]
75
76    fileOutCategory: category class: isClass [
77        | methods theClass |
78
79	theClass := isClass
80	    ifTrue: [ outClass asMetaclass ]
81	    ifFalse: [ outClass ].
82
83        methods := theClass selectors select:
84                    [ :selector | (theClass compiledMethodAt: selector)
85                                    methodCategory = category ].
86
87        methods asSortedCollection
88	    do: [ :selector | self fileOutSource: selector class: isClass ]
89    ]
90
91    fileOutClassExtension: aBlock [
92        outStream nextPutAll: (outClass asClass name).
93
94        (outClass isMetaclass)
95            ifTrue:  [ outStream nextPutAll: ' class extend ['; nl ]
96            ifFalse: [ outStream nextPutAll: ' extend ['; nl ].
97
98        aBlock value.
99
100        outStream nl; nextPut: $]; nl; nl.
101    ]
102
103    fileOutClassDeclaration: aBlock [
104        | aSet superclassName inheritedShape |
105
106        outClass isMetaclass ifTrue: [ ^outClass ].
107
108        superclassName := outClass superclass isNil
109            ifTrue: [ 'nil' ]
110            ifFalse: [ outClass superclass nameIn: outClass environment ].
111
112        outStream
113            nextPutAll: superclassName; space;
114	        nextPutAll: 'subclass: ';
115            nextPutAll: outClass name; space;
116            nextPut: $[; nl; space: 4.
117
118        "instance variables"
119        (outClass instVarNames isEmpty) ifFalse: [
120            outStream nextPut: $|; space.
121            self printFormattedSet: outClass instVarNames.
122            outStream space; nextPut: $|; nl; space: 4
123        ].
124
125	"shape"
126	inheritedShape := outClass superclass isNil
127				ifTrue: [ nil ]
128				ifFalse: [ outClass superclass shape ].
129	outClass shape ~~
130	    (outClass inheritShape ifTrue: [ inheritedShape ] ifFalse: [ nil ])
131	    	ifTrue: [ outStream nl; space: 4;
132	    	  		  nextPutAll: '<shape: ';
133			          store: outClass shape;
134			          nextPut: $> ].
135
136	"sharedPools"
137        (aSet := outClass sharedPools) do: [ :element |
138            outStream nl; space: 4; nextPutAll: '<import: '.
139            outStream nextPutAll: element.
140            outStream nextPutAll: '>' ].
141
142	    "category and comment"
143	outStream nl.
144	outClass classPragmas do: [ :selector |
145            outStream space: 4;
146		  nextPut: $<;
147		  nextPutAll: selector;
148		  nextPutAll: ': '.
149	    (outClass perform: selector) storeLiteralOn: outStream.
150	    outStream  nextPut: $>; nl ].
151
152        "class instance varriables"
153        outClass asMetaclass instVarNames isEmpty
154            ifFalse: [ outStream nl; space: 4; nextPutAll: outClass name;
155                       nextPutAll: ' class ['; nl; tab.
156                       outStream nextPut: $|; space.
157                       self printFormattedSet: outClass asMetaclass instVarNames.
158                       outStream space; nextPut: $|; nl; tab.
159                       outStream nl; space: 4; nextPut: $]; nl ].
160
161        "class variables"
162        ((aSet := outClass classVarNames) isEmpty)
163            ifFalse: [
164                outStream nl.
165                aSet do: [ :var | outStream space: 4; nextPutAll: var; nextPutAll: ' := nil.'; nl ] ].
166
167        aBlock value.
168
169        outStream nextPut: $]; nl; nl.
170    ]
171
172    fileOutMethods [
173        outClass asMetaclass collectCategories do:
174            [ :category | self fileOutCategory: category class: true ].
175
176        outClass asMetaclass selectors isEmpty ifFalse: [ outStream nl ].
177
178        outClass collectCategories do:
179            [ :category | self fileOutCategory: category class: false ]
180    ]
181
182    fileOutInitialize [
183        (outClass includesSelector: #initialize)
184            ifTrue: [ outStream nl;
185                        nextPutAll: 'Eval [ ';
186                        print: outClass;
187                        nextPutAll: ' initialize ]'; nl. ]
188    ]
189]
190
191NewSyntaxExporter subclass: FormattingExporter [
192
193    <comment: 'This class in addition to FileOutExporter, uses an RBFormatter
194               to pretty print the body of every method.'>
195
196    fileOutInitialize [ ]
197
198    fileOutSource: selector class: isClass [
199        | class source |
200        outStream nl; nextPutAll: '    '.
201        class := isClass
202                    ifTrue: [
203			outStream
204			    nextPutAll: outClass name;
205			    nextPutAll: ' class >> '.
206                        outClass asMetaclass ]
207                    ifFalse: [ outClass ].
208
209	source := (class compiledMethodAt: selector) methodFormattedSourceString.
210        outStream nextPutAll: source; nl.
211    ]
212]
213