--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/MCClassDefinition.st	Wed Nov 22 14:09:01 2006 +0100
@@ -0,0 +1,370 @@
+"{ Package: 'stx:goodies/monticello' }"
+
+MCDefinition subclass:#MCClassDefinition
+	instanceVariableNames:'name superclassName variables category type comment commentStamp'
+	classVariableNames:''
+	poolDictionaries:''
+	category:'Monticello-Modeling'
+!
+
+
+!MCClassDefinition class methodsFor:'instance creation'!
+
+name: nameString
+superclassName: superclassString
+category: categoryString 
+instVarNames: ivarArray
+classVarNames: cvarArray
+poolDictionaryNames: poolArray
+classInstVarNames: civarArray
+type: typeSymbol
+comment: commentString
+commentStamp: stampString
+	^ self instanceLike:
+		(self new initializeWithName: nameString
+					superclassName: superclassString
+					category: categoryString 
+					instVarNames: ivarArray
+					classVarNames: cvarArray
+					poolDictionaryNames: poolArray
+					classInstVarNames: civarArray
+					type: typeSymbol
+					comment: commentString
+					commentStamp: stampString)
+! !
+
+!MCClassDefinition class methodsFor:'obsolete'!
+
+name: nameString
+superclassName: superclassString
+category: categoryString 
+instVarNames: ivarArray
+classVarNames: cvarArray
+poolDictionaryNames: poolArray
+classInstVarNames: civarArray
+comment: commentString
+	^ self	name: nameString
+			superclassName: superclassString
+			category: categoryString 
+			instVarNames: ivarArray
+			classVarNames: cvarArray
+			poolDictionaryNames: poolArray
+			classInstVarNames: civarArray
+			type: #normal
+			comment: commentString
+!
+
+name: nameString
+superclassName: superclassString
+category: categoryString 
+instVarNames: ivarArray
+classVarNames: cvarArray
+poolDictionaryNames: poolArray
+classInstVarNames: civarArray
+type: typeSymbol
+comment: commentString
+	^ self 
+		name: nameString
+		superclassName: superclassString
+		category: categoryString 
+		instVarNames: ivarArray
+		classVarNames: cvarArray
+		poolDictionaryNames: poolArray
+		classInstVarNames: civarArray
+		type: typeSymbol
+		comment: commentString
+		commentStamp: nil
+!
+
+name: nameString
+superclassName: superclassString
+category: categoryString 
+instVarNames: ivarArray
+comment: commentString
+	^ self	name: nameString
+			superclassName: superclassString
+			category: categoryString 
+			instVarNames: ivarArray
+			classVarNames: #()
+			poolDictionaryNames: #()
+			classInstVarNames: #()
+			comment: commentString
+! !
+
+!MCClassDefinition methodsFor:'accessing'!
+
+actualClass
+	^Smalltalk classNamed: self className
+!
+
+category
+	^ category
+!
+
+classInstVarNames
+	^ self selectVariables: #isClassInstanceVariable
+!
+
+className
+	^ name
+!
+
+classVarNames
+	^ self selectVariables: #isClassVariable
+!
+
+comment
+	^ comment
+!
+
+commentStamp
+	^ commentStamp
+!
+
+description
+	^ Array with: name
+!
+
+instVarNames
+	^ self selectVariables: #isInstanceVariable
+!
+
+poolDictionaries
+	^ self selectVariables: #isPoolImport
+!
+
+selectVariables: aSelector
+	^ variables select: [:v | v perform: aSelector] thenCollect: [:v | v name]
+!
+
+sortKey
+	^ self className
+!
+
+superclassName
+	^ superclassName
+!
+
+type
+	^ type
+!
+
+variables
+	^ variables
+! !
+
+!MCClassDefinition methodsFor:'annotations'!
+
+printAnnotations: requests on: aStream
+	"Add a string for an annotation pane, trying to fulfill the annotation requests.
+	These might include anything that
+		Preferences defaultAnnotationRequests 
+	might return. Which includes anything in
+		Preferences annotationInfo
+	To edit these, use:"
+	"Preferences editAnnotations"
+
+	requests do: [ :aRequest |
+		aRequest == #requirements ifTrue: [
+			self requirements do: [ :req | aStream nextPutAll: req ] separatedBy: [ aStream space ]]
+	] separatedBy: [ aStream space ].
+! !
+
+!MCClassDefinition methodsFor:'comparing'!
+
+= aDefinition
+	^ ((super = aDefinition)
+		and: [superclassName = aDefinition superclassName]
+		and: [category = aDefinition category]
+		and: [type = aDefinition type])
+		and: [variables = aDefinition variables]
+		and: [comment = aDefinition comment]
+		
+!
+
+hash
+	| hash |
+	hash _ String stringHash: name initialHash: 0.
+	hash _ String stringHash: superclassName initialHash: hash.
+	hash _ String stringHash: (category ifNil: ['']) initialHash: hash.
+	hash _ String stringHash: type initialHash: hash.
+	variables do: [
+		:v |
+		hash _ String stringHash: v name initialHash: hash.
+	].
+	^ hash
+!
+
+provisions
+	^ Array with: name
+!
+
+requirements
+	^ (Array with: superclassName), self poolDictionaries
+! !
+
+!MCClassDefinition methodsFor:'initializing'!
+
+addVariables: aCollection ofType: aClass
+	variables addAll: (aCollection collect: [:var | aClass name: var asString]).
+!
+
+defaultCommentStamp
+	^ String new
+
+	"The version below avoids stomping on stamps already in the image
+
+	^ (Smalltalk at: name ifPresent: [:c | c organization commentStamp])
+		ifNil: ['']
+	"
+! !
+
+!MCClassDefinition methodsFor:'installing'!
+
+createClass
+	| superClass |
+	superClass _ Smalltalk at: superclassName.
+	^ (ClassBuilder new)
+			name: name 
+			inEnvironment: superClass environment 
+			subclassOf: superClass
+			type: type 
+			instanceVariableNames: self instanceVariablesString 
+			classVariableNames: self classVariablesString 
+			poolDictionaries: self sharedPoolsString
+			category: category
+!
+
+load
+	 self createClass ifNotNilDo:
+		[:class |
+		class class instanceVariableNames: self classInstanceVariablesString.
+		self hasComment ifTrue: [class classComment: comment stamp: commentStamp]]
+!
+
+stringForVariablesOfType: aSymbol
+	^ String streamContents:
+		[:stream |
+		(self selectVariables: aSymbol) 
+			do: [:ea | stream nextPutAll: ea]
+			separatedBy: [stream space]]
+!
+
+unload
+	Smalltalk removeClassNamed: name
+! !
+
+!MCClassDefinition methodsFor:'printing'!
+
+classInstanceVariablesString
+	^ self stringForVariablesOfType: #isClassInstanceVariable
+!
+
+classVariablesString
+	^ self stringForVariablesOfType: #isClassVariable
+!
+
+definitionString
+	^ String streamContents: [:stream | self printDefinitionOn: stream]
+!
+
+instanceVariablesString
+	^ self stringForVariablesOfType: #isInstanceVariable
+!
+
+kindOfSubclass
+	type = #normal ifTrue: [^ ' subclass: '].
+	type = #words ifTrue: [^ ' variableWordSubclass: '].
+	type = #variable ifTrue: [^ ' variableSubclass: '].
+	type = #bytes ifTrue: [^ ' variableByteSubclass: '].
+	type = #weak ifTrue: [^ ' weakSubclass: ' ].
+	type = #compiledMethod ifTrue: [^ ' variableByteSubclass: ' ].
+	self error: 'Unrecognized class type'
+!
+
+printDefinitionOn: stream
+		stream 
+			nextPutAll: self superclassName;
+			nextPutAll: self kindOfSubclass;
+			nextPut: $# ;
+			nextPutAll: self className;
+			cr; tab;
+			nextPutAll: 'instanceVariableNames: ';
+			store: self instanceVariablesString;
+			cr; tab;
+			nextPutAll: 'classVariableNames: ';
+			store: self classVariablesString;
+			cr; tab;
+			nextPutAll: 'poolDictionaries: ';
+			store: self sharedPoolsString;
+			cr; tab;
+			nextPutAll: 'category: ';
+			store: self category asString
+!
+
+sharedPoolsString
+	^ self stringForVariablesOfType: #isPoolImport
+!
+
+source
+	^ self definitionString
+!
+
+summary
+	^ name
+! !
+
+!MCClassDefinition methodsFor:'serializing'!
+
+initializeWithName: nameString
+superclassName: superclassString
+category: categoryString 
+instVarNames: ivarArray
+classVarNames: cvarArray
+poolDictionaryNames: poolArray
+classInstVarNames: civarArray
+type: typeSymbol
+comment: commentString
+commentStamp: stampStringOrNil
+	name _ nameString asSymbol.
+	superclassName _ superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol].
+	category _ categoryString.
+	name = #CompiledMethod ifTrue: [type _ #compiledMethod] ifFalse: [type _ typeSymbol].
+	comment _ commentString withSqueakLineEndings.
+	commentStamp _ stampStringOrNil ifNil: [self defaultCommentStamp].
+	variables _ OrderedCollection  new.
+	self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
+	self addVariables: cvarArray ofType: MCClassVariableDefinition.
+	self addVariables: poolArray ofType: MCPoolImportDefinition.
+	self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.
+! !
+
+!MCClassDefinition methodsFor:'testing'!
+
+hasClassInstanceVariables
+	^ (self selectVariables: #isClassInstanceVariable) isEmpty not
+!
+
+hasComment
+	^ comment notNil and: [comment ~= '']
+!
+
+isClassDefinition
+	^ true
+!
+
+isCodeDefinition
+	^ true
+! !
+
+!MCClassDefinition methodsFor:'visiting'!
+
+accept: aVisitor
+	^ aVisitor visitClassDefinition: self
+! !
+
+!MCClassDefinition class methodsFor:'documentation'!
+
+version
+    ^ '$Header: /cvs/stx/stx/goodies/monticello/MCClassDefinition.st,v 1.1 2006-11-22 13:09:01 cg Exp $'
+! !