Model subclass: #Building
	instanceVariableNames: ''
	classVariableNames: 'MooseAttributeTypeErrorSignal MooseConnectionError MooseConnectionTypeErrorSignal MooseErrorSignal MooseTypeErrorSignal '
	poolDictionaries: ''
	category: 'BuildingADT'
	keys: ''
	attributes: ''
	relations: ''!



!Building methodsFor: 'slang-io'!

writeSlangAttributesOn: aSlangHandler 
	"Writes slang-representations off all defined non-key-attributes of the 
	receiver 
	on aSlangHandler, e.g. 
	'(attr1 value1) 
	(attr2 value2) 
	... 
	(attrN valueN)'"

	self class allAttributes
		do: 
			[:eachAttribute | 
			| eachValue |
			eachValue := self perform: (eachAttribute asString, 'Local') asSymbol.
			eachValue notNil
				ifTrue: 
					[aSlangHandler openList.
					aSlangHandler writeString: '_' , eachAttribute asString.
					eachValue class knowsAboutSlang
						ifTrue: [eachValue writeSlangOn: aSlangHandler]
						ifFalse: [aSlangHandler writeString: eachValue printString].
					aSlangHandler closeList.
					aSlangHandler newLine]].
	^aSlangHandler!

writeSlangDataOn: aSlangHandler 
	"Writes the slang-representation of the receiver's data on aSlangHandler"

	aSlangHandler openRecord.
	aSlangHandler tabsIncrease; newLine.
	self writeSlangKeysOn: aSlangHandler.
	self writeSlangAttributesOn: aSlangHandler.
	self writeSlangRelationsOn: aSlangHandler.
	aSlangHandler tabsDecrease; newLine.
	aSlangHandler closeRecord.
	aSlangHandler newLine.
	^aSlangHandler!

writeSlangDRefOn: aSlangHandler 
	"Writes a slang-reference of the receiver, wich is marked deleted"

	aSlangHandler openList.
	aSlangHandler writeString: 'KEY'.
	aSlangHandler writeString: _key negated printString.
	aSlangHandler writeString: self class name,'Class'.
	aSlangHandler closeList.
	^self!

writeSlangKeysOn: aSlangHandler 
	"Writes slang-representations off all defined key-attributes of the receiver 
	on aSlangHandler. This will include the unique key of the receiver, e.g. 
	'(KEY <_key>) 
	(key1 value1) 
	(key2 value2) 
	... 
	(keyN valueN)'"

	aSlangHandler openList.
	aSlangHandler writeString: 'KEY'.
	aSlangHandler writeString: _key printString.
	aSlangHandler closeList.
	aSlangHandler newLine.
	self class allKeys
		do: 
			[:eachKey | 
			| eachValue |
			eachValue := self perform: eachKey.
			eachValue isNil
				ifFalse: 
					[aSlangHandler openList.
					aSlangHandler writeString: '_' , eachKey asString.
					eachValue class knowsAboutSlang
						ifTrue: [eachValue writeSlangOn: aSlangHandler]
						ifFalse: [aSlangHandler writeString: eachValue printString].
					aSlangHandler closeList.
					aSlangHandler newLine]].
	^aSlangHandler!

writeSlangRefOn: aSlangHandler 
	"Writes a slang-reference of the receiver"

	aSlangHandler openList.
	aSlangHandler writeString: 'KEY'.
	aSlangHandler writeString: _key printString.
	aSlangHandler writeString: self class name,'Class'.
	aSlangHandler closeList.
	^self!

