--- a/ChangeSet.st Thu May 18 09:17:45 2000 +0200
+++ b/ChangeSet.st Mon May 22 14:00:59 2000 +0200
@@ -46,6 +46,380 @@
!ChangeSet class methodsFor:'instance creation'!
+changesFromParseTree:aTree andStream:aStream do:aBlock
+ "given a parse-tree (from parsing some changes source/chunk),
+ create changes and evaluate aBlock on each.
+ The block is invoked with the change and a lineNumberOrNil as
+ arg; the lineNumber is only valid, if the underlying stream
+ provides line-numbers; otherwise, nil is passed."
+
+ |changes sel className categoryName
+ methodSource methodSelector change parser
+ oldName newName priv receiver receiverVarName
+ receiverSelector receiverReceiver primSource
+ nameSpace lineNumberOrNil|
+
+ lineNumberOrNil := aStream lineNumber.
+
+"/ nameSpace := Class nameSpaceQuerySignal query.
+"/ nameSpace isNil ifTrue:[nameSpace := Smalltalk].
+
+ sel := aTree selector.
+ receiver := aTree receiver.
+ receiver isMessage ifTrue:[
+ receiverSelector := receiver selector.
+ receiverReceiver := receiver receiver.
+ ] ifFalse:[
+ receiver isVariable ifTrue:[
+ receiverVarName := receiver name
+ ]
+ ].
+
+ (sel == #'methodsFor:'
+ or:[(sel == #'ignoredMethodsFor:')]) ifTrue:[
+ (sel == #'ignoredMethodsFor:') ifTrue:[
+ priv := #ignored.
+ ] ifFalse:[
+ priv := nil
+ ].
+ (receiver isUnaryMessage
+ and:[receiverSelector == #class]) ifTrue:[
+ className := (receiverReceiver name) , ' class'.
+ ] ifFalse:[
+ className := (receiver name).
+ ].
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+ categoryName := (aTree arguments at:1) evaluate.
+
+ aStream skipSeparators.
+ lineNumberOrNil := aStream lineNumber.
+ methodSource := aStream nextChunk.
+ changes := OrderedCollection new.
+
+ [methodSource notEmpty] whileTrue:[
+ parser := Parser
+ parseMethodArgAndVarSpecification:methodSource
+ in:nil
+ ignoreErrors:true
+ ignoreWarnings:true
+ parseBody:false.
+
+ parser isNil ifTrue:[
+ "/ something wierd ...
+ methodSelector := '????'.
+ ] ifFalse:[
+ methodSelector := parser selector.
+ ].
+
+ change := MethodChange new.
+ change
+ className:className
+ selector:methodSelector
+ source:methodSource
+ category:categoryName
+ privacy:priv.
+ aBlock value:change value:lineNumberOrNil.
+
+ aStream skipSeparators.
+ lineNumberOrNil := aStream lineNumber.
+ methodSource := aStream nextChunk.
+ ].
+ ^ true
+ ].
+
+ sel == #'removeSelector:' ifTrue:[
+ (receiver isUnaryMessage
+ and:[receiverSelector == #class]) ifTrue:[
+ className := (receiverReceiver name) , ' class'.
+ ] ifFalse:[
+ className := (receiver name).
+ ].
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+ methodSelector := (aTree arguments at:1) evaluate.
+ change := MethodRemoveChange new.
+ change
+ className:className
+ selector:methodSelector.
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ].
+
+ "/ any subclass definiton selector ?
+ (Behavior definitionSelectors includes:sel)
+ ifTrue:[
+ className := (aTree arguments at:1) evaluate.
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+ change := ClassDefinitionChange new.
+ change
+ className:className;
+ source:(aTree printString).
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ].
+
+ sel == #'renameCategory:to:' ifTrue:[
+ (receiver isUnaryMessage
+ and:[receiverSelector == #class]) ifTrue:[
+ className := (receiverReceiver name) , ' class'.
+ ] ifFalse:[
+ className := (receiver name).
+ ].
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+ change := MethodCategoryRenameChange new.
+ change
+ className:className;
+ oldCategoryName:(aTree arguments at:1) evaluate
+ newCategoryName:(aTree arguments at:2) evaluate.
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ].
+
+ (sel == #'category:'
+ or:[sel == #'privacy:']) ifTrue:[
+ (receiver isMessage
+ and:[receiverSelector == #'compiledMethodAt:']) ifTrue:[
+ (receiverReceiver isUnaryMessage
+ and:[receiverReceiver selector == #class]) ifTrue:[
+ className := (receiverReceiver receiver name) , ' class'.
+ ] ifFalse:[
+ className := (receiverReceiver name).
+ ].
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+ methodSelector := (receiver arguments at:1) evaluate.
+
+ sel == #'category:' ifTrue:[
+ change := MethodCategoryChange new.
+ change
+ className:className
+ selector:methodSelector
+ category:(aTree arguments at:1) evaluate.
+ ] ifFalse:[
+ change := MethodPrivacyChange new.
+ change
+ className:className
+ selector:methodSelector
+ privacy:(aTree arguments at:1) evaluate.
+ ].
+
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ] ifFalse:[
+ self halt:'unexpected change'
+ ].
+ ].
+
+ sel == #'comment:' ifTrue:[
+ (receiver isUnaryMessage
+ and:[receiverSelector == #class]) ifTrue:[
+ className := (receiverReceiver name) , ' class'.
+ ] ifFalse:[
+ className := (receiver name).
+ ].
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+
+ change := ClassCommentChange new.
+ change
+ className:className
+ comment:(aTree arguments at:1) evaluate.
+ change source:(aTree printString).
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ].
+
+ sel == #'instanceVariableNames:' ifTrue:[
+ (receiver isUnaryMessage
+ and:[receiverSelector == #class]) ifTrue:[
+ className := (receiverReceiver name) , ' class'.
+ ] ifFalse:[
+ className := (receiver name).
+ ].
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+ change := ClassInstVarDefinitionChange new.
+ change className:className.
+ change source:(aTree printString).
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ].
+
+ sel == #'removeClass:' ifTrue:[
+ (receiverVarName == #Smalltalk) ifTrue:[
+ className := (aTree arguments at:1) name.
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+
+ change := ClassRemoveChange new.
+ change className:className.
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ] ifFalse:[
+ self halt
+ ].
+ ].
+
+ sel == #'renameClass:to:' ifTrue:[
+ (receiverVarName == #Smalltalk) ifTrue:[
+ oldName := (aTree arguments at:1) name.
+ newName := (aTree arguments at:2) evaluate.
+
+ change := ClassRenameChange new.
+ change oldName:oldName newName:newName.
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ] ifFalse:[
+ self halt
+ ].
+ ].
+
+ sel == #'name:' ifTrue:[
+ ((receiverVarName == #Namespace)
+ or:[receiverVarName == #NameSpace]) ifTrue:[
+ className := (aTree arguments at:1) evaluate.
+
+ change := NameSpaceCreationChange new.
+ change name:className.
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ] ifFalse:[
+ self halt
+ ].
+ ].
+
+ (sel == #'primitiveDefinitions'
+ or:[sel == #'primitiveFunctions'
+ or:[sel == #'primitiveVariables']]) ifTrue:[
+ (receiver isUnaryMessage
+ and:[receiverSelector == #class]) ifTrue:[
+ className := (receiverReceiver name) , ' class'.
+ ] ifFalse:[
+ className := (receiver name).
+ ].
+"/ nameSpace ~~ Smalltalk ifTrue:[
+"/ className := nameSpace name , '::' , className
+"/ ].
+
+ aStream skipSeparators.
+ primSource := aStream nextChunk.
+
+ sel == #'primitiveDefinitions' ifTrue:[
+ change := ClassPrimitiveDefinitionsChange new
+ ] ifFalse:[
+ sel == #'primitiveFunctions' ifTrue:[
+ change := ClassPrimitiveFunctionsChange new
+ ] ifFalse:[
+ change := ClassPrimitiveVariablesChange new
+ ]
+ ].
+ change class:className source:primSource.
+ aBlock value:change value:lineNumberOrNil.
+ ^ true
+ ].
+
+ ^ false
+
+ "Created: / 16.2.1998 / 13:42:40 / cg"
+ "Modified: / 15.12.1999 / 00:29:06 / cg"
+
+
+!
+
+changesFromStream:aStream do:aBlock
+ "enumerate changes from a stream and invoke aBlock on each.
+ The block is invoked with the change and a lineNumberOrNil as
+ arg; the lineNumber is only valid, if the underlying stream
+ provides line-numbers; otherwise, nil is passed."
+
+ |chunk sawExcla lastTimeStamp s change nameSpace changes
+ lineNumber|
+
+ nameSpace := Smalltalk.
+
+ [aStream atEnd] whileFalse:[
+ aStream skipSeparators.
+ sawExcla := aStream peekFor:$!!.
+ lineNumber := aStream lineNumber.
+ chunk := aStream nextChunk.
+ (chunk notNil and:[chunk notEmpty]) ifTrue:[
+ Class nameSpaceQuerySignal answer:nameSpace do:[
+ |parser tree ns|
+
+ parser := Parser for:chunk.
+ tree := parser
+ parseExpressionWithSelf:nil
+ notifying:nil
+ ignoreErrors:true
+ ignoreWarnings:true
+ inNameSpace:nameSpace.
+
+ tree == #Error ifTrue:[
+ change := DoItChange new.
+ change source:chunk.
+ aBlock value:change value:lineNumber.
+ ] ifFalse:[
+ (tree notNil and:[tree ~~ #Error]) ifTrue:[
+ "/ if there is any nameSpace directive in there, extract it.
+ ((ns := parser currentNameSpace) notNil
+ and:[ns ~~ nameSpace]) ifTrue:[
+ "/ self halt.
+ nameSpace := ns
+ ].
+ Class nameSpaceQuerySignal answer:nameSpace do:[
+ "/
+ "/ what type of chunk is this ...
+ "/
+ tree isConstant ifTrue:[
+ (s := tree evaluate) isString ifTrue:[
+ (s startsWith:'---- timestamp ') ifTrue:[
+ lastTimeStamp := s.
+ ]
+ ] ifFalse:[
+ self halt:'unexpected change-chunk'
+ ]
+ ] ifFalse:[
+ tree isMessage ifTrue:[
+ (self
+ changesFromParseTree:tree
+ andStream:aStream
+ do:aBlock) ifFalse:[
+ change := DoItChange new.
+ change source:chunk.
+ aBlock value:change value:lineNumber.
+ ]
+ ] ifFalse:[
+ self halt:'unexpected change-chunk'
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "
+ ChangeSet fromStream:('changes' asFilename readStream)
+ ChangeSet fromStream:('patches' asFilename readStream)
+ ChangeSet fromStream:(Object source asString readStream)
+ "
+
+ "Created: / 16.2.1998 / 12:19:34 / cg"
+ "Modified: / 14.12.1999 / 15:23:16 / cg"
+!
+
forExistingClass:aClass
"build a changeSet for some given class.
That does of course not give deltas, but instead reflects the current
@@ -94,68 +468,13 @@
(i.e. either a classes sourceFile or a change-file).
Return the changeSet."
- |changeSet chunk sawExcla lastTimeStamp s change nameSpace|
+ |changeSet|
changeSet := self new.
- nameSpace := Smalltalk.
-
- [aStream atEnd] whileFalse:[
- aStream skipSeparators.
- sawExcla := aStream peekFor:$!!.
- chunk := aStream nextChunk.
- (chunk notNil and:[chunk notEmpty]) ifTrue:[
- Class nameSpaceQuerySignal answer:nameSpace do:[
- |parser tree ns|
-
- parser := Parser for:chunk.
- tree := parser
- parseExpressionWithSelf:nil
- notifying:nil
- ignoreErrors:true
- ignoreWarnings:true
- inNameSpace:nameSpace.
+ self changesFromStream:aStream do:[:aChange :lineNumberOrNil |
+ changeSet add:aChange
+ ].
- tree == #Error ifTrue:[
- change := DoItChange new.
- change source:chunk.
- changeSet add: change.
- ] ifFalse:[
- (tree notNil and:[tree ~~ #Error]) ifTrue:[
- "/ if there is any nameSpace directive in there, extract it.
- ((ns := parser currentNameSpace) notNil
- and:[ns ~~ nameSpace]) ifTrue:[
- "/ self halt.
- nameSpace := ns
- ].
- Class nameSpaceQuerySignal answer:nameSpace do:[
- "/
- "/ what type of chunk is this ...
- "/
- tree isConstant ifTrue:[
- (s := tree evaluate) isString ifTrue:[
- (s startsWith:'---- timestamp ') ifTrue:[
- lastTimeStamp := s.
- ]
- ] ifFalse:[
- self halt:'unexpected change-chunk'
- ]
- ] ifFalse:[
- tree isMessage ifTrue:[
- (changeSet addFromParseTree:tree andStream:aStream) ifFalse:[
- change := DoItChange new.
- change source:chunk.
- changeSet add: change.
- ]
- ] ifFalse:[
- self halt:'unexpected change-chunk'
- ]
- ]
- ]
- ]
- ]
- ]
- ]
- ].
^ changeSet
"
@@ -381,283 +700,17 @@
addFromParseTree:aTree andStream:aStream
"given a parse-tree (from parsing some changes source/chunk),
- create a change and add it to the changeSet"
-
- |sel className categoryName
- methodSource methodSelector change parser
- oldName newName priv receiver receiverVarName
- receiverSelector receiverReceiver primSource
- nameSpace|
-
-"/ nameSpace := Class nameSpaceQuerySignal query.
-"/ nameSpace isNil ifTrue:[nameSpace := Smalltalk].
-
- sel := aTree selector.
- receiver := aTree receiver.
- receiver isMessage ifTrue:[
- receiverSelector := receiver selector.
- receiverReceiver := receiver receiver.
- ] ifFalse:[
- receiver isVariable ifTrue:[
- receiverVarName := receiver name
- ]
- ].
-
- (sel == #'methodsFor:'
- or:[(sel == #'ignoredMethodsFor:')]) ifTrue:[
- (sel == #'ignoredMethodsFor:') ifTrue:[
- priv := #ignored.
- ] ifFalse:[
- priv := nil
- ].
- (receiver isUnaryMessage
- and:[receiverSelector == #class]) ifTrue:[
- className := (receiverReceiver name) , ' class'.
- ] ifFalse:[
- className := (receiver name).
- ].
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
- categoryName := (aTree arguments at:1) evaluate.
-
- aStream skipSeparators.
- methodSource := aStream nextChunk.
- [methodSource notEmpty] whileTrue:[
- parser := Parser
- parseMethodArgAndVarSpecification:methodSource
- in:nil
- ignoreErrors:true
- ignoreWarnings:true
- parseBody:false.
-
- parser isNil ifTrue:[
- "/ something wierd ...
- methodSelector := '????'.
- ] ifFalse:[
- methodSelector := parser selector.
- ].
-
- change := MethodChange new.
- change
- className:className
- selector:methodSelector
- source:methodSource
- category:categoryName
- privacy:priv.
- self add: change.
-
- aStream skipSeparators.
- methodSource := aStream nextChunk.
- ].
- ^ true
- ].
-
- sel == #'removeSelector:' ifTrue:[
- (receiver isUnaryMessage
- and:[receiverSelector == #class]) ifTrue:[
- className := (receiverReceiver name) , ' class'.
- ] ifFalse:[
- className := (receiver name).
- ].
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
- methodSelector := (aTree arguments at:1) evaluate.
- change := MethodRemoveChange new.
- change
- className:className
- selector:methodSelector.
- self add: change.
- ^ true
- ].
-
- "/ any subclass definiton selector ?
- (Behavior definitionSelectors includes:sel)
- ifTrue:[
- className := (aTree arguments at:1) evaluate.
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
- change := ClassDefinitionChange new.
- change
- className:className;
- source:(aTree printString).
- self add: change.
- ^ true
- ].
-
- sel == #'renameCategory:to:' ifTrue:[
- (receiver isUnaryMessage
- and:[receiverSelector == #class]) ifTrue:[
- className := (receiverReceiver name) , ' class'.
- ] ifFalse:[
- className := (receiver name).
- ].
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
- change := MethodCategoryRenameChange new.
- change
- className:className;
- oldCategoryName:(aTree arguments at:1) evaluate
- newCategoryName:(aTree arguments at:2) evaluate.
- self add: change.
- ^ true
- ].
+ create changes and add them to the changeSet.
+ (usually only one, except for multiple methodsFor: changes,
+ which are not encountered in normal change files.)"
- (sel == #'category:'
- or:[sel == #'privacy:']) ifTrue:[
- (receiver isMessage
- and:[receiverSelector == #'compiledMethodAt:']) ifTrue:[
- (receiverReceiver isUnaryMessage
- and:[receiverReceiver selector == #class]) ifTrue:[
- className := (receiverReceiver receiver name) , ' class'.
- ] ifFalse:[
- className := (receiverReceiver name).
- ].
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
- methodSelector := (receiver arguments at:1) evaluate.
-
- sel == #'category:' ifTrue:[
- change := MethodCategoryChange new.
- change
- className:className
- selector:methodSelector
- category:(aTree arguments at:1) evaluate.
- ] ifFalse:[
- change := MethodPrivacyChange new.
- change
- className:className
- selector:methodSelector
- privacy:(aTree arguments at:1) evaluate.
- ].
-
- self add: change.
- ^ true
- ] ifFalse:[
- self halt:'unexpected change'
+ ^ self class
+ changesFromParseTree:aTree andStream:aStream
+ do:[:aChange :lineNumberOrNil |
+ self add:aChange.
].
- ].
-
- sel == #'comment:' ifTrue:[
- (receiver isUnaryMessage
- and:[receiverSelector == #class]) ifTrue:[
- className := (receiverReceiver name) , ' class'.
- ] ifFalse:[
- className := (receiver name).
- ].
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
-
- change := ClassCommentChange new.
- change
- className:className
- comment:(aTree arguments at:1) evaluate.
- change source:(aTree printString).
- self add: change.
- ^ true
- ].
-
- sel == #'instanceVariableNames:' ifTrue:[
- (receiver isUnaryMessage
- and:[receiverSelector == #class]) ifTrue:[
- className := (receiverReceiver name) , ' class'.
- ] ifFalse:[
- className := (receiver name).
- ].
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
- change := ClassInstVarDefinitionChange new.
- change className:className.
- change source:(aTree printString).
- self add: change.
- ^ true
- ].
- sel == #'removeClass:' ifTrue:[
- (receiverVarName == #Smalltalk) ifTrue:[
- className := (aTree arguments at:1) name.
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
- change := ClassRemoveChange new.
- change className:className.
- self add: change.
- ^ true
- ] ifFalse:[
- self halt
- ].
- ].
-
- sel == #'renameClass:to:' ifTrue:[
- (receiverVarName == #Smalltalk) ifTrue:[
- oldName := (aTree arguments at:1) name.
- newName := (aTree arguments at:2) evaluate.
-
- change := ClassRenameChange new.
- change oldName:oldName newName:newName.
- self add: change.
- ^ true
- ] ifFalse:[
- self halt
- ].
- ].
-
- sel == #'name:' ifTrue:[
- ((receiverVarName == #Namespace)
- or:[receiverVarName == #NameSpace]) ifTrue:[
- className := (aTree arguments at:1) evaluate.
-
- change := NameSpaceCreationChange new.
- change name:className.
- self add: change.
- ^ true
- ] ifFalse:[
- self halt
- ].
- ].
-
- (sel == #'primitiveDefinitions'
- or:[sel == #'primitiveFunctions'
- or:[sel == #'primitiveVariables']]) ifTrue:[
- (receiver isUnaryMessage
- and:[receiverSelector == #class]) ifTrue:[
- className := (receiverReceiver name) , ' class'.
- ] ifFalse:[
- className := (receiver name).
- ].
-"/ nameSpace ~~ Smalltalk ifTrue:[
-"/ className := nameSpace name , '::' , className
-"/ ].
-
- aStream skipSeparators.
- primSource := aStream nextChunk.
-
- sel == #'primitiveDefinitions' ifTrue:[
- change := ClassPrimitiveDefinitionsChange new
- ] ifFalse:[
- sel == #'primitiveFunctions' ifTrue:[
- change := ClassPrimitiveFunctionsChange new
- ] ifFalse:[
- change := ClassPrimitiveVariablesChange new
- ]
- ].
- change class:className source:primSource.
- self add: change.
-
- ^ true
- ].
-
- ^ false
-
- "Created: / 16.2.1998 / 13:42:40 / cg"
- "Modified: / 15.12.1999 / 00:29:06 / cg"
! !
!ChangeSet methodsFor:'utilities'!
@@ -815,5 +868,5 @@
!ChangeSet class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic3/ChangeSet.st,v 1.45 2000-04-12 21:40:29 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic3/ChangeSet.st,v 1.46 2000-05-22 12:00:59 cg Exp $'
! !