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