writeSlangRelationsOn: aSlangHandler 
	"Writes references to all connected objects on aSlangHandler. If the 
	connected object is an instance of a subclass of the expected class, then 
	the name of the class is also noticed. The instance of the relation-object 
	has to write the slang-representation of its connections."

	| relAnz names |
	names := self class allRelations.
	relAnz := names size.
	names 
		do: 
			[:eachRel | 
			| eachRelVal |
			eachRelVal := self perform: (eachRel asString, 'Local') asSymbol.
			eachRelVal isEmpty
				ifFalse: 
					[aSlangHandler openList.
					aSlangHandler writeString: '_' , eachRel asString.
					eachRelVal writeSlangOn: aSlangHandler.
					aSlangHandler closeList.
					relAnz := relAnz - 1.
					relAnz isZero ifFalse: [aSlangHandler newLine]]].
	^aSlangHandler! !


!Building methodsFor: 'printing'!

printOn: aStream 
	"Print the classname and the keyattribute/value-pairs on aStream. e.g. 'an 
	Instance( key1: value1 key2: value2 ... keyN: valueN )'. This replaces the 
	printOn-method of the ST-Library"

	| title keys |
	title := self class name.
	keys := self class allKeys.
	aStream nextPutAll: ((title at: 1) isVowel
			ifTrue: ['an ']
			ifFalse: ['a ']).
	aStream nextPutAll: self class name.
	keys size isZero
		ifTrue: [aStream nextPutAll: '<' , _key printString , '>'; cr]
		ifFalse: 
			[aStream nextPut: $(.
			keys do: [:each | aStream nextPutAll: ' ' , each asString , ': ' , (self perform: each) printString].
			aStream nextPutAll: ' )'; cr].
	^self! !


!Building methodsFor: 'error handling'!

mooseAttributeTypeError: aString 
	"Raise a non-proceedable signal that indicates an error with the argument as the message.
	This additional message is the one a subclass should override in order to
	change the handling of errors.
	Remove any trailing spaces from aString, since we know we don't
	want other strings appended to this one."

	| lastNonSpace |
	lastNonSpace := aString findLast: [:ch | ch ~= Character space].
	^self mooseAttributeTypeErrorSignal raiseErrorString: (aString copyFrom: 1 to: lastNonSpace)!

mooseAttributeTypeErrorSignal
	"Answer the Signal used for type-checking -errors, which occur with 
	attributes. 
	(self attributeTypeError:)."

	^self class mooseAttributeTypeErrorSignal!

mooseConnectionError: aString 
	"Raise a non-proceedable signal that indicates an error with the argument as the message.
	This additional message is the one a subclass should override in order to
	change the handling of errors.
	Remove any trailing spaces from aString, since we know we don't
	want other strings appended to this one."

	| lastNonSpace |
	lastNonSpace := aString findLast: [:ch | ch ~= Character space].
	^self mooseConnectionErrorSignal raiseErrorString: (aString copyFrom: 1 to: lastNonSpace)!

mooseConnectionErrorSignal
	"Answer the Signal used for connection-errors 
	(self mooseConnectionError:)."

	^self class mooseConnectionErrorSignal!

mooseConnectionTypeError: aString 
	"Raise a non-proceedable signal that indicates an error with the argument as the message.
	This additional message is the one a subclass should override in order to
	change the handling of errors.
	Remove any trailing spaces from aString, since we know we don't
	want other strings appended to this one."

	| lastNonSpace |
	lastNonSpace := aString findLast: [:ch | ch ~= Character space].
	^self mooseConnectionTypeErrorSignal raiseErrorString: (aString copyFrom: 1 to: lastNonSpace)!

mooseConnectionTypeErrorSignal
	"Answer the Signal used for connection-type errors 
	(self mooseConnectionTypeError:)."

	^self class mooseConnectionTypeErrorSignal!

mooseError: aString 
	"Raise a non-proceedable signal that indicates an error with the argument as the message.
	This additional message is the one a subclass should override in order to
	change the handling of errors.
	Remove any trailing spaces from aString, since we know we don't
	want other strings appended to this one."

	| lastNonSpace |
	lastNonSpace := aString findLast: [:ch | ch ~= Character space].
	^self mooseErrorSignal raiseErrorString: (aString copyFrom: 1 to: lastNonSpace)!

mooseErrorSignal
	"Answer the Signal used for miscellaneous errors 
	(self mooseError:)."

	^self class mooseErrorSignal!

mooseTypeError: aString 
	"Raise a non-proceedable signal that indicates an error with the argument as the message.
	This additional message is the one a subclass should override in order to
	change the handling of errors.
	Remove any trailing spaces from aString, since we know we don't
	want other strings appended to this one."

	| lastNonSpace |
	lastNonSpace := aString findLast: [:ch | ch ~= Character space].
	^self mooseTypeErrorSignal raiseErrorString: (aString copyFrom: 1 to: lastNonSpace)!

mooseTypeErrorSignal
	"Answer the Signal used for type-checking -errors 
	(self typeError:)."

	^self class mooseTypeErrorSignal! !


!Building methodsFor: 'initialize-release'!

initialize
	"Generated by MPOK 2.8."

	"Do initialization for the receiver, e.g. get a unique key."

	super initialize.
	_key isNil ifTrue:[_key := self class nextKey].
	^self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Building class
	instanceVariableNames: ''!



!Building class methodsFor: 'accessing'!

allAttributes
	"Answers an array of all attributes-names for 
	the receiver."

	^self allAttributeVarNames!

allKeys
	"Answers an array of all key-names for 
	the receiver."

	^self allKeyVarNames!

allRelations
	"Answers an array of all relation-names for 
	the receiver."

	^self allRelationVarNames!

myAttributes
	"Answers an array of attributes-names for 
	the receiver."

	^self attributePool keys!

myKeys
	"Answers an array of key-names for 
	the receiver."

	^self keyPool keys!

myRelations
	"Answers an array of relation-names for 
	the receiver."

	^self relationPool keys!

specificationsForRelation: aSymbol
	"Look-up the specifications for the specified relation."

	^self relationPool at: aSymbol ifAbsent:[superclass specificationsForRelation: aSymbol]!

typeForAttribute: aSymbol 
	"Look-up the type for the specified attribute."

	^self attributePool at: aSymbol ifAbsent: [superclass typeForAttribute: aSymbol]!

typeForKey: aSymbol 
	"Look-up the type for the specified key."

	^self keyPool at: aSymbol ifAbsent: [superclass typeForKey: aSymbol]! !


!Building class methodsFor: 'slang-io'!

adtName
	"Answer the name of the adt (used for slang)"

	^'Building'!

calculateAllReferencedObjectsOf: aCollection for: aSet 
	"Ths methods calculates the transitive closure of the elements in 
	aCollections and adds it to aSet."

	aCollection
		do: 
			[:each | 
			| relations |
			aSet add: each.
			relations := each class allRelations.
			relations
				do: 
					[:rel | 
					| connections |
					connections := (each perform: rel).
					connections do: [:object | (aSet includes: object)
							ifFalse: [self calculateAllReferencedObjectsOf: (OrderedCollection with: object)
									for: aSet]]]].
	^aSet!

readSlangFile: aString 
	"This method reads a Slangfile named by aString and answers 
	aDictionary, 
	indexed by th classnames of the read objects, containing all objects 
	of the 
	file. Because the Slangparser is stream-based, this method provides 
	a 
	template"

	| aSet aDictionary aSlangHandler aFile aStream adtName aClass aClassName |
	aDictionary := Dictionary new.
	aFile := UnixFilename named: aString.
	aStream := aFile readStream.
	aSlangHandler := SlangHandler newOn: aStream.
	aSlangHandler open: #read.
	aSlangHandler skipBracket.
	adtName := aSlangHandler readString.
	Transcript cr; show: Date today printString , ' at: ' , Time now printString , ' reading Slangfile ' , aString , ' for ' , adtName; cr.
	aSlangHandler skipBracket.
	[aSlangHandler skipBracket = $(]
		whileTrue: 
			[aClassName := aSlangHandler readClassName.
			aClass := Smalltalk at: aClassName ifAbsent: [nil].
			aClass notNil
				ifTrue: 
					[aSet := aDictionary at: aClass name ifAbsent: [aDictionary at: aClass name put: Set new].
					[aSlangHandler skipBracket = $<]
						whileTrue: [aSet add: (aClass readSlangFrom: aSlangHandler)]]
				ifFalse: [aSlangHandler skipList]].
	aSlangHandler skipBracket.
	aSlangHandler close.
	Transcript cr; show: 'Parser finished. '.
	aSlangHandler makeConnections.
	aSlangHandler printStatistics.
	aStream close.
	^aDictionary!

readSlangFrom: aSlangHandler 
	"Answers an instance of the receiver read from aSlangHandler"

	| keys attributes relations selector key aClass anInstance attrDictionary relDictionary |
	attrDictionary := Dictionary new.
	relDictionary := Dictionary new.
	keys := self allKeys asArray.
	attributes := self allAttributes asArray.
	relations := self allRelations.
	aSlangHandler skipBracket.
	aSlangHandler readString.
	key := SmallInteger readFromString: aSlangHandler readString.
	aSlangHandler skipBracket.
	[aSlangHandler skipBracket = $(]
		whileTrue: 
			[| classDesc ref |
			selector := aSlangHandler readSelector.
			(relations includes: selector)
				ifTrue: 
					[classDesc := self specificationsForRelation: selector.
					ref := true]
				ifFalse: 
					[classDesc := (keys includes: selector)
								ifTrue: [self typeForKey: selector]
								ifFalse: [self typeForAttribute: selector].
					ref := false].
			classDesc isNil
				ifTrue: 
					[aSlangHandler skipList.
					Transcript cr; show: self name asString , ': Skipping list labeled: ' , selector asString]
				ifFalse: 
					[ref
						ifTrue: 
							[aClass := Smalltalk at: (classDesc at: #type).
							relDictionary at: selector put: (aClass readSlangFrom: aSlangHandler)]
						ifFalse: 
							[aClass := Smalltalk at: classDesc.
							attrDictionary at: selector put: (aClass knowsAboutSlang
									ifTrue: [aClass readSlangFrom: aSlangHandler]
									ifFalse: [aClass readFromString: aSlangHandler readString])].
					aSlangHandler skipBracket]].
	anInstance := self new.
	keys , attributes
		do: 
			[:each | 
			| aValue |
			aValue := attrDictionary at: each ifAbsent: [nil].
			aValue isNil ifFalse: [anInstance perform: (each asString , ':') asSymbol with: aValue]].
	aSlangHandler requestConnections: relDictionary for: anInstance.
	aSlangHandler register: anInstance for: key.
	^anInstance!

sortClasses: aSet 
	"This method answers a Dictionary, indexed by the classNames of the sets 
	Elements."

	| aDictionary |
	aDictionary := Dictionary new.
	aSet
		do: 
			[:each | 
			| aCollection className |
			className := each class name.
			aCollection := aDictionary at: className ifAbsent: [aDictionary at: className put: OrderedCollection new].
			aCollection add: each].
	^aDictionary!

writeSlangFile: aString on: aCollection 
	"This methods writes all elements of aCollection an their transitive closure 
	into a file named by aString. Because the slang-output is stream-based, 
	this method provides a template."

	| aSlangHandler aFile aStream classes aSet total |
	Transcript cr; cr; show: Date today printString , ' ' , Time now printString , ' writing Slangfile ' , aString , ' for ' , self adtName.
	aFile := UnixFilename named: aString.
	aStream := aFile writeStream.
	aSlangHandler := SlangHandler newOn: aStream.
	aSlangHandler open: #write.
	aSlangHandler openList.
	aSlangHandler writeString: self adtName.
	aSlangHandler tabsIncrease; newLine.
	aSlangHandler openRecord.
	aSet := self calculateAllReferencedObjectsOf: aCollection for: Set new.
	classes := self sortClasses: aSet.
	total := 0.
	classes keys
		do: 
			[:eachClass | 
			| num |
			num := (classes at: eachClass) size.
			Transcript cr; show: num printString , ' instances of ' , eachClass asString.
			total := total + num.
			aSlangHandler tabsIncrease; newLine.
			aSlangHandler openList.
			aSlangHandler writeString: eachClass asString,'Class'.
			aSlangHandler tabsIncrease; newLine.
			(classes at: eachClass)
				do: [:eachInst | eachInst writeSlangDataOn: aSlangHandler].
			aSlangHandler tabsDecrease.
			aSlangHandler closeList.
			aSlangHandler tabsDecrease].
	aSlangHandler newLine.
	aSlangHandler closeRecord.
	aSlangHandler tabsDecrease; newLine.
	aSlangHandler close.
	aStream close.
	Transcript cr; show: '-----'; cr; show: total printString , ' total'; cr.
	^self! !


!Building class methodsFor: 'Signal constants'!

connectionErrorSignal
	"The parameter for an exception raised by this signal or its children 
	is a MessageSend describing the operation that failed."

	^ConnectionErrorSignal!

mooseAttributeTypeErrorSignal
	"The parameter for an exception raised by this signal or its children 
	is a MessageSend describing the operation that failed."

	^MooseAttributeTypeErrorSignal!

mooseConnectionTypeErrorSignal
	"The parameter for an exception raised by this signal or its children 
	is a MessageSend describing the operation that failed."

	^MooseConnectionTypeErrorSignal!

mooseErrorSignal
	"The parameter for an exception raised by this signal or its children 
	is a MessageSend describing the operation that failed."

	^MooseErrorSignal!

typeErrorSignal
	"The parameter for an exception raised by this signal or its children 
	is a MessageSend describing the operation that failed."

	^TypeErrorSignal! !


!Building class methodsFor: 'class initialization'!

initialize
	"Generated by MPOK 2.8."

	"Do the initialization for the receiver, e.g. initialize the
	error-handling-stuff."
	self name == #Building
		ifTrue: [ self initSignals ].
	^self!

initSignals
	"Do the signal initialization for the receiver."

	| es mes |
	es := Object errorSignal.
	MooseErrorSignal :=  (es := (es newSignalMayProceed: true)
	notifierString: 'Moose error';
		nameClass: self message: #mooseErrorSignal).
	mes := es.
	MooseTypeErrorSignal := (es := (mes newSignal)
		notifierString: 'Type-check failed';
		nameClass: self message: #mooseTypeErrorSignal).
	MooseAttributeTypeErrorSignal := ((es newSignal)
		notifierString: 'Attribute-Type-check failed';
		nameClass: self message: #mooseAttributeTypeErrorSignal).
	MooseConnectionTypeErrorSignal := ((es newSignal)
		notifierString: 'ConnectionType-check failed';
		nameClass: self message: #mooseConnectionTypeErrorSignal).
	MooseConnectionErrorSignal := ((mes newSignal)
		notifierString: '(Dis-) Connection failed';
		nameClass: self message: #mooseConnectionErrorSignal).
	^self! !


!Building class methodsFor: 'instance creation'!

new
	"Generated by MPOK 2.8."

	"Create a new instance of the Receiver. This method implements the
	standard-constructor for Moose-Classes"

	^super new initialize.!

newOn: anInstance
	"Generated by MPOK 2.8."

	"Create a new instance of the Receiver. This method implements the
	copy-constructor for Moose-Classes"

	| newInstance |
	newInstance := super newOn: anInstance.
	newInstance initialize.
	newInstance resetAllConnections.
	^newInstance! !

Building initialize!

To increase readability of this file, some HTML tags have been included

(click here for the original file)