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