"====================================================================== | | ClassDescription Method Definitions | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Steve Byrne. | | This file is part of the GNU Smalltalk class library. | | The GNU Smalltalk class library is free software; you can redistribute it | and/or modify it under the terms of the GNU Lesser General Public License | as published by the Free Software Foundation; either version 2.1, or (at | your option) any later version. | | The GNU Smalltalk class library is distributed in the hope that it will be | useful, but WITHOUT ANY WARRANTY; without even the implied warranty of | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser | General Public License for more details. | | You should have received a copy of the GNU Lesser General Public License | along with the GNU Smalltalk class library; see the file COPYING.LESSER. | If not, write to the Free Software Foundation, 59 Temple Place - Suite | 330, Boston, MA 02111-1307, USA. | ======================================================================" Behavior subclass: #ClassDescription instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Language-Implementation' ! ClassDescription comment: 'My instances provide methods that access classes by category, and allow whole categories of classes to be filed out to external disk files.' ! !ClassDescription methodsFor: 'organization of messages and classes'! createGetMethod: what default: value "Create a method accessing the variable `what', with a default value of `value', using lazy initialization" ^(super createGetMethod: what default: value) methodCategory: 'accessing' ! createGetMethod: what "Create a method accessing the variable `what'." ^(super createGetMethod: what) methodCategory: 'accessing' ! createSetMethod: what "Create a method which sets the variable `what'." ^(super createSetMethod: what) methodCategory: 'accessing' ! defineCFunc: cFuncNameString withSelectorArgs: selectorAndArgs returning: returnTypeSymbol args: argsArray "See documentation. Too complex to describe it here ;-)" ^(super defineCFunc: cFuncNameString withSelectorArgs: selectorAndArgs returning: returnTypeSymbol args: argsArray) methodCategory: 'C functions' ! removeCategory: aString "Remove from the receiver every method belonging to the given category" | selector method category | methodDictionary isNil ifTrue: [ ^self ]. methodDictionary copy associationsDo: [ :assoc | method := assoc value. method methodCategory = category ifTrue: [ methodDictionary removeAssociation: assoc ] ]. ! whichCategoryIncludesSelector: selector "Answer the category for the given selector, or nil if the selector is not found" | method | methodDictionary isNil ifTrue: [ ^nil ]. method := methodDictionary at: selector ifAbsent: [ ^nil ]. ^method methodCategory ! ! !ClassDescription methodsFor: 'copying'! copy: selector from: aClass "Copy the given selector from aClass, assigning it the same category" | method | method := aClass compiledMethodAt: selector. methodDictionary at: selector put: (method withNewMethodClass: self). ! copy: selector from: aClass classified: categoryName "Copy the given selector from aClass, assigning it the given category" | method | method := (aClass compiledMethodAt: selector) withNewMethodClass: self. method methodCategory: categoryName. methodDictionary at: selector put: method ! copyAll: arrayOfSelectors from: class "Copy all the selectors in arrayOfSelectors from class, assigning them the same category they have in class" arrayOfSelectors do: [ :selector | self copy: selector from: class ] ! copyAll: arrayOfSelectors from: class classified: categoryName "Copy all the selectors in arrayOfSelectors from aClass, assigning them the given category" arrayOfSelectors do: [ :selector | self copy: selector from: class classified: categoryName ] ! copyAllCategoriesFrom: aClass "Copy all the selectors in aClass, assigning them the original category" | method | aClass selectors do: [ :selector | self copy: selector from: aClass ] ! copyCategory: categoryName from: aClass "Copy all the selectors in from aClass that belong to the given category" | method | aClass selectors do: [ :selector | method := aClass compiledMethodAt: selector. method methodCategory = categoryName ifTrue: [ self copy: selector from: aClass ] ] ! copyCategory: categoryName from: aClass classified: newCategoryName "Copy all the selectors in from aClass that belong to the given category, reclassifying them as belonging to the given category" | method | aClass selectors do: [ :selector | method := aClass compiledMethodAt: selector. method methodCategory = categoryName ifTrue: [ self copy: selector from: aClass classified: newCategoryName ] ] ! ! !ClassDescription methodsFor: 'compiling'! compile: code classified: categoryName "Compile code in the receiver, assigning the method to the given category. Answer the newly created CompiledMethod, or nil if an error was found." | method | method := self compile: code. method notNil ifTrue: [method methodCategory: categoryName]. ^method ! compile: code classified: categoryName ifError: block "Compile method source and install in method category, categoryName. If there are parsing errors, invoke exception block, 'block' (see compile:ifError:). Return the method" | method | method := self compile: code ifError: [ ^block value ]. method notNil ifTrue: [method methodCategory: categoryName]. ^method ! compile: code classified: categoryName notifying: requestor "Compile method source and install in method category, categoryName. If there are parsing errors, send an error message to requestor" | method | method := self compile: code notifying: requestor. method notNil ifTrue: [method methodCategory: categoryName]. ^method ! ! !ClassDescription methodsFor: 'printing'! nameIn: aNamespace "Answer the class name when the class is referenced from aNamespace" ^self environment == aNamespace ifTrue: [ self printString ] ifFalse: [ self environment storeString, ' ', self printString ] ! classVariableString self subclassResponsibility ! instanceVariableString "Answer a string containing the name of the receiver's instance variables." | stream | instanceVariables isNil ifTrue: [ ^'' ]. stream := WriteStream on: (String new: 0). instanceVariables do: [ :instVarName | stream nextPutAll: instVarName; nextPut: ($ ) ]. ^stream contents ! sharedVariableString self subclassResponsibility ! ! !ClassDescription methodsFor: 'filing'! fileOutOn: aFileStream "File out complete class description: class definition, class and instance methods" self subclassResponsibility ! fileOut: fileName "Open the given file and to file out a complete class description to it" | aFileStream | aFileStream := FileStream open: fileName mode: FileStream write ifFail: [ ^self error: 'Failed to open ''', fileName, '''' ]. Transcript nextPutAll: 'Filing out class to: '; nextPutAll: fileName. self fileOutOn: aFileStream. aFileStream close. ! fileOutCategory: categoryName to: fileName "File out all the methods belonging to the method category, categoryName, to the fileName file" | aFileStream | aFileStream := FileStream open: fileName mode: FileStream write ifFail: [ ^self error: 'Failed to open ''', fileName, '''' ]. Transcript nextPutAll: 'Filing out a category to: '; nextPutAll: fileName. self fileOutCategory: categoryName toStream: aFileStream. aFileStream close ! fileOutCategory: category toStream: aFileStream "File out all the methods belonging to the method category, categoryName, to aFileStream" | methods | self selectors isNil ifTrue: [ ^self ]. aFileStream nextPut: $!; print: self; nextPutAll: ' methodsFor: '; store: category; nextPut: $!. methods := self selectors select: [ :selector | (self compiledMethodAt: selector) methodCategory = category ]. methods asSortedCollection do: [ :selector | aFileStream nextPutAll: ' '; nextPutAll: (self sourceCodeAt: selector); nextPut: $! ]. aFileStream nextPutAll: ' ! ' ! fileOutSelector: selector to: fileName "File out the given selector to fileName" | aFileStream | aFileStream := FileStream open: fileName mode: FileStream write ifFail: [ ^self error: 'Failed to open ''', fileName, '''' ]. Transcript nextPutAll: 'Filing out a selector to: '; nextPutAll: fileName. self fileOutHeaderOn: aFileStream. aFileStream nextPutAll: '!'; print: self; nextPutAll: ' methodsFor: '; store: (self compiledMethodAt: selector) methodCategory; nextPut: $!; nl; nextPutAll: (self sourceCodeAt: selector) ; nextPutAll: '! !'; close ! ! !ClassDescription methodsFor: 'private'! collectCategories "Answer all the method categories, sorted by name" | categories | methodDictionary isNil ifTrue: [ ^#() ]. categories := Set new. methodDictionary do: [ :method | categories add: (method methodCategory) ]. ^categories asSortedCollection ! ! !ClassDescription methodsFor: 'conversion'! asClass self subclassResponsibility ! asMetaclass "Answer the metaclass associated to the receiver" ^self asClass class ! !