'From Squeak3.7alpha of ''11 September 2003'' [latest update: #5623] on 19 January 2004 at 12:53:42 pm'! "Change Set: KCP-0142-SystemNotificationIntegration Date: 19 January 2004 Author: Nathanael SchŠrli First part of System Change Notification integration."! !ChangeHooksTest methodsFor: 'Events-Expression' stamp: 'NS 1/19/2004 09:56'! methodDoItEvent1: event "self run: #testDoItEvent1" self addSingleEvent: event. self checkEvent: event kind: #DoIt item: doItExpression itemKind: AbstractEvent expressionKind. self assert: event context isNil.! ! !ChangeHooksTest methodsFor: 'Events-Expression' stamp: 'NS 1/19/2004 09:56'! methodDoItEvent2: event "self run: #testDoItEvent2" self addSingleEvent: event. self checkEvent: event kind: #DoIt item: doItExpression itemKind: AbstractEvent expressionKind. self assert: event context isNil.! ! !ChangeSet methodsFor: 'change logging' stamp: 'NS 1/16/2004 16:35'! event: anEvent "Hook for SystemChangeNotifier" Transcript show: self name; show: ' '; show: anEvent; cr. (anEvent isRemoved and: [anEvent itemKind = #class]) ifTrue: [ anEvent item wantsChangeSetLogging ifTrue: [self noteRemovalOf: anEvent item]. ].! ! !Class methodsFor: 'initialize-release' stamp: 'NS 1/16/2004 15:16'! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." "tell class to deactivate and unload itself-- two separate events in the module system" self deactivate; unload. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self environment forgetClass: self logged: logged. self obsolete.! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'NS 1/16/2004 14:49'! newChanges: aChangeSet "Set the system ChangeSet to be the argument, aChangeSet. Tell the current project that aChangeSet is now its change set. When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital" SystemChangeNotifier uniqueInstance noMoreNotificationsFor: current. current isolationSet: nil. current _ aChangeSet. SystemChangeNotifier uniqueInstance notify: aChangeSet ofAllSystemChangesUsing: #event:. Smalltalk currentProjectDo: [:proj | proj setChangeSet: aChangeSet. aChangeSet isolationSet: proj isolationSet]! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/16/2004 16:56'! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass newClass organization instVars classVars force needNew oldSuper oldCategory oldInstVars | environ _ env. instVars _ Scanner new scanFieldNames: instVarString. classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. "Validate the proposed name" unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. oldClass _ env at: className ifAbsent:[nil]. oldClass isBehavior ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" oldClass isNil ifFalse: [oldInstVars := oldClass instVarNames]. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass" needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. needNew == nil ifTrue:[^nil]. "some error" (needNew and:[unsafe not]) ifTrue:[ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue:[ self error: oldClass name, ' cannot be changed'. ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ self notify: oldClass name asText allBold, ' should not be redefined!! \Proceed to store over it.' withCRs]]. oldClass isNil ifFalse: [oldSuper := oldClass superclass]. needNew ifTrue:[ "Create the new class" newClass _ self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. newClass == nil ifTrue:[^nil]. "Some error" newClass setName: className. ] ifFalse:[ "Reuse the old class" newClass _ oldClass. ]. "Install the class variables and pool dictionaries... " force _ (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." organization _ environ ifNotNil:[environ organization]. oldClass isNil ifFalse: [oldCategory := organization categoryOfElement: oldClass name]. organization classify: newClass name under: category asSymbol. newClass environment: environ. "... recompile ..." newClass _ self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ [environ at: newClass name put: newClass] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. Smalltalk flushClassNameCache. ]. self doneCompiling: newClass. oldClass == nil ifTrue: [SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: category asSymbol. ^newClass]. (oldClass ~= nil and: [oldSuper ~= newSuper]) ifTrue: [SystemChangeNotifier uniqueInstance class: newClass changedSuperclassFrom: oldSuper name.]. (needNew not and: [category asSymbol ~= oldCategory]) ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category asSymbol]. (oldInstVars = instVars) ifFalse: [self triggerInstVarChanges: instVars old: oldInstVars inClass: newClass]. ^newClass! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 10:00'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag "Compiles the sourceStream into a parse tree, then generates code into a method. This method is then installed in the receiver's class so that it can be invoked. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here as DoIt or (in the case of evaluation in aContext) DoItIn:. The method is subsequently removed from the class, but this will not get done if the invocation causes an error which is terminated. Such garbage can be removed by executing: Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: #DoItIn:]." | methodNode method value selector | class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode _ self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method _ methodNode generate: #(0 0 0 0). self interactive ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. selector _ context isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. SystemChangeNotifier uniqueInstance doSilently: [class addSelector: selector withMethod: method]. value _ context isNil ifTrue: [receiver DoIt] ifFalse: [receiver DoItIn: context]. InMidstOfFileinNotification signal ifFalse: [SystemChangeNotifier uniqueInstance doSilently: [class removeSelectorSimply: selector]]. logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. ^ value.! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 09:05'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock ^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false.! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 10:07'! evaluate: textOrString "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object, and the invocation is not logged." ^self evaluate: textOrString for: nil logged: false! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 09:50'! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." ^ self new evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil] logged: logFlag.! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'NS 1/19/2004 10:08'! evaluateSelection "Treat the current selection as an expression; evaluate it and return the result" | result rcvr ctxt | self lineSelectAndEmptyCheck: [^ '']. (model respondsTo: #doItReceiver) ifTrue: [FakeClassPool adopt: model selectedClass. "Include model pool vars if any" rcvr _ model doItReceiver. ctxt _ model doItContext] ifFalse: [rcvr _ ctxt _ nil]. result _ [ rcvr class evaluatorClass new evaluate: self selection string in: ctxt to: rcvr notifying: self ifFail: [FakeClassPool adopt: nil. ^ #failedDoit] logged: true. ] on: OutOfScopeNotification do: [ :ex | ex resume: true]. FakeClassPool adopt: nil. ^ result! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'NS 1/19/2004 09:52'! event: anEvent "Hook for SystemChangeNotifier" Transcript show: 'SmalltalkImage current'; show: ' '; show: anEvent; cr. (anEvent isRemoved and: [anEvent itemKind = #class]) ifTrue: [ anEvent item acceptsLoggingOfCompilation ifTrue: [self logChange: 'Smalltalk removeClassNamed: #' , anEvent item name]. ]. anEvent isDoIt ifTrue: [self logChange: anEvent item].! ! !SmalltalkImage class methodsFor: 'class initialization' stamp: 'NS 1/16/2004 16:12'! startUp SystemChangeNotifier uniqueInstance notify: self current ofAllSystemChangesUsing: #event:.! ! !SystemDictionary methodsFor: 'class names' stamp: 'NS 1/16/2004 16:15'! forgetClass: aClass logged: aBool "Delete the class, aClass, from the system, but log the removal neither to the current change set nor to the changes log. Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem." aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: aClass category]. SystemOrganization removeElement: aClass name. self removeFromStartUpList: aClass. self removeFromShutDownList: aClass. self removeKey: aClass name ifAbsent: []. self flushClassNameCache! ! SmalltalkImage class removeSelector: #startup! "Postscript: Add SmalltalkImage into the startup list" Smalltalk addToStartUpList: SmalltalkImage.!