! ! From ! GEMSTONE: 5.0, Mon Jul 15 22:14:11 US/Pacific 1996; IMAGE: GemStone v5.0 kernel classes filein of stripped sources completed at 15/07/1996 22:48:49 ! ! On November 12, 1997, 6:34:31 pm ! ! ! SymbolDictionary 'CooperationContract' ! run | symList newDict | symList := System myUserProfile symbolList. symList do: [ :element | (element includesKey: #CooperationContract) ifTrue: [ ^element ] ]. newDict := SymbolDictionary new. newDict at: #CooperationContract put: newDict. System myUserProfile insertDictionary: newDict at: 1. ^newDict % doit (Object subclass: 'ObjectWithContracts' instVarNames: #() classVars: #() classInstVars: #( ParticipatesIn) poolDictionaries: #[] inDictionary: CooperationContract constraints: #[] instancesInvariant: false isModifiable: true) . % doit (Object subclass: 'CoopMsg' instVarNames: #() classVars: #() classInstVars: #() poolDictionaries: #[] inDictionary: CooperationContract constraints: #[] instancesInvariant: false isModifiable: true) . % doit (Object subclass: 'CoopContract' instVarNames: #( self1 self2) classVars: #() classInstVars: #( ContractName PartnerClass1 PartnerClass2) poolDictionaries: #[] inDictionary: CooperationContract constraints: #[] instancesInvariant: false isModifiable: true) . % doit ObjectWithContracts immediateInvariant. % doit CoopMsg immediateInvariant. % doit CoopContract immediateInvariant. % ! Remove existing behavior from ObjectWithContracts doit ObjectWithContracts removeAllMethods. ObjectWithContracts class removeAllMethods. % ! ------------------- Class methods for ObjectWithContracts category: 'Accessing' classmethod: ObjectWithContracts participatesIn " Return the value of class instance variable 'ParticipatesIn'. " ^ParticipatesIn % category: 'Contract Handling' classmethod: ObjectWithContracts addContract: aContractClass " Add contract 'aContractClass' to dictionary 'ParticipatesIn' under the contract name. The order in which contracts are stored in a dictionary entry is determined by a left-first-up traversal of the specialization hierarchy of contracts. " | class1 class2 contractName result | class1 := self. " is the same as first partnerclass! " class2 := aContractClass partnerClass2. contractName := aContractClass contractName. " Add the contract name as key if it has not already been defined. " (class1 participatesIn includesKey: contractName) ifFalse: [ class1 participatesIn at: contractName put: (OrderedCollection new) ]. " Add the contract and return it. " result := (class1 participatesIn at: contractName) select: [ :c | class2 isSubclassOf: (c partnerClass2) ]. result isEmpty ifTrue: [ (class1 participatesIn at: contractName) addLast: aContractClass ] ifFalse: [ (class1 participatesIn at: contractName) add: aContractClass before: (result first) ]. % category: 'Contract Handling' classmethod: ObjectWithContracts removeContract: aContractClass " Remove contract 'aContractClass' from the 'ParticipatesIn'-dictionary of the first participant (the receiver of this method). Raise an error if the specified contract class is not a contract. " | contractName | contractName := aContractClass contractName. " Check whether the contract exists. " ((self participatesIn at: contractName) includes: aContractClass) ifFalse: [ System signal: 5 args: #[ self name, contractName] signalDictionary: ContractErrors ]. " Remove the contract and the collection as a whole (if empty). " (self participatesIn at: contractName) remove: aContractClass. (self participatesIn at: contractName) isEmpty ifTrue: [ self participatesIn removeKey: contractName ]. % category: 'Subclass Creation' classmethod: ObjectWithContracts subclass: aString instVarNames: anArrayOfStrings classVars: anArrayOfClassVars classInstVars: anArrayOfClassInstVars poolDictionaries: anArrayOfPoolDicts inDictionary: aDictionary constraints: aConstraint instancesInvariant: invarBoolean description: aDescription isModifiable: modifyBoolean " This method proceeds with the subclass creation by the superclass and sets class instance variable 'ParticiptesIn' of the new subclass to a new dictionary. " | result | result := super subclass: aString instVarNames: anArrayOfStrings classVars: anArrayOfClassVars classInstVars: anArrayOfClassInstVars poolDictionaries: anArrayOfPoolDicts inDictionary: aDictionary constraints: aConstraint instancesInvariant: invarBoolean description: aDescription isModifiable: modifyBoolean. result atClassInstVar: #ParticipatesIn put: (Dictionary new). ^result % category: 'Subclass Creation' classmethod: ObjectWithContracts subclass: aString instVarNames: anArrayOfStrings classVars: anArrayOfClassVars classInstVars: anArrayOfClassInstVars poolDictionaries: anArrayOfPoolDicts inDictionary: aDictionary constraints: aConstraint instancesInvariant: invarBoolean isModifiable: modifyBoolean " This method proceeds with the subclass creation by the superclass and sets class instance variable 'ParticiptesIn' of the new subclass to a new dictionary. " | result | result := super subclass: aString instVarNames: anArrayOfStrings classVars: anArrayOfClassVars classInstVars: anArrayOfClassInstVars poolDictionaries: anArrayOfPoolDicts inDictionary: aDictionary constraints: aConstraint instancesInvariant: invarBoolean isModifiable: modifyBoolean. result atClassInstVar: #ParticipatesIn put: (Dictionary new). ^result % category: 'Subclass Creation' classmethod: ObjectWithContracts subclass: aString instVarNames: anArrayOfStrings classVars: anArrayOfClassVars classInstVars: anArrayOfClassInstVars poolDictionaries: anArrayOfPoolDicts inDictionary: aDictionary constraints: aConstraint instancesInvariant: invarBoolean newVersionOf: anOldClass description: aDescription isModifiable: modifyBoolean " This method proceeds with the subclass creation by the superclass and sets class instance variable 'ParticiptesIn' of the new subclass to a new dictionary. " | result | result := super subclass: aString instVarNames: anArrayOfStrings classVars: anArrayOfClassVars classInstVars: anArrayOfClassInstVars poolDictionaries: anArrayOfPoolDicts inDictionary: aDictionary constraints: aConstraint instancesInvariant: invarBoolean newVersionOf: anOldClass description: aDescription isModifiable: modifyBoolean. result atClassInstVar: #ParticipatesIn put: (Dictionary new). ^result % ! ------------------- Instance methods for ObjectWithContracts ! Remove existing behavior from CoopMsg doit CoopMsg removeAllMethods. CoopMsg class removeAllMethods. % ! ------------------- Class methods for CoopMsg category: 'Method Execution' classmethod: CoopMsg on: anObject1 and: anObject2 using: aContractName " Find the most specific contract, create a new instance of it, and return it for method execution. " | contractClass | contractClass := CoopContract getMostSpecContract: aContractName between: (anObject1 class) and: (anObject2 class). " Check whether the contract exists. " (contractClass isNil) ifTrue: [ System signal: 5 args: #[ anObject1 class name, anObject2 class name, aContractName ] signalDictionary: ContractErrors ]. ^(contractClass new) self1: anObject1; self2: anObject2 % ! ------------------- Instance methods for CoopMsg ! Remove existing behavior from CoopContract doit CoopContract removeAllMethods. CoopContract class removeAllMethods. % ! ------------------- Class methods for CoopContract category: 'Accessing' classmethod: CoopContract contractName " Return the value of class instance variable 'ContractName'. " ^ContractName % category: 'Accessing' classmethod: CoopContract partnerClass1 " Return the value of class instance variable 'PartnerClass1'. " ^PartnerClass1 % category: 'Accessing' classmethod: CoopContract partnerClass2 " Return the value of class instance variable 'PartnerClass2'. " ^PartnerClass2 % category: 'Contract Handling' classmethod: CoopContract defineContract: aContractName between: aClass1 and: aClass2 " Define and return a new contract between the two classes as a subclass of 'CoopContract' and inform the first partner class about the new contract. Report an error if the first partner class is not a subclass of 'ObjectWithContracts', if a contract with the given name already exists bewteen the two classes, or if there is already a class with the same name. " | contractClass contractName | contractName := aContractName + (aClass1 name) + (aClass2 name). " Check that the first partner class is a subclass of 'ObjectWithContracts'. " (aClass1 isSubclassOf: ObjectWithContracts) ifFalse: [ System signal: 1 args: #[aClass1 name] signalDictionary: ContractErrors ]. " Check whether a contract with the same name already exists. " ((aClass1 participatesIn at: aContractName otherwise: #[]) detect: [ :c | c partnerClass2 == aClass2 ] ifNone: [ nil ]) notNil ifTrue: [ System signal: 2 args: #[aClass1 name, aClass2 name, aContractName] signalDictionary: ContractErrors ]. " Check that there is not any class with the same name. " (System myUserProfile resolveSymbol: contractName) notNil ifTrue: [ System signal: 3 args: #[contractName asSymbol] signalDictionary: ContractErrors ]. " Create new subclass of 'CoopContract'. " contractClass := CoopContract subclass: contractName instVarNames: #() classVars: #() classInstVars: #() poolDictionaries: #[] inDictionary: CooperationContract constraints: #[] instancesInvariant: false isModifiable: false. contractClass contractName: aContractName; partnerClass1: aClass1; partnerClass2: aClass2. " Tell the first partner class to add the contract. " aClass1 addContract: contractClass. ^contractClass % category: 'Contract Handling' classmethod: CoopContract deleteContract " Inform the first partner class of the contract receiving this message to remove this contract from its 'ParticipatesIn'-dictionary and remove the contract from the symbol-list dictionary. " | dict sym | self partnerClass1 removeContract: self. dict:=(System myUserProfile dictionaryAndSymbolOf: self) at: 1. sym :=(System myUserProfile dictionaryAndSymbolOf: self) at: 2. dict removeKey: sym. % category: 'Contract Handling' classmethod: CoopContract deleteContract: aContractName between: aClass1 and: aClass2 " Find the appropriate contract and delete it. " ^(self getContract: aContractName between: aClass1 and: aClass2) deleteContract % category: 'Contract Handling' classmethod: CoopContract getContract: aContractName between: aClass1 and: aClass2 " Return the contract with name 'aContractName' defined between partner classes 'aClass1' and 'aClass2'. Return nil if no appropriate contract is found. Report an error if the first partner class is not a subclass of 'ObjectWithContracts' or if the contract name does not exist for the first partner class. " " Check that the first partner class is a subclass of 'ObjectWithContracts'. " (aClass1 isSubclassOf: ObjectWithContracts) ifFalse: [ System signal: 1 args: #[aClass1 name] signalDictionary: ContractErrors ]. " Check that the contract name exists for the first partner class. " (aClass1 participatesIn includesKey: aContractName) ifFalse: [ System signal: 4 args: #[aClass1 name, aContractName] signalDictionary: ContractErrors ]. " Return the appropriate contract or nil if there is none. " ^(aClass1 participatesIn at: aContractName) detect: [ :c | c partnerClass2 == aClass2] ifNone: [ nil ] % category: 'Contract Handling' classmethod: CoopContract getMostSpecContract: aContractName between: aClass1 and: aClass2 " Return the most specific contract between the first and the second partner class. Return nil if no appropriate contract is found. " | class1 contractClass | " Search for the most specific contract by looking up the 'ParticipatesIn'-dictionary of the first partner class. Note: In GemStone Smalltalk each class is also subclass of itself. As the collections under each dictionary entry are ordered, the first contract detected is the most specific one. " class1 := aClass1. [ contractClass := (class1 participatesIn at: aContractName otherwise: #[]) detect: [ :c | aClass2 isSubclassOf: (c partnerClass2) ] ifNone: [ nil ]. " Proceed next run with superclass of actual partner class one. " class1 := class1 superClass. (contractClass ~= nil) | (class1 == ObjectWithContracts) ] untilTrue. ^contractClass % category: 'Contract Handling' classmethod: CoopContract getMostSpecContract: aContractName between: aClass1 and: aClass2 thatUnderstands: aSelector " Return the most specific contract understanding 'aSelector' between the first and the second partner class. Return nil if no appropriate contract is found. " | class1 contractClass | " Search for the most specific contract understanding 'aSelector' by looking up the 'ParticipatesIn'-dictionary of the first partner class. Note: In GemStone Smalltalk each class is also subclass of itself. As this list is ordered, the first contract detected is the most specific one. " class1 := aClass1. [ contractClass :=(class1 participatesIn at: aContractName otherwise: #[]) detect: [ :c | (aClass2 isSubclassOf: (c partnerClass2)) & (c canUnderstand: aSelector) ] ifNone: [ nil ]. " Proceed next run with superclass of actual partner class one. " class1 := class1 superClass. (contractClass ~= nil) | (class1 == ObjectWithContracts) ] untilTrue. ^contractClass % category: 'Method Definition' classmethod: CoopContract addMethod: aSourceString " Add the specified cooperative method to the cooperation contract. " ^self compileMethod: aSourceString dictionaries: (System myUserProfile symbolList) category: 'Cooperative Methods'. % category: 'Updating' classmethod: CoopContract contractName: aContractName " Modify the value of class instance variable 'ContractName'. " self atClassInstVar: #ContractName put: aContractName % category: 'Updating' classmethod: CoopContract partnerClass1: aClass " Modify the value of class instance variable 'PartnerClass1'. " self atClassInstVar: #PartnerClass1 put: aClass % category: 'Updating' classmethod: CoopContract partnerClass2: aClass " Modify the value of class instance variable 'PartnerClass2'. " self atClassInstVar: #PartnerClass2 put: aClass % ! ------------------- Instance methods for CoopContract category: 'Accessing' method: CoopContract self1 " Return the value of instance variable 'self1'. " ^self1 % category: 'Accessing' method: CoopContract self2 " Return the value of instance variable 'self2'. " ^self2 % category: 'Error Handling' method: CoopContract doesNotUnderstand: aMessageDescriptor " Find the next specific contract understanding the message, instantiate it, and proceed with the method execution. If there is no appropriate contract, raise an error. " | selector args contractClass | selector := aMessageDescriptor at: 1. args := aMessageDescriptor at: 2. contractClass := CoopContract getMostSpecContract: (self class contractName) between: (self1 class) and: (self2 class) thatUnderstands: selector. " Raise an error if no contract can understand the message. Otherwise create an instance of the contract, set 'self1' and 'self2', and perform the method on this one. " contractClass isNil ifTrue: [ System signal: 2010 args: #[self,selector,args] signalDictionary: GemStoneError ] ifFalse: [ ^(contractClass new) self1: self1; self2: self2; perform: selector withArguments: args ] % category: 'Updating' method: CoopContract self1: anObject " Modify the value of instance variable 'self1'. " self1 := anObject % category: 'Updating' method: CoopContract self2: anObject " Modify the value of instance variable 'self2'. " self2 := anObject %