'From Smalltalk-80, Version 2.3 of 13 June 1988 on 3 September 1988 at 9:50:51 pm'! View subclass: #AClockView instanceVariableNames: 'myProject date ' classVariableNames: 'NumberForms ' poolDictionaries: '' category: 'Interface-Clocks'! AClockView comment: 'I am the view of the ASCII clock - I display the date in my top view''s label tab and display the time in my insides. My instance variables are: the project I''m open in and, the date i have in my label'! !AClockView methodsFor: 'initialize-release'! initialize "set up the view's constants" super initialize. myProject _ Project current. date _ Date today! ! !AClockView methodsFor: 'displaying'! display "sent on update, check if my project is the current one." myProject == Project current ifTrue: [super display]! displayTimeAt: aPoint "update the time in the view with now's string" | str | str _ Time now printString. str _ str copyFrom: 1 to: (str size - 6). "remove seconds and am/pm" str asParagraph displayOn: Display at: aPoint clippingBox: self insetDisplayBox "put up the string"! displayView "called from the outside, check the date and update the time." | today | today _ Date today. date = today ifFalse: [date _ today. self topView newLabel: today printString]. super displayView. self topView isCollapsed ifFalse: [self displayTimeAt: ((self insetDisplayBox origin) + (16 @ 1))] "Magic numbers"! ! !AClockView methodsFor: 'controller access'! defaultControllerClass ^ClockController! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AClockView class instanceVariableNames: ''! AClockView class comment: 'I am the view of the ASCII clock - I hold the date in my label tab and display the time in my insides. My instance variables are: the project i''m open in and, the date i have in my label'! !AClockView class methodsFor: 'instance creation'! open "open an ASCII clock view and start the controller." "AClockView open" | topView insideView | topView _ StandardSystemView new. topView label: Date today printString. topView borderWidth: 2. topView insideColor: Form white. topView minimumSize: ('XX:XX' asParagraph boundingBox corner + (32@8)). "Magic Numbers... (system and font dependent)" insideView _ self new. topView addSubView: insideView. topView controller open! ! PopUpMenu subclass: #ActionMenu instanceVariableNames: 'selectors ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! ActionMenu comment: 'ActionMenus carry an array of selectors which correspond to the listed menu items. This allows a menu to stand alone in parameterizing a controller, since the controller just sends the selector to its model. This saves maintaining two parallel structures, one for the names in the menu, and one for the selectors to be performed. ActionMenus allow the pluggable views experiment (TextView, SelectionInListView) to handle menus much easier than having pairs of variables for the menu and its associated selectors. Obviously these menus eagerly await a proper objectification of protocol.'! !ActionMenu methodsFor: 'action symbols'! selectorAt: index ^ selectors at: index! setSelectors: selArray selectors _ selArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActionMenu class instanceVariableNames: ''! ActionMenu class comment: 'This subclass of PopUpMenu carries a list of selectors corresponding to the various menu items. Therefore, with only the menu as a parameter, a controller can display the menu and then tell its model to perform the associated selector. This saves maintaining two parallel structures, one for the names in the menu, and one for the selectors to be performed.'! !ActionMenu class methodsFor: 'instance creation'! labelList: anArray selectors: selArray "Answer a menu with lables from anArray and selectors from selArray." |menu| menu _ self labelList: anArray. menu setSelectors: selArray. ^menu! labels: aString lines: anArray selectors: selArray "Answer a menu with lables from aString lines form anArray and selectors from selArray." | aMenu | aMenu _ self labels: aString lines: anArray. aMenu setSelectors: selArray. ^ aMenu! labels: aString selectors: selArray "Answer a menu with lables from aString and selectors from selArray." ^ self labels: aString lines: nil selectors: selArray! ! !ActionMenu class methodsFor: 'confirmation'! confirm "ActionMenu confirm" ^ (ActionMenu labels: 'confirm\abort' withCRs selectors: nil) startUp = 1! ! CodeController subclass: #AlwaysAcceptCodeController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! AlwaysAcceptCodeController comment: 'I am a code controller that will do an accept even if the text is the same.'! !AlwaysAcceptCodeController methodsFor: 'menu messages'! accept (model changeRequestFrom: view) ifFalse: [^view flash]. self controlTerminate. (view accept: self text from: self) ifTrue: [initialText _ paragraph text copy] ifFalse: [view flash]. self controlInitialize! ! Path subclass: #Arc instanceVariableNames: 'quadrant radius center ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! Arc comment: 'Class Arc represents a quarter of a Circle, the quadrant is specified by 1, 2, 3 or 4 points which indicate which part of the circle is to be displayed. Quadrants are numbered 1 - 4 counter clockwise. Instance Variables: quadrant 1 - 4 representing a part of the circle radius length of the Circle radius center position at the center of the Circle'! !Arc methodsFor: 'accessing'! center "Answer the point at the center of the receiver." ^center! center: aPoint "Set aPoint to be the receiver's center." center _ aPoint! center: aPoint radius: anInteger "The receiver is defined by a point at the center and a radius. The quadrant is not reset." center _ aPoint. radius _ anInteger! center: aPoint radius: anInteger quadrant: section "The receiver is an Arc for the quadrant specified by section. The size of the arc is defined by the center and its radius." center _ aPoint. radius _ anInteger. quadrant _ section! quadrant "Answer the section of a circle represented by the receiver." ^quadrant! quadrant: section "Set section to be the part of the circle represented by the receiver." quadrant _ section! radius "Answer the receiver's radius." ^radius! radius: anInteger "Set anInteger to be the receiver's radius." radius _ anInteger! ! !Arc methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Display the receiver on the display medium aDisplayMedium positioned at aDisplayPoint within the rectangle clipRectangle and with the rule, ruleInteger, and mask, aForm. " | nSegments line angle sin cos xn yn xn1 yn1 | nSegments _ 12.0. line _ Line new. line form: self form. angle _ 90.0 / nSegments. sin _ (angle * (2 * Float pi / 360.0)) sin. cos _ (angle * (2 * Float pi / 360.0)) cos. quadrant = 1 ifTrue: [xn _ radius asFloat. yn _ 0.0]. quadrant = 2 ifTrue: [xn _ 0.0. yn _ 0.0 - radius asFloat]. quadrant = 3 ifTrue: [xn _ 0.0 - radius asFloat. yn _ 0.0]. quadrant = 4 ifTrue: [xn _ 0.0. yn _ radius asFloat]. nSegments truncated timesRepeat: [xn1 _ xn * cos + (yn * sin). yn1 _ yn * cos - (xn * sin). line beginPoint: center + (xn truncated @ yn truncated). line endPoint: center + (xn1 truncated @ yn1 truncated). line displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm. xn _ xn1. yn _ yn1]! ! !Arc methodsFor: 'transforming'! scaleBy: aPoint "Answers with a new Arc scaled by aPoint. Does not effect the current data in this Arc." | newArc tempCenter | newArc _ super scaleBy: aPoint. newArc center: self center. newArc radius: (self radius * aPoint x) truncated. newArc quadrant: self quadrant. ^newArc! translateBy: aPoint "Answers with a new instance of Arc whose elements are translated by aPoint. Does not effect the elements of this Arc." | newArc | newArc _ super translateBy: aPoint. newArc center: (self center x + aPoint x) @ (self center y + aPoint y). newArc radius: self radius. newArc quadrant: self quadrant. ^newArc! ! !Arc methodsFor: 'display box access'! computeBoundingBox | origin | quadrant = 1 ifTrue: [origin _ center - (0 @ radius)]. quadrant = 2 ifTrue: [origin _ center]. quadrant = 3 ifTrue: [origin _ center - (radius @ 0)]. quadrant = 4 ifTrue: [origin _ center - (radius @ radius)]. ^Rectangle origin: origin + form offset extent: radius @ radius + form extent! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Arc class instanceVariableNames: ''! !Arc class methodsFor: 'examples'! arcDraw "Click the button somewhere on the screen. The designated point will be the center of an Arc with radius 50 in the 4th quadrant." "Arc arcDraw." | anArc aForm | aForm _ Form new extent: 1 @ 30. "make a long thin Form for display" aForm black. "turn it black" anArc _ Arc new. anArc form: aForm. "set the form for display" anArc radius: 50.0. anArc center: Sensor waitButton. anArc quadrant: 4. anArc displayOn: Display. Sensor waitButton! ! ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! Array comment: 'Clas Array represents SequenceableCollections whose elements are any objects. It provides the concrete representation for storing a collection of elements that have integers as external keys. Instance Variables: *indexed*'! !Array methodsFor: 'converting'! asArray "Answer the receiver itself." ^self! ! !Array methodsFor: 'printing'! isLiteral "Answer whether all the elements of the array are literal." self detect: [:element | element isLiteral not] ifNone: [^true]. ^false! printOn: aStream "Append to the argument, aStream, the elements of the Array enclosed by parentheses." | tooMany | tooMany _ aStream position + self maxPrint. aStream nextPut: $(. self do: [:element | aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self]. element printOn: aStream. aStream space]. aStream nextPut: $)! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver. Use the literal form if possible." self isLiteral ifTrue: [aStream nextPut: $#; nextPut: $(. self do: [:element | element printOn: aStream. aStream space]. aStream nextPut: $)] ifFalse: [super storeOn: aStream]! ! !Array methodsFor: 'comparing'! ! SequenceableCollection subclass: #ArrayedCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! ArrayedCollection comment: 'The abstract class ArrayedCollection represents a collection of elements with integers as external keys. Its subclasses are Array elements are pointers ByteArray elements are bytes RunArray elements are typically runs of the same thing String elements are characters Text elements are characters with style WordArray elements are words It re-implements several messages inherited from SequenceableCollection in order to obtain some performance gains. Subclasses should not implement methods for adding add: removing remove:ifAbsent:'! !ArrayedCollection methodsFor: 'accessing'! size "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Primitive is specified here to override SequenceableCollection size. Essential. See Object documentation whatIsAPrimitive. " ^self basicSize! ! !ArrayedCollection methodsFor: 'testing'! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." | tally index len| tally _ 0. index _ 1. len _ self size. [index <= len ] whileTrue: [anObject = (self at: index) ifTrue: [tally _ tally + 1]. index _ index + 1]. ^tally! ! !ArrayedCollection methodsFor: 'adding'! add: newObject "ArrayedCollections cannot implement add:." self shouldNotImplement! ! !ArrayedCollection methodsFor: 'printing'! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver. For an ArrayedCollection, the general format is ((class-name new: size) at: index put: element; at: nextIndex put: element; yourself) " aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new: '. aStream store: self size. aStream nextPut: $). (self storeElementsFrom: 1 to: self size on: aStream) ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !ArrayedCollection methodsFor: 'private'! defaultElement "Answer the object that is stored when no specific object is indicated." ^nil! storeElementsFrom: firstIndex to: lastIndex on: aStream "Append to the argument aStream a description of elements of the receiver starting with the element at position firstIndex and ending with the element at position lastIndex. The general format for each position is at: index put: element separated by semicolons." | noneYet defaultElement arrayElement | noneYet _ true. defaultElement _ self defaultElement. firstIndex to: lastIndex do: [:index | arrayElement _ self at: index. arrayElement = defaultElement ifFalse: [noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' at: '. aStream store: index. aStream nextPutAll: ' put: '. aStream store: arrayElement]]. ^noneYet! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayedCollection class instanceVariableNames: ''! !ArrayedCollection class methodsFor: 'instance creation'! new "Answer a new instance of ArrayedCollection with size = 0." ^self new: 0! new: size withAll: value "Answer a new instance of ArrayedCollection whose every element is equal to the argument, value." ^(self new: size) atAllPut: value! with: anObject "Answer a new instance of ArrayedCollection, containing only anObject." | newCollection | newCollection _ self new: 1. newCollection at: 1 put: anObject. ^newCollection! with: firstObject with: secondObject "Answer a new instance of ArrayedCollection, containing firstObject and secondObject." | newCollection | newCollection _ self new: 2. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. ^newCollection! with: firstObject with: secondObject with: thirdObject "Answer a new instance of ArrayedCollection, containing only these three objects." | newCollection | newCollection _ self new: 3. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. ^newCollection! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer a new instance of ArrayedCollection, containing the four arguments as the elements." | newCollection | newCollection _ self new: 4. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. ^newCollection! ! ParseNode subclass: #AssignmentNode instanceVariableNames: 'variable value ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! AssignmentNode comment: 'I represent a (var_expr) construct.'! !AssignmentNode methodsFor: 'initialize-release'! variable: aVariable value: expression variable _ aVariable. value _ expression! variable: aVariable value: expression from: encoder "compile" (aVariable isMemberOf: MessageNode) ifTrue: [^aVariable store: expression from: encoder]. variable _ aVariable. value _ expression! ! !AssignmentNode methodsFor: 'code generation'! emitForEffect: stack on: aStream value emitForValue: stack on: aStream. variable emitStorePop: stack on: aStream! emitForValue: stack on: aStream value emitForValue: stack on: aStream. variable emitStore: stack on: aStream! sizeForEffect: encoder ^(value sizeForValue: encoder) + (variable sizeForStorePop: encoder)! sizeForValue: encoder ^(value sizeForValue: encoder) + (variable sizeForStore: encoder)! ! !AssignmentNode methodsFor: 'printing'! printOn: aStream indent: level variable printOn: aStream indent: level. aStream nextPutAll: ' _ '. value printOn: aStream indent: level + 2! printOn: aStream indent: level precedence: p p < 4 ifTrue: [aStream nextPutAll: '(']. self printOn: aStream indent: level. p < 4 ifTrue: [aStream nextPutAll: ')']! ! LookupKey subclass: #Association instanceVariableNames: 'value ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! Association comment: 'An Association is a pair of associated objects--a key and a value. It can serve as an entry in a dictionary. Think of the key as the left-hand side of the dictionary and the value as the right-hand side. Instance Variable: value '! !Association methodsFor: 'accessing'! key: aKey value: anObject "Store the arguments as the variables of the receiver." key _ aKey. value _ anObject! value "Answer the value of the receiver." ^value! value: anObject "Store the argument, anObject, as the value of the receiver." value _ anObject! ! !Association methodsFor: 'printing'! printOn: aStream "Append to the argument, aStream, the two elements of the Association separated by a right arrow." super printOn: aStream. aStream nextPutAll: '->'. value printOn: aStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Association class instanceVariableNames: ''! !Association class methodsFor: 'instance creation'! key: newKey value: newValue "Answer a new instance of the receiver with the arguments as the key and value of the association." ^(super key: newKey) value: newValue! ! Collection subclass: #Bag instanceVariableNames: 'contents ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! Bag comment: 'A Bag is an unordered collection of elements. It stores these elements in a dictionary, tallying up occurrences of equal objects. Because a Bag can store an occurrence only once, its clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of Bag should be created. Instance Variable: contents of associations between elements and the number of occurrences of each element in the Bag'! !Bag methodsFor: 'accessing'! at: anInteger "Provide an error notification that elements of a Bag are not accessible by external keys." self errorNotKeyed! at: anInteger put: anObject "Provide an error notification that elements of a Bag are not accessible by external keys." self errorNotKeyed! size "Answer how many elements the receiver contains." | tally | tally _ 0. contents do: [:each | tally _ tally + each]. ^tally! sortedCounts "Answer a collection of counts with elements, sorted by decreasing count. " | counts | counts _ SortedCollection sortBlock: [:x :y | x >= y]. contents associationsDo: [:assn | counts add: (Association key: assn value value: assn key)]. ^counts! sortedElements "Answer a collection of elements with counts, sorted by element." | elements | elements _ SortedCollection new. contents associationsDo: [:assn | elements add: assn]. ^ elements! ! !Bag methodsFor: 'testing'! includes: anObject "Answer whether anObject is one of the receiver's elements." ^contents includesKey: anObject! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." (self includes: anObject) ifTrue: [^contents at: anObject] ifFalse: [^0]! ! !Bag methodsFor: 'adding'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." ^self add: newObject withOccurrences: 1! add: newObject withOccurrences: anInteger "Add the element newObject to the elements of the receiver. Do so as though the element were added anInteger number of times. Answer newObject." (self includes: newObject) ifTrue: [contents at: newObject put: anInteger + (contents at: newObject)] ifFalse: [contents at: newObject put: anInteger]. ^newObject! ! !Bag methodsFor: 'removing'! remove: oldObject ifAbsent: exceptionBlock "Remove oldObject as one of the receiver's elements. If several of the elements are equal to oldObject, only one is removed. If no element is equal to oldObject, answer the result of evaluating anExceptionBlock. Otherwise, answer the argument, oldObject." | count | (self includes: oldObject) ifTrue: [(count _ contents at: oldObject) = 1 ifTrue: [contents removeKey: oldObject] ifFalse: [contents at: oldObject put: count - 1]] ifFalse: [^exceptionBlock value]. ^oldObject! ! !Bag methodsFor: 'enumerating'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! !Bag methodsFor: 'private'! setDictionary "Initialize the instance variable." contents _ Dictionary new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bag class instanceVariableNames: ''! !Bag class methodsFor: 'instance creation'! new "Create an instance of Bag whose contents are empty." ^super new setDictionary! ! Object subclass: #Behavior instanceVariableNames: 'superclass methodDict format subclasses ' classVariableNames: 'SelectorsOfConflictMethods SelectorsOfCopiedMethods SelectorsOfDirectedMethods ' poolDictionaries: '' category: 'Kernel-Classes'! Behavior comment: 'Instances of class Behavior provides the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but Behavior is a good starting point for providing instance-specific behavior (as in Metaclass). Instance Variables: superclass links the chain of inheritance methodDict associates message names with methods format encodes storage layout of instances subclasses back-pointers to the class'' subclasses Class Variables: These are used in implementing multiple inheritance, to keep track of classes in which methods are duplicated, copied or referred to another class SelectorsOfConflictMethods of associations where the key is a selector and value is Array of classes SelectorsOfCopiedMethods of associations where the key is a selector and value is Array of classes SelectorsOfDirectedMethods of associations where the key is a selector and value is Array of classes '! !Behavior methodsFor: 'initialize-release'! obsolete "Invalidate and recycle local messages. Remove the receiver from its superclass' subclass list." methodDict _ MethodDictionary new. self superclasses do: [:each | each removeSubclass: self]. self removeFromInheritanceTables! ! !Behavior methodsFor: 'accessing'! format "Answer an Integer that encodes the kinds and numbers of variables of instances of the receiver." ^format! ! !Behavior methodsFor: 'testing'! instSize "Answer the number of named instance variables (as opposed to indexed variables) of the receiver." ^format bitAnd: 255! isBits "Answer whether the receiver contains just bits (not pointers)." ^format noMask: -16384! isBytes "Answer whether the receiver has 8-bit instance variables." ^format noMask: 8192! isFixed "Answer whether the receiver does not have a variable (indexable) part." ^self isVariable not! isPointers "Answer whether the receiver contains just pointers (not bits)." ^self isBits not! isVariable "Answer whether the receiver has a variable (indexable) part." ^(format bitAnd: 4096) ~= 0! isWords "Answer whether the receiver has 16-bit instance variables." ^self isBytes not! ! !Behavior methodsFor: 'copying'! copy "Make a copy of the receiver without a list of subclasses." | myCopy savedSubclasses | savedSubclasses _ subclasses. subclasses _ nil. myCopy _ self shallowCopy. subclasses _ savedSubclasses. ^myCopy methodDictionary: methodDict copy! ! !Behavior methodsFor: 'printing'! printHierarchy "Answer a description containing the names and instance variable names of all of the subclasses and superclasses of the receiver." | aStream index supers | index _ 0. aStream _ WriteStream on: (String new: 16). self allDynamicSuperclasses reverseDo: [:aClass | aStream crtab: index. index _ index + 1. aStream nextPutAll: aClass name. aStream space. aStream print: aClass instVarNames. supers _ aClass superclasses. supers size>1 ifTrue: [aStream nextPutAll: ' [also a '. (supers copyFrom: 2 to: supers size) do: [:s | aStream space; nextPutAll: s name; space; print: s allInstVarNames]. aStream nextPut: $] ]]. aStream cr. self printSubclassesOn: aStream callingSuperclass: self dynamicSuperclass level: index. ^aStream contents! printOn: aStream "Append to the argument aStream a statement of which superclass the receiver descends from." aStream nextPutAll: 'a descendent of '. superclass printOn: aStream! ! !Behavior methodsFor: 'creating class hierarchy'! addSubclass: aSubclass "Make the argument, aSubclass, be one of the subclasses of the receiver." (aSubclass superclasses includes: self) ifTrue: [subclasses == nil ifTrue: [subclasses _ Set with: aSubclass] ifFalse: [subclasses add: aSubclass]] ifFalse: [self error: aSubclass name , ' is not my subclass']! removeSubclass: aSubclass "If the argument, aSubclass, is one of the receiver's subclasses, remove it." subclasses == nil ifFalse: [subclasses remove: aSubclass ifAbsent: []. subclasses isEmpty ifTrue: [subclasses _ nil]]! superclass: aClass "Change the receiver's superclass to be aClass." (aClass isKindOf: Behavior) ifTrue: [superclass _ aClass] ifFalse: [self error: 'superclass must be a class-describing object']! ! !Behavior methodsFor: 'creating method dictionary'! addSelector: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary." | wasThere | wasThere _ methodDict includesKey: selector. methodDict at: selector put: compiledMethod. self flushCache. "if the selector is indexed in SelectorsOfConflictMethods or SelectorsOfCopiedMethods, remove it" ((SelectorsOfConflictMethods at: selector ifAbsent: [Array new]) includes: self) ifTrue: [self removeClass: self selector: selector in: SelectorsOfConflictMethods]. ((SelectorsOfCopiedMethods at: selector ifAbsent: [Array new]) includes: self) ifTrue: [self removeClass: self selector: selector in: SelectorsOfCopiedMethods]. wasThere ifTrue: [self checkChangeSelector: selector] ifFalse: [self subclasses do: [:sub | sub checkSuperAddSelector: selector]]! addSelectorUnchecked: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do not check for effect on (multiple) inheritance." methodDict at: selector put: compiledMethod. self flushCache! methodDictionary: aDictionary "Store the argument, aDictionary, as the method dictionary of the receiver." methodDict _ aDictionary! removeSelector: selector "Assuming that the message selector is in the receiver's method dictionary, remove it. If the selector is not in the method dictionary, create an error notification." methodDict removeKey: selector. self flushCache. self checkChangeSelector: selector! removeSelectorUnchecked: selector "Assuming that the message selector is in the receiver's method dictionary, remove it. If the selector is not in the method dictionary, create an error notification. Do not check for effect on (multiple) inheritance." methodDict removeKey: selector. self flushCache! tryCopyingCodeFor: selector "Check if 'selector' is compound, and if so, try to copy down the appropriate code. Return #OK if sucessful, #HierarchyViolation if the class part is not one of my immediate superclasses, or #NotFound if the class part is OK but the selector part is not found in the inheritance hierarchy." | classPart whichClass simpleSelector descr | selector isCompound ifFalse: [^#NotFound]. classPart _ selector classPart. simpleSelector _ selector selectorPart. "check for special class parts" classPart==#all ifTrue: [self compileBroadcastCodeFor: simpleSelector. self insertClass: self selector: simpleSelector in: SelectorsOfDirectedMethods. ^#OK]. classPart==#super ifTrue: [descr _ self superMethodDescriptionAt: simpleSelector] ifFalse: [whichClass _ Smalltalk at: classPart. "if I'm a metaclass, get the metaclass of whichClass" self isMeta ifTrue: [whichClass _ whichClass class]. "check that whichClass is one of my superclasses" (self inheritsFrom: whichClass) ifFalse: [^#HierarchyViolation]. descr _ whichClass methodDescriptionAt: simpleSelector]. descr isBad ifTrue: [^#NotFound]. self compileUnchecked: classPart , '.' , descr sourceCode. self insertClass: self selector: simpleSelector in: SelectorsOfDirectedMethods. ^#OK! ! !Behavior methodsFor: 'instance creation'! basicNew "Answer a new instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [^self basicNew: 0]. self primitiveFailed! basicNew: anInteger "Answer a new instance of the receiver (which is a class) with the number of indexable variables specified by the argument, anInteger. Fail if the class is not indexable or if the argument is not a positive Integer. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! new "Answer with a new instance of the receiver, which is a class with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive. " self isVariable ifTrue: [^self new: 0]. self primitiveFailed! new: anInteger "Answer with a new instance of the receiver, a class with the number of indexable variables specified by the argument, anInteger. Fail if the class is not indexable or if the argument is not a positive Integer. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Behavior methodsFor: 'accessing class hierarchy'! allDynamicSuperclasses "Answer an OrderedCollection of the receiver and the receiver's ancestor's dynamic superclasses; ordered with immediate superclass first." | temp | superclass == nil ifTrue: [^OrderedCollection new] ifFalse: [temp _ superclass allDynamicSuperclasses. temp addFirst: superclass. ^temp]! allSubclasses "Answer an OrderedCollection of the receiver's subclasses and the receiver's ancestor's subclasses in breadth-first order, with the immediate subclasses first." | coll | coll _ OrderedCollection new. coll addAll: self subclasses. self subclasses do: [:eachSubclass | coll addAll: eachSubclass allSubclasses]. ^coll! allSuperclasses "Answer an OrderedCollection of the receiver's superclasses and the receiver's ancestor's superclasses in breadth-first order, with the immediate superclasses first." | coll | coll _ OrderedCollection new. self allSuperclassesInto: coll. ^coll! allSuperclassesInto: orderedCollection "Add all my superclasses to orderedCollection if not already there. Use breadth-first order." | mysupers | mysupers _ self superclasses. mysupers do: [:each | each allSuperclassesInto: orderedCollection]. mysupers reverseDo: [:each | (orderedCollection includes: each) ifFalse: [orderedCollection addFirst: each]]! dynamicSuperclass "Answer the receiver's superclass. Only returns the first one - use 'superclasses' to find them all." ^superclass! hasMultipleSuperclasses ^false! subclasses "Answer the receiver's subclasses. Return a copy so that callers who add or delete subclasses won't get confused." subclasses == nil ifTrue: [^Set new] ifFalse: [^subclasses copy]! superclass "Answer the receiver's superclass. Only returns the first one - use 'superclasses' to find them all." ^superclass! superclasses "Answer with an array of all the receiver's superclasses." superclass == nil ifTrue: [^#()]. self hasMultipleSuperclasses ifTrue: [^ (Array with: superclass) , self class otherSuperclasses]. ^ Array with: superclass! withAllSubclasses "Answer an OrderedCollection of subclasses including this class in breadth first order." | subs | subs _ self allSubclasses. subs addFirst: self. ^subs! withAllSuperclasses "Answer an OrderedCollection of superclasses including this class in breadth first order." | subs | subs _ self allSuperclasses. subs addFirst: self. ^subs! ! !Behavior methodsFor: 'accessing method dictionary'! allSelectors "Answer a set of all the message selectors that instances of the receiver can understand." | aSet | aSet _ Set new. self withAllSuperclasses do: [:each | aSet addAll: each selectors]. ^aSet "Point allSelectors."! checkChangeSelector: selector "The method for selector has been changed or removed. Check all copied versions for the method in question." (SelectorsOfCopiedMethods at: selector ifAbsent: [Array new]) do: [:class | (class inheritsFrom: self) ifTrue: [(class checkMethodFor: selector) ifFalse: [Transcript cr; show: 'conflicting methods for ' , selector, ' in ', class name] ]]. "Remove all versions copied for directed access (eg Point.max) " (SelectorsOfDirectedMethods at: selector ifAbsent: [Array new]) do: [:class | (class inheritsFrom: self) ifTrue: [(class compoundSelectorsMatching: selector) do: [:sel | class removeSelectorUnchecked: sel]. self removeClass: class selector: selector in: SelectorsOfDirectedMethods]]! checkSuperAddSelector: selector | local | local _ self includesSelector: selector. self hasMultipleSuperclasses ifFalse: [local ifTrue: [^self]. ^ self subclasses do: [:sub | sub checkSuperAddSelector: selector]]. (self checkMethodFor: selector) ifFalse: "Copy or note conflict" [Transcript cr; show: 'conflicting methods for ' , selector, ' in ', self name]. local ifTrue: [^self]. "Was local before, so no change below" ^ self subclasses do: [:sub | sub checkSuperAddSelector: selector]! compiledMethodAt: selector "Answer the compiled method associated with the message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^methodDict at: selector! dynamicMethodDescriptionAt: selector "return a method description for the method for 'selector' that would be found by dynamic lookup" (methodDict includesKey: selector) ifTrue: [^MethodDescription whichClass: self selector: selector]. superclass == nil ifTrue: [^MethodDescription makeMethodNotImplemented]. ^superclass dynamicMethodDescriptionAt: selector! methodDescriptionAt: selector "Answer a method description for the method for 'selector'." | local copied conflict | local _ methodDict includesKey: selector. copied _ (SelectorsOfCopiedMethods at: selector ifAbsent: [Array new]) includes: self. conflict _ (SelectorsOfConflictMethods at: selector ifAbsent: [Array new]) includes: self. local & copied not & conflict not ifTrue: [^MethodDescription whichClass: self selector: selector]. ^self superMethodDescriptionAt: selector! selectorAtMethod: method setClass: classResultBlock "Answer both the message selector associated with the compiled method and the class in which that selector is defined." | sel | sel _ methodDict keyAtValue: method ifAbsent: [superclass == nil ifTrue: [classResultBlock value: self. ^self defaultSelectorForMethod: method]. sel _ superclass selectorAtMethod: method setClass: classResultBlock. "Set class to be self, rather than that returned from superclass. " sel == (self defaultSelectorForMethod: method) ifTrue: [classResultBlock value: self]. ^sel]. classResultBlock value: self. ^sel! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^methodDict keys "Point selectors."! sourceCodeAt: messageSelector "Answer the string corresponding to the source code for the argument." ^ self sourceCodeForMethod: (methodDict at: messageSelector) at: messageSelector! sourceCodeForMethod: method at: messageSelector "Answer the string corresponding to the source code for the argument." | newSource index| Sensor leftShiftDown ifTrue: [newSource _ (self decompilerClass new decompile: messageSelector in: self method: method) decompileString] ifFalse: [newSource _ method getSource. newSource == nil ifTrue: [newSource _ (self decompilerClass new decompile: messageSelector in: self method: method) decompileString] ifFalse: [((newSource at: newSource size) isSeparator) ifTrue: [index _ newSource size. "tidy up for file out" [((newSource at: index) isSeparator) and: [index > 1]] whileTrue: [index _ index - 1]. newSource _ newSource copyFrom: 1 to: index]]]. ^newSource! sourceMethodAt: selector "Answer the paragraph corresponding to the source code for the argument." ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! superMethodDescriptionAt: selector "return a method description for the method for 'selector' inherited from my superclasses" | descr result | result _ MethodDescription makeMethodNotImplemented. self superclasses do: [: each | descr _ each methodDescriptionAt: selector. descr isMethodNotImplemented ifFalse: [result isMethodNotImplemented ifTrue: [result _ descr] ifFalse: [result=descr ifFalse: [^MethodDescription makeConflictingMethods]]]]. ^result! ! !Behavior methodsFor: 'accessing instances and variables'! allClassVarNames "Answer a Set of the names of the receiver's and the receiver's ancestor's class variables." ^superclass allClassVarNames! allInstances "Answer a collection of all instances of this class." | aCollection | aCollection _ OrderedCollection new. self allInstancesDo: [:x | x == aCollection ifFalse: [aCollection add: x]]. ^aCollection! allInstVarNames "Answer an Array of the names of the receiver's instance variables." | names | names _ OrderedCollection new. self accumulateInstVarNames: names traversedClasses: Set new. ^names! allSharedPools "Answer a Set of the pools, dictionaries, that the receiver and the receiver's ancestors share. Subclasses, such as class Class, override this message." ^superclass allSharedPools! allVarNamesSelect: selectBlock "Answer a collection of all the static variable names defined for the receiver which satisfy the condition in selectBlock. Test class and pool variables, including superclass variables. Also include global variables." | set | set _ self classPool keys select: selectBlock. self sharedPools do: [:pool | set addAll: (pool keys select: selectBlock)]. superclass == nil ifTrue: [set addAll: (Smalltalk keys select: selectBlock)] ifFalse: [set addAll: (superclass allVarNamesSelect: selectBlock)]. ^set! classVarNames "Answer a Set of the receiver's class variable names. Since the receiver does not retain knowledge of class variables, the method fakes it by creating an empty set." ^Set new! instanceCount "Answer the number of instances of the receiver that are currently in use." | count | count _ 0. self allInstancesDo: [:x | count _ count + 1]. ^count! instVarNames "Answer an Array of the instance variable names. Behaviors must make up fake local instance variable names because Behaviors have instance variables for the purpose of compiling methods, but these are not named instance variables. " | mySize superSize | mySize _ self instSize. superSize _ superclass == nil ifTrue: [0] ifFalse: [superclass instSize]. mySize = superSize ifTrue: [^#()]. ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! sharedPools "Answer a Set of the pools, dictionaries, that the receiver shares. Since the receiver does not retain knowledge of pool dictionaries, the method fakes it by creating an empty array. Subclasses, such as class Class, override this message." ^Set new! someInstance "Answer with the first instance of this receiver. See Object nextInstance. Fails if there are none. Essential. See Object documentation whatIsAPrimitive." ^nil! subclassInstVarNames "Answer with a Set of the names of the receiver's subclasses' instance variables." | vars | vars _ Set new. self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames]. ^vars! ! !Behavior methodsFor: 'testing class hierarchy'! inheritsFrom: aClass "Answer whether the argument, aClass, is on the receiver's superclass chain." self superclasses do: [:each | (each==aClass or: [each inheritsFrom: aClass]) ifTrue: [^true]]. ^false! kindOfSubclass "Answer a string which is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, or a variableWordSubclass." self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [^' variableByteSubclass: '] ifFalse: [^' variableWordSubclass: ']] ifFalse: [^' variableSubclass: ']] ifFalse: [^' subclass: ']! ! !Behavior methodsFor: 'testing method dictionary'! canUnderstand: selector "Answer true if the receiver can respond to the message whose selector is the argument, false otherwise. The selector can be in the method dictionary of the receiver's class or any of its superclasses." (self includesSelector: selector) ifTrue: [^true]. superclass == nil ifTrue: [^false]. ^superclass canUnderstand: selector! hasMethods "Answer whether the receiver has any methods in its method dictionary." ^methodDict size > 0! includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class." ^methodDict includesKey: aSymbol! scopeHas: varName ifTrue: assocBlock "Look up varName in this class, its superclasses, and Smalltalk. If it is there, pass the association to assocBlock, and answer true; else answer false." | assoc | self withAllSuperclasses do: [:sup | (sup poolHas: varName ifTrue: assocBlock) ifTrue: [^true]]. assoc _ Smalltalk associationAt: varName ifAbsent: []. assoc == nil ifFalse: [assocBlock value: assoc. ^true]. ^false! whichClassIncludesSelector: aSymbol "Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found." (methodDict includesKey: aSymbol) ifTrue: [^self]. superclass == nil ifTrue: [^nil]. ^superclass whichClassIncludesSelector: aSymbol "Rectangle whichClassIncludesSelector: #inspect."! whichSelectorsAccess: instVarName "Answer a set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new]. ^methodDict keys select: [:sel | ((methodDict at: sel) readsField: instVarIndex) or: [(methodDict at: sel) writesField: instVarIndex]] "Point whichSelectorsAccess: 'x'."! whichSelectorsReferTo: literal "Answer a set of selectors whose methods access the argument as a literal." | special byte | special _ Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:bytex | byte _ bytex]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a collection of selectors whose methods access the argument as a literal." | who method methodArray index arraySize | who_ OrderedCollection new. methodArray _ methodDict methodArray. arraySize _ methodArray size. index _ 0. [(index _ index + 1) <= arraySize] whileTrue: [(method _ methodArray at: index) == nil ifFalse: [((method refersToLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [who add: (methodDict basicAt: index)]]]. ^who "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: 'compiling'! compile: code notifying: requestor remoteString: aRemoteString ifFail: failBlock "Compile the argument, code, as source code in the context of the receiver and install the result in the receiver's method dictionary. The argument requestor is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string. The trailer is an array of three bytes that should be added to the end of the compiled method. These point to the location of the source code (on a file). This method does not save the source code. Evaluate the failBlock if the compilation does not succeed." | methodNode selector | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. selector _ methodNode selector. self addSelector: selector withMethod: (methodNode generateAt: aRemoteString). ^selector! compileAll ^ self compileAllFrom: self! compileAllFrom: oldClass "Compile all the methods in oldClass's method dictionary. See recompile:from: regarding oldClass, which is normally just self." self selectors do: [:sel | self recompile: sel from: oldClass]! compileAllSubclasses "Compile all the methods in the receiver's subclasses. This does not modify code (re-install the compiled versions), just compiles the methods as a kind of static check." self allSubclasses do: [:aSubclass | aSubclass compileAll]! compileBroadcastCodeFor: selector "compile code that invokes ALL methods for 'selector' in my inheritance hierarchy" | implementors strm keywords argNames | implementors _ self withAllSuperclasses select: [:each | each includesSelector: selector]. argNames _ Array new: selector numArgs. 1 to: argNames size do: [:i | argNames at: i put: 'arg' , i printString]. strm _ WriteStream on: (String new: 500). strm nextPutAll: 'all.'. argNames size=0 ifTrue: [strm nextPutAll: selector] ifFalse: [keywords _ selector keywords. 1 to: argNames size do: [:i | strm nextPutAll: (keywords at: i); space; nextPutAll: (argNames at: i); space]]. implementors do: [:each | strm cr; tab; nextPutAll: 'self '; nextPutAll: each name; nextPut: $. . argNames size=0 ifTrue: [strm nextPutAll: selector] ifFalse: [keywords _ selector keywords. 1 to: argNames size do: [:i | strm nextPutAll: (keywords at: i); space; nextPutAll: (argNames at: i); space]]. strm nextPut: $.]. self compileUnchecked: strm contents! compilerClass "Return a compiler class appropriate for source methods of this class." ^Compiler! compileUnchecked: code "Compile the argument, code, and install the result in the receiver's method dictionary. Do not check for possible effect on inheritance, since that's what this is doing." | selector methodNode | methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^nil]. selector _ methodNode selector. self addSelectorUnchecked: selector withMethod: (methodNode generate). ^selector! decompile: selector "Find the compiled code associated with the argument, selector, as a message selector in the receiver's method dictionary and decompile it. Answer the resulting source code as a string. Create an error if the selector is not in the receiver's method dictionary." ^self decompilerClass new decompile: selector in: self! decompilerClass "Return a decompiler class appropriate for compiled methods of this class." ^Decompiler! evaluatorClass "Return an evaluator class appropriate for evaluating expressions in the context of instances of this class." ^Compiler! parserClass "Return a parser class to use for parsing methods in this class." ^self compilerClass preferredParserClass! poolHas: varName ifTrue: assocBlock "Behaviors have no pools" ^false! recompile: selector ^ self recompile: selector from: self! recompile: selector from: oldClass "Recompile the method associated with selector in the receiver's method dictionary. Take care not to write out any new source code - just generate new bytes. oldClass may differ from self in order to decompile right (if sourceFiles == nil) when adding or removing fields of a class." | method remoteString methodNode | method _ oldClass compiledMethodAt: selector. remoteString _ method getSourceRemoteString. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: []. methodNode == nil "Try again after proceed from SyntaxError" ifTrue: [^self recompile: selector]. selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self addSelector: selector withMethod: (methodNode generateAt: remoteString).! sourceCodeTemplate "Answer an expression to be edited and evaluated in order to define methods in this class." ^'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! subclassDefinerClass "Return an evaluator class appropriate for evaluating definitions of new subclasses of this class." ^Compiler! ! !Behavior methodsFor: 'enumerating'! allAccessesTo: instVarName "Return a list of all methods in my hierarchy that refer to the named instance variable." | coll | coll _ OrderedCollection new. Cursor execute showWhile: [(self withAllSuperclasses reverse) , self allSubclasses do: [:class | (class whichSelectorsAccess: instVarName) do: [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]]. ^coll "Collection allAccessesTo: 'contents'."! allCallsOn: aLiteral "Answer a SortedCollection of all the methods that call on aLiteral." | set special byte | self == Object ifTrue: [^Smalltalk allCallsOn: aLiteral]. set _ Set new. special _ Smalltalk hasSpecialSelector: aLiteral ifTrueSetByte: [:bytex | byte _ bytex]. self withAllSuperclasses reverse , self allSubclasses do: [:class | (class whichSelectorsReferTo: aLiteral special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [set add: class name , ' ' , sel]]. (class class whichSelectorsReferTo: aLiteral special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [set add: class class name , ' ' , sel]]]. ^set asSortedCollection! allInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver." | inst next | inst _ self someInstance. inst == nil ifFalse: [[next _ inst nextInstance. aBlock value: inst. next == nil] whileFalse: [inst _ next]]. nil class == self ifTrue: [aBlock value: nil]! allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclasses do: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! allSubInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver's subclasses." self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! browseAllAccessesTo: instanceVariable "Create and schedule a Message Set browser for all the receiver's methods or any methods of a subclass that refer to the instance variable name. If the instance variable name is not defined for the receiver, the notification 'Nobody' occurs in the System Transcript." BrowserView openListBrowserOn: (self allAccessesTo: instanceVariable) label: instanceVariable initialSelection: instanceVariable! browseAllCallsOn: aSymbol "Create and schedule a message browser on each method that calls on aSymbol." "For example, Number browseAllCallsOn: #/. " | label key | (aSymbol isMemberOf: Association) ifTrue: [key _ aSymbol key. label _ 'Users of ' , key] ifFalse: [key _ aSymbol. label _ 'Senders of ', key]. ^ BrowserView openListBrowserOn: (self allCallsOn: aSymbol) label: label, ' from ', self name initialSelection: key asSymbol keywords first! crossReference "Answer an array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included." ^self selectors asSortedCollection asArray collect: [:x | Array with: (String with: Character cr), x with: (self whichSelectorsReferTo: x)] "Point crossReference."! showVariableMenu: generatorBlock collect: valueBlock "Construct a menu of variable names supplied by the generatorBlock, with lines between classes in the superclass chain. Show the menu, returning the variable chosen by the user, or nil if no variable was chosen." | aStream lines count lastLine variables index | aStream _ WriteStream on: (String new: 200). lines _ OrderedCollection new. count _ 0. lastLine _ 0. variables _ OrderedCollection new. self withAllSuperclasses reverseDo: [:eachClass | count = lastLine ifFalse: [lines add: count. lastLine _ count]. (generatorBlock value: eachClass) do: [:var | aStream nextPutAll: ((valueBlock value: var) contractTo: 20); cr. variables addLast: var. count _ count + 1]]. variables isEmpty ifTrue: [^nil]. "Nothing to choose from" aStream skip: -1. index _ (PopUpMenu labels: aStream contents lines: lines) startUp. ^index = 0 ifTrue: [nil] ifFalse: [variables at: index]! ! !Behavior methodsFor: 'fileIn/Out'! printMethodChunk: selector on: aFileStream moveSource: moveSource toFile: fileIndex "Print the source code for the method associated with the argument selector onto the fileStream. aFileStream, and, for backup, if the argument moveSource (a Boolean) is true, also set the file index within the method to be the argument fileIndex." | position | aFileStream cr; cr. moveSource ifTrue: [position _ aFileStream position]. aFileStream nextChunkPut: (self sourceMethodAt: selector) asString. moveSource ifTrue: [(self compiledMethodAt: selector) setSourcePosition: position inFile: fileIndex]! ! !Behavior methodsFor: 'private'! accumulateInstVarNames: names traversedClasses: classSet "accumulate instance variable names in 'names'. Do this in depth-first, left-to-right order. This will give the ordering of instance variable names expected by the compiler and other parts of the system." self superclasses do: [:each | each accumulateInstVarNames: names traversedClasses: classSet]. (classSet includes: self) ifFalse: [names addAll: self instVarNames. classSet add: self]! checkMethodFor: selector "copy method from superclass if necessary. Answer true if no conflict detected" | descr unmoved copyOK local copied conflict | local _ methodDict includesKey: selector. copied _ (SelectorsOfCopiedMethods at: selector ifAbsent: [Array new]) includes: self. conflict _ (SelectorsOfConflictMethods at: selector ifAbsent: [Array new]) includes: self. local & copied not & conflict not ifTrue: [^true]. descr _ self superMethodDescriptionAt: selector. descr isMethodNotImplemented ifTrue: [self removeSelectorUnchecked: selector. ^true]. descr isConflictingMethods ifTrue: [self compileConflictCodeFor: selector. ^false]. conflict ifTrue: "Not conflicting any more, so remove if it had been." [self removeSelectorUnchecked: selector. self removeClass: self selector: selector in: SelectorsOfConflictMethods]. "If this method isnt on the dynamic chain, copy it." descr = (self dynamicMethodDescriptionAt: selector) ifFalse: [unmoved _ self unmovedVarsFrom: descr whichClass. copyOK _ true. "If method doesnt touch any vars which moved" descr method fieldsTouched do: [:field | copyOK _ copyOK & (unmoved at: field)]. copyOK ifTrue: "then can just install that same method" [self addSelectorUnchecked: descr selector withMethod: descr method] ifFalse: "otherwise have to recompile it here" [self compileUnchecked: descr sourceCode]. self insertClass: self selector: selector in: SelectorsOfCopiedMethods]. ^true! compileConflictCodeFor: selector | classes | classes _ SelectorsOfConflictMethods at: selector ifAbsent: [Array new]. (classes includes: self name) "This class already has conflict code for this selector" ifTrue: [^self]. self compile: (self conflictCodeFor: selector) classified: 'conflicting inherited methods' notifying: nil. self insertClass: self selector: selector in: SelectorsOfConflictMethods! compoundSelectorsMatching: simple ^ self selectors select: [:sel | sel isCompound and: [sel selectorPart = simple]]! conflictCodeFor: sel "return some code that indicates a conflicting definition" | code parser | code _ (self dynamicMethodDescriptionAt: sel) sourceCode. (parser _ self parserClass new) parseSelector: code. ^ (code copyFrom: 1 to: (parser endOfLastToken min: code size)) , (String with: Character cr) , ' ^self conflictingInheritanceError'! copyMethods "copy all methods from superclasses not on the dynamic lookup chain" | noConflicts | noConflicts _ true. self allSelectors do: [:selector | noConflicts _ noConflicts & (self checkMethodFor: selector)]. noConflicts ifFalse: [Transcript cr; show: self name , ' has conflicting inherited methods -- consult browser for their names']! defaultSelectorForMethod: aMethod "Given a method, invent an appropriate selector, that is, one that will parse with the correct number of arguments." | aStream | aStream _ WriteStream on: (String new: 16). aStream nextPutAll: 'unboundMethod'. 1 to: aMethod numArgs do: [:i | aStream nextPutAll: 'with:']. ^aStream contents asSymbol! flushCache "Tell the interpreter to remove the contents of its method lookup cache, if it has one. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! format: nInstVars variable: isVar words: isWords pointers: isPointers "Set the format for the receiver (a Class)." format _ nInstVars + (isVar ifTrue: [4096] ifFalse: [0]) + (isWords ifTrue: [8192] ifFalse: [0]) + (isPointers ifTrue: [-16384] ifFalse: [0])! insertClass: aClass selector: selector in: aDictionary | previous | previous _ aDictionary at: selector ifAbsent: [Array new]. (previous includes: aClass) ifFalse: [aDictionary at: selector put: (previous copyWith: aClass)]! printSubclassesOn: aStream callingSuperclass: whichSuper level: level "As part of the algorithm for printing a description of the receiver, print the subclass on the file stream, aStream, indenting level times." | subs supers | aStream crtab: level. aStream nextPutAll: self name. aStream space; print: self instVarNames. supers _ self superclasses. supers size>1 ifTrue: [aStream nextPutAll: ' [also a'. (supers copyWithout: whichSuper) do: [:s | aStream space; nextPutAll: s name; space; print: s allInstVarNames]. aStream nextPut: $] ]. subs _ self subclasses. self == Class ifTrue: [aStream crtab: level+1; nextPutAll: '... all the Metaclasses ...'. subs _ subs reject: [:sub | sub isMeta]]. "Print subclasses in alphabetical order" (subs asSortedCollection: [:x :y | x name < y name]) do: [:sub | sub printSubclassesOn: aStream callingSuperclass: self level: level + 1]! removeClass: aClass selector: selector in: aDictionary | list | list _ (aDictionary at: selector) copyWithout: aClass. list size = 0 ifTrue: [aDictionary removeKey: selector] ifFalse: [aDictionary at: selector put: list]! removeFromInheritanceTable: table "I have been deleted -- remove me from the given inheritance table" | keys list | "get keys first, since we may be deleting entries in the midst of the loop that follows" keys _ table keys. keys do: [:key | list _ (table at: key) copyWithout: self. list size = 0 ifTrue: [table removeKey: key] ifFalse: [table at: key put: list]]! removeFromInheritanceTables "I have been deleted. Remove me from multiple inheritance tables" self removeFromInheritanceTable: SelectorsOfConflictMethods. self removeFromInheritanceTable: SelectorsOfCopiedMethods. self removeFromInheritanceTable: SelectorsOfDirectedMethods! removeSelectorSimply: selector "Remove the message selector from the receiver's method dictionary. Internal access from compiler." methodDict removeKey: selector ifAbsent: [^self]. self flushCache! sourceTextAt: selector "Answer with the string of the source code for the message selector." | newSource method | method _ methodDict at: selector. Sensor leftShiftDown ifTrue: [newSource _ self decompilerClass new decompile: selector in: self method: method] ifFalse: [newSource _ method getSource. newSource == nil ifTrue: [newSource _ self decompilerClass new decompile: selector in: self method: method]]. ^newSource asText! unmovedVarsFrom: sup "Answer with an Array with true for fields with the same offset in this class as in super" | allInstVarNames supNames | allInstVarNames _ self allInstVarNames. supNames _ sup allInstVarNames. ^ ((1 to: sup instSize) collect: [:i | (supNames at: i) = (allInstVarNames at: i)])! updateInheritanceTable: table oldSelf: oldSelf "I have replaced an old behavior or class. Update the given multiple inheritance table" table do: [:array | 1 to: array size do: [:i | (array at: i)==oldSelf ifTrue: [array at: i put: self]]]! updateInheritanceTables: oldSelf "I have replaced an old behavior or class. Update the multiple inheritance tables" self updateInheritanceTable: SelectorsOfConflictMethods oldSelf: oldSelf. self updateInheritanceTable: SelectorsOfCopiedMethods oldSelf: oldSelf. self updateInheritanceTable: SelectorsOfDirectedMethods oldSelf: oldSelf! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Behavior class instanceVariableNames: ''! !Behavior class methodsFor: 'class initialization'! init "Behavior init." SelectorsOfConflictMethods _ IdentityDictionary new. "selector -> Array of classes" SelectorsOfCopiedMethods _ IdentityDictionary new. "selector -> Array of classes" SelectorsOfDirectedMethods _ IdentityDictionary new "selector -> Array of classes"! ! Model subclass: #BinaryChoice instanceVariableNames: 'trueAction falseAction actionTaken ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Prompt/Confirm'! BinaryChoice comment: 'I represent a true/false (yes/no) choice. My instances have two possible actions they can take, depending on which choice is made. Instance variables trueAction sequence of expression to do if positive choice is made falseAction sequence of expression to do if negative choice is made actionTaken was the action, true or false, already taken '! !BinaryChoice methodsFor: 'initialize-release'! falseAction: aBlock "The argument, aBlock, will be evaluated if the receiver is sent the message selectFalse." falseAction _ aBlock! initialize "Initialize the receiver so that it indicates no action has yet been taken." actionTaken _ false! trueAction: aBlock "The argument, aBlock, will be evaluated if the receiver is sent the message selectTrue." trueAction _ aBlock! ! !BinaryChoice methodsFor: 'menu messages'! selectFalse "Take the action, if one, associated with selecting no or false." actionTaken _ true. falseAction notNil ifTrue: [falseAction value]! selectTrue "Take the action, if one, associated with selecting yes or true." actionTaken _ true. trueAction notNil ifTrue: [trueAction value]! ! !BinaryChoice methodsFor: 'accessing'! actionTaken "Answer whether the receiver has carried out its actions yet." ^actionTaken! active "Answer whether the receiver is an active system view." ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BinaryChoice class instanceVariableNames: ''! !BinaryChoice class methodsFor: 'instance creation'! message: messageString "Answer an instance of me whose question is messageString. If the user answer is yes, then return true. If the user answer is no, return false. Display the view of the instance at the cursor location." | answer | self message: messageString displayAt: Sensor cursorPoint centered: true ifTrue: [answer _ true] ifFalse: [answer _ false]. ^answer! message: messageString displayAt: aPoint centered: centered ifTrue: trueAlternative ifFalse: falseAlternative "Answer an instance of me whose question is messageString. If the user answer is yes, then evaluate trueAlternative. If the user answer is no, evaluate falseAlternative. If centered, a Boolean, is false, display the view of the instance at aPoint; otherwise display it with its center at aPoint." | newChoice | newChoice _ self new initialize. newChoice trueAction: trueAlternative. newChoice falseAction: falseAlternative. BinaryChoiceView openOn: newChoice message: messageString displayAt: aPoint centered: centered! message: messageString displayAt: originPoint ifFalse: falseAlternative "Answer an instance of me whose question is messageString. If the user answer is yes, then do nothing. If the user answer is no, evaluate falseAlternative. Display the view of the instance at originPoint." ^self message: messageString displayAt: originPoint centered: false ifTrue: nil ifFalse: falseAlternative! message: messageString displayAt: originPoint ifTrue: trueAlternative "Answer an instance of me whose question is messageString. If the user answer is yes, then evaluate trueAlternative. If the user answer is no, do nothing. Display the view of the instance at originPoint." ^self message: messageString displayAt: originPoint centered: false ifTrue: trueAlternative ifFalse: nil! message: messageString displayAt: originPoint ifTrue: trueAlternative ifFalse: falseAlternative "Answer an instance of me whose question is messageString. If the user answer is yes, then evaluate trueAlternative. If the user answer is no, evaluate falseAlternative. Display the view of the instance at originPoint." ^self message: messageString displayAt: originPoint centered: false ifTrue: trueAlternative ifFalse: falseAlternative! ! !BinaryChoice class methodsFor: 'examples'! example BinaryChoice message: 'Are you happy?' displayAt: Sensor waitButton centered: true ifTrue: [Transcript cr; show: 'happy'] ifFalse: [Transcript cr; show: 'not happy'] "BinaryChoice example."! ! Controller subclass: #BinaryChoiceController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Prompt/Confirm'! BinaryChoiceController comment: 'My instances assume that their model can carry out some action only once--that is, make a selection only once. Control is given up if the model responds true to the message actionTaken.'! !BinaryChoiceController methodsFor: 'control defaults'! isControlActive model actionTaken ifTrue: [^false]. [super isControlActive] whileFalse: [view flash]. ^true! ! !BinaryChoiceController methodsFor: 'basic control sequence'! startUp Cursor normal showWhile: [super startUp]! ! !BinaryChoiceController methodsFor: 'cursor'! centerCursorInView "Position sensor's mousePoint (which is assumed to be connected to the cursor) to the center of its view's inset display box (see Sensor|mousePoint: and View|insetDisplayBox)." | lowestSubView subViews | subViews_ view subViews. subViews isEmpty ifFalse: [lowestSubView _ subViews at: 1. subViews do: [:subView | (subView insetDisplayBox top > lowestSubView insetDisplayBox top) ifTrue: [lowestSubView _ subView]]. ^lowestSubView controller centerCursorInView]. ^super centerCursorInView! ! View subclass: #BinaryChoiceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! BinaryChoiceView comment: 'I am a view of a BinaryChoice. I display a question and two switches, yes and no, indicating choices the user can make.'! !BinaryChoiceView methodsFor: 'controller access'! defaultControllerClass ^BinaryChoiceController! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BinaryChoiceView class instanceVariableNames: ''! !BinaryChoiceView class methodsFor: 'instance creation'! openOn: aBinaryChoice message: messageString displayAt: originPoint centered: centered "Answer an instance of me that displays aBinaryChoice asking the question messageString. If the argument centered, a Boolean, is false, display the instance with top left corner at originPoint; otherwise, display it with its center at originPoint. If necessary, translate so the view is completely on the screen. Do not schedule, rather take control immediately and insist that the user respond." | topView messageView switchView savedArea | messageView _ DisplayTextView new editParagraph: messageString asParagraph. messageView insideColor: Form white. messageView controller: NoController new. messageView centered. switchView _ self buildSwitchesFor: aBinaryChoice width: messageView window width. topView _ self new model: aBinaryChoice. topView addSubView: messageView. topView addSubView: switchView below: messageView. topView align: (centered ifTrue: [switchView viewport center] ifFalse: [topView viewport topLeft]) with: originPoint. topView borderWidth: 2. topView translateBy: (topView displayBox amountToTranslateWithin: Display boundingBox). topView insideColor: Form white. savedArea _ Form fromDisplay: topView displayBox. topView display. topView controller startUp. topView release. savedArea displayOn: Display at: topView viewport topLeft! ! !BinaryChoiceView class methodsFor: 'private'! buildSwitchesFor: aBinaryChoice width: anInteger |switchView yesSwitchView noSwitchView| switchView _ View new model: aBinaryChoice. switchView controller: BinaryChoiceController new. yesSwitchView _ SwitchView new model: aBinaryChoice. yesSwitchView borderWidthLeft: 0 right: 2 top: 0 bottom: 0. yesSwitchView selector: #active. yesSwitchView controller selector: #selectTrue. yesSwitchView controller cursor: Cursor thumbsUp. yesSwitchView label: 'yes' asParagraph. yesSwitchView window: (0@0 extent: anInteger//2 @ yesSwitchView window height). noSwitchView _ SwitchView new model: aBinaryChoice. noSwitchView selector: #active. noSwitchView controller selector: #selectFalse. noSwitchView controller cursor: Cursor thumbsDown. noSwitchView label: 'no' asParagraph. noSwitchView window: (0@0 extent: anInteger//2 @ noSwitchView window height). switchView addSubView: yesSwitchView. switchView addSubView: noSwitchView toRightOf: yesSwitchView. switchView borderWidthLeft: 0 right: 0 top: 2 bottom: 0. ^switchView! ! Object subclass: #BitBlt instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Support'! BitBlt comment: 'The BitBlt operation copies bits from one rectangle within a Form (source) to another (dest). The result is stored according to a combination rule which specifies one of the sixteen possibilities for how white and black should be combined. Instance Variables: destForm
destination of a copy sourceForm source from which to copy halftoneForm screen to mask the source during the copy combinationRule between 0 and 15 destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight If halftoneForm is not nil, it is a halftone screen which masks (is ANDed with) the source during the operation. Halftones are 16x16 bit Forms which are repeated indefinitely as needed by the BitBlt operation. with the two forms and a halftoneForm. If sourceForm is nil, the halftone is taken by itself to be the source, as for filling with a constant pattern. The clipping parameters specify a rectangle in the destination outside of which BitBlt will not make any changes '! !BitBlt methodsFor: 'accessing'! clipHeight: anInteger "Set the clipHeight instance variable in BitBlt." clipHeight _ anInteger! clipRect "Answer the clipX, clipY clipWidth and clipHeight instance variables in BitBlt." ^clipX @ clipY extent: clipWidth @ clipHeight! clipRect: aRectangle "Set the clipX, clipY clipWidth andclipHeight instance variables in BitBlt. This is a shorthand way to set four of the parameters to BitBlt." clipX _ aRectangle left. clipY _ aRectangle top. clipWidth _ aRectangle width. clipHeight _ aRectangle height! clipWidth: anInteger "Set the clipWidth instance variable in BitBlt." clipWidth _ anInteger! clipX: anInteger "Set the clipX instance variable in BitBlt." clipX _ anInteger! clipY: anInteger "Set the clipY instance variable in BitBlt." clipY _ anInteger! combinationRule: anInteger "Set the combinationRule instance variable in BitBlt. anInteger is in the range 0-16." combinationRule _ anInteger! destForm: aForm "Set the destinationForm instance variable in BitBlt." destForm _ aForm! destOrigin: aPoint "Set the destination coordinates to be those of aPoint." destX _ aPoint x. destY _ aPoint y! destRect "return the destination rectangle" ^destX@destY extent: width@height! destRect: aRectangle "Set the destination coordinates to be those of aRectangle top left and the width and height of the receiver to be the width and height of aRectangle." destX _ aRectangle left. destY _ aRectangle top. width _ aRectangle width. height _ aRectangle height! destX: anInteger "Set the destX instance variable in BitBlt." destX _ anInteger! destY: anInteger "Set the destY instance variable in BitBlt." destY _ anInteger! height: anInteger "Set the height instance variable in BitBlt ." height _ anInteger! mask: aForm "Set the halftoneForm instance variable in BitBlt." halftoneForm _ aForm! sourceForm: aForm "Set the sourceForm instance variable in BitBlt." sourceForm _ aForm! sourceOrigin: aPoint "Set the source form coordinats to be those of aPoint." sourceX _ aPoint x. sourceY _ aPoint y! sourceRect: aRectangle "Set the sourceX, sourceY width and height instance variables in BitBlt. This is a shorthand way to set four of the parameters to BitBlt." sourceX _ aRectangle left. sourceY _ aRectangle top. width _ aRectangle width. height _ aRectangle height! sourceX: anInteger "Set the sourceX instance variable in BitBlt." sourceX _ anInteger! sourceY: anInteger "Set the sourceY instance variable in BitBlt." sourceY _ anInteger! width: anInteger "Set the width instance variable in BitBlt." width _ anInteger! ! !BitBlt methodsFor: 'copying'! clipFully "Do the clipping in Smalltalk (after the primitive failed, and after truncating all parameters to integers). Fixes very negative or very large rectangles." | deltaLeft deltaTop deltaRight deltaBottom | deltaLeft _ clipX - destX max: 0. deltaTop _ clipY - destY max: 0. deltaRight _ clipX + clipWidth - (destX + width) min: 0. deltaBottom _ clipY + clipHeight - (destY + height) min: 0. destX _ destX + deltaLeft. destY _ destY + deltaTop. sourceX _ sourceX + deltaLeft. sourceY _ sourceY + deltaTop. height _ height - deltaTop + deltaBottom max: 0. width _ width - deltaLeft + deltaRight max: 0. clipX _ clipX max: 0. clipY _ clipY max: 0. clipHeight _ clipHeight max: 0. clipWidth _ clipWidth max: 0! copyBits "Perform the movement of bits from one From to another described by the instance variables of the receiver. Fail if any instance variables are not of the right type (Integer or Form) or if combinationRule is not between 0 and 15 inclusive. Set the variables and try again (BitBlt|copyBitsAgain). Essential. See Object documentation whatIsAPrimitive." combinationRule = Form paint ifTrue: [^self paintBits] ifFalse: [^self copy truncateFully; "Handle Float coordinates" copyBitsAgain]! copyBitsAgain (self clipRect intersects: self destRect) "check for intersection before clipping" ifTrue: [self clipFully. "Clipping for very negative or very large rectangles" ^self copyBitsAgainAgain]! copyBitsAgainAgain self primitiveFailed! paintBits "Perform the paint operation, which may require two calls to BitBlt." | oldMask | (halftoneForm == nil or: [halftoneForm == Form black]) ifFalse: "optimization" [oldMask _ halftoneForm. combinationRule _ Form erase. halftoneForm _ nil. self copyBits. "first erase hole in dest" halftoneForm _ oldMask]. halftoneForm == Form white ifFalse: "optimization" [combinationRule _ Form under. self copyBits]. combinationRule _ Form paint. "restore rule" "(Form dotOfSize: 32) displayOn: Display at: Sensor cursorPoint clippingBox: Display boundingBox rule: Form paint mask: Form lightGray"! truncateFully "Truncate all coordinates in case any of them was a Float." destX _ destX truncated. destY _ destY truncated. width _ width truncated. height _ height truncated. sourceX _ sourceX truncated. sourceY _ sourceY truncated. clipX _ clipX truncated. clipY _ clipY truncated. clipWidth _ clipWidth truncated. clipHeight _ clipHeight truncated! ! !BitBlt methodsFor: 'line drawing'! drawFrom: startPoint to: stopPoint | offset point1 point2 | "Always draw down, or at least left-to-right" ((startPoint y = stopPoint y and: [startPoint x < stopPoint x]) or: [startPoint y < stopPoint y]) ifTrue: [point1 _ startPoint. point2 _ stopPoint] ifFalse: [point1 _ stopPoint. point2 _ startPoint]. width _ sourceForm width. height _ sourceForm height. offset _ sourceForm offset. destX _ (point1 x + offset x) rounded. destY _ (point1 y + offset y) rounded. self drawLoopX: (point2 x - point1 x) rounded Y: (point2 y - point1 y) rounded! drawLoopX: xDelta Y: yDelta "This is the Bresenham plotting algorithm (IBM Systems Journal Vol 4 No. 1, 1965). It chooses a principal direction, and maintains a potential, P. When P's sign changes, it is time to move in the minor direction as well. Optional. See Object documentation whatIsAPrimitive." | dx dy px py P i | combinationRule = Form paint ifTrue: [^self paintLoopX: xDelta Y: yDelta ]. dx _ xDelta sign. dy _ yDelta sign. px _ yDelta abs. py _ xDelta abs. self copyBits. py > px ifTrue: ["more horizontal" P _ py // 2. i _ 0. [(i _ i + 1) <= py] whileTrue: [destX _ destX + dx. (P _ P - px) < 0 ifTrue: [destY _ destY + dy. P _ P + py]. self copyBits]] ifFalse: ["more vertical" P _ px // 2. i _ 0. [(i _ i + 1) <= px] whileTrue: [destY _ destY + dy. (P _ P - py) < 0 ifTrue: [destX _ destX + dx. P _ P + px]. self copyBits]]! paintLoopX: xDelta Y: yDelta "Perform the paint operation, which may require two calls to BitBlt." | oldMask startX startY | (halftoneForm == nil or: [halftoneForm == Form black]) ifFalse: ["optimization" startX _ destX. startY _ destY. oldMask _ halftoneForm. combinationRule _ Form erase. halftoneForm _ nil. self drawLoopX: xDelta Y: yDelta. "first erase hole in dest" halftoneForm _ oldMask. destX _ startX. destY _ startY ]. halftoneForm == Form white ifFalse: ["optimization" combinationRule _ Form under. self drawLoopX: xDelta Y: yDelta]. combinationRule _ Form paint! ! !BitBlt methodsFor: 'private'! setDestForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect | aPoint | destForm _ df. sourceForm _ sf. halftoneForm _ hf. combinationRule _ cr. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourceOrigin x. sourceY _ sourceOrigin y. width _ extent x. height _ extent y. aPoint _ clipRect origin. clipX _ aPoint x. clipY _ aPoint y. aPoint _ clipRect corner. clipWidth _ aPoint x - clipX. clipHeight _ aPoint y - clipY! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BitBlt class instanceVariableNames: ''! !BitBlt class methodsFor: 'instance creation'! destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect "Answer an instance of the receiver with values set according to the arguments. " ^self new setDestForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! toReverse: aRectangle "Answer a new instance of the receiveer that will reverse a particular rectangle in the destination (which must be supplied later)." ^self destForm: nil sourceForm: nil halftoneForm: nil combinationRule: Form reverse destOrigin: aRectangle origin sourceOrigin: 0 @ 0 extent: aRectangle extent clipRect: aRectangle! ! !BitBlt class methodsFor: 'examples'! exampleOne "This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the Byte magazine article by D. Ingalls for the meaning of the combination rules and the complete documentation for BitBlt in Smalltalk-80.)" "BitBlt exampleOne." | path | path _ Path new. 0 to: 3 do: [:i | 0 to: 3 do: [:j | path add: j * 100 @ (i * 100)]]. Display white. path _ path translateBy: 100 @ 100. 1 to: 16 do: [:index | BitBlt exampleAt: (path at: index) rule: index - 1 mask: Form gray]! exampleTwo "This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for awhile and then automatically stops." "BitBlt exampleTwo." | f aBitBlt | "create a small black Form source as a brush." f _ Form new extent: 20 @ 20. f black. "create a BitBlt which will OR gray into the display" aBitBlt _ BitBlt destForm: Display sourceForm: f halftoneForm: Form gray combinationRule: Form under destOrigin: Sensor cursorPoint sourceOrigin: 0 @ 0 extent: f extent clipRect: Display computeBoundingBox. "paint the gray Form on the screen for a while" 1 to: 5000 do: [:i | aBitBlt destOrigin: Sensor cursorPoint. aBitBlt copyBits]! ! !BitBlt class methodsFor: 'private'! exampleAt: originPoint rule: rule mask: mask "This builds a source and destination form and copies the source to the destination using the specifed rule and mask. It is called from the method named exampleOne." | s d border aBitBlt | border_Form new extent: 32@32. border black. border fill: (1@1 extent: 30@30) mask: Form white. s_Form new extent: 32@32. s white. s fill: (7@7 corner: 25@25) mask: Form black. d_Form new extent: 32@32. d white. d fill: (0@0 corner: 32@16) mask: Form black. s displayOn: Display at: originPoint. border displayOn: Display at: originPoint rule: Form under. d displayOn: Display at: originPoint + (s width @0). border displayOn: Display at: originPoint + (s width @0) rule: Form under. d displayOn: Display at: originPoint + (s extent // (2 @ 1)). aBitBlt _ BitBlt destForm: Display sourceForm: s halftoneForm: mask combinationRule: rule destOrigin: originPoint + (s extent // (2 @ 1)) sourceOrigin: 0 @ 0 extent: s extent clipRect: Display computeBoundingBox. aBitBlt copyBits. border displayOn: Display at: originPoint + (s extent // (2 @ 1)) rule: Form under. "BitBlt exampleAt: 100@100 rule: 3 mask: Form gray."! ! MouseMenuController subclass: #BitEditor instanceVariableNames: 'scale squareForm color ' classVariableNames: 'YellowButtonMenu YellowButtonMessages ' poolDictionaries: '' category: 'Graphics-Editors'! BitEditor comment: 'A BitEditor is a bit-magnifying tool for editing small Forms directly on the display screen. Instance Variables: scale squareForm color denoting the color for marking a bit Class Variables: YellowButtonMenu to be displayed when the yellow button is pressed YellowButtonMessages of message names, one associated with each item in the YellowButtonMenu'! !BitEditor methodsFor: 'initialize-release'! initialize super initialize. self initializeYellowButtonMenu! release super release. squareForm release. squareForm _ nil! ! !BitEditor methodsFor: 'view access'! view: aView super view: aView. scale _ aView transformation scale. scale _ scale x rounded @ scale y rounded. squareForm _ Form new extent: scale. squareForm black! ! !BitEditor methodsFor: 'basic control sequence'! controlInitialize super controlInitialize. Cursor crossHair show! controlTerminate Cursor normal show! ! !BitEditor methodsFor: 'control defaults'! controlActivity | absoluteScreenPoint formPoint displayPoint | super controlActivity. [sensor redButtonPressed] whileTrue: [absoluteScreenPoint _ sensor cursorPoint. formPoint _ (view inverseDisplayTransform: absoluteScreenPoint - (scale//2)) rounded. displayPoint _ view displayTransform: formPoint. squareForm displayOn: Display at: displayPoint clippingBox: view insetDisplayBox rule: Form over mask: (Form perform: color). view changeValueAt: formPoint put: (#(white black gray) indexOf: color)-1].! isControlActive ^super isControlActive & sensor blueButtonPressed not & sensor keyboardPressed not! ! !BitEditor methodsFor: 'menu messages'! accept "The edited information should now be accepted by the view." view accept! cancel "The edited informatin should be forgotten by the view." view cancel! setColor: aSymbol color _ aSymbol! ! !BitEditor methodsFor: 'private'! initializeYellowButtonMenu self yellowButtonMenu: YellowButtonMenu yellowButtonMessages: YellowButtonMessages! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BitEditor class instanceVariableNames: ''! !BitEditor class methodsFor: 'class initialization'! initialize "The Bit Editor is the only controller to override the use of the blue button with a different pop-up menu. Initialize this menu." "BitEditor initialize." YellowButtonMenu _ PopUpMenu labels: 'accept cancel'. YellowButtonMessages _ #(accept cancel )! ! !BitEditor class methodsFor: 'instance creation'! openOnForm: aForm | scaleFactor | scaleFactor _ 8 @ 8. ^ self openOnForm: aForm at: (self locateMagnifiedView: aForm scale: scaleFactor) topLeft scale: scaleFactor! openOnForm: aForm at: magnifiedLocation ^ self openOnForm: aForm at: magnifiedLocation scale: 8 @ 8! openOnForm: aForm at: magnifiedLocation scale: scaleFactor "Create and schedule a BitEditor on the form aForm. Show the small and magnified view of aForm." | aScheduledView | aScheduledView _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: nil. aScheduledView controller openDisplayAt: aScheduledView displayBox topLeft + (aScheduledView displayBox extent / 2)! openScreenViewOnForm: aForm at: formLocation magnifiedAt: magnifiedLocation scale: scaleFactor "Create and schedule a BitEditor on the form aForm. Show the magnified view of aForm in a scheduled window." | smallFormView bitEditor savedForm | smallFormView _ FormView new model: aForm. smallFormView align: smallFormView viewport topLeft with: formLocation. bitEditor _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: smallFormView. savedForm _ Form fromDisplay: bitEditor displayBox. bitEditor controller blueButtonMenu: nil blueButtonMessages: nil. bitEditor controller startUp. savedForm displayOn: Display at: bitEditor displayBox topLeft. bitEditor release. smallFormView release! ! !BitEditor class methodsFor: 'examples'! magnifyOnScreen "Bit editing of an area of the display screen. User designates a rectangular area that is magnified by 8 to allow individual screens dots to be modified. Editor is not scheduled in a view. Original screen location is updated immediately. This is the same as FormEditor magnify." "BitEditor magnifyOnScreen." | smallRect smallForm scaleFactor tempRect | scaleFactor _ 8 @ 8. smallRect _ Rectangle fromUser. smallRect isNil ifTrue: [^self]. smallForm _ Form fromDisplay: smallRect. tempRect _ self locateMagnifiedView: smallForm scale: scaleFactor. "show magnified form size until mouse is depressed" BitEditor openScreenViewOnForm: smallForm at: smallRect topLeft magnifiedAt: tempRect topLeft scale: scaleFactor! magnifyWithSmall "Bit editing of an area of the Form. User designates a rectangular area that is magnified by 8 to allow individual screens dots to be modified. Editor is scheduled in a view, showing the magnified view only." "BitEditor magnifyWithSmall." | smallRect smallForm | smallRect _ Rectangle fromUser. smallRect isNil ifTrue: [^self]. smallForm _ Form fromDisplay: smallRect. BitEditor openOnForm: smallForm! ! !BitEditor class methodsFor: 'private'! bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView "Creates a BitEditor on aForm. That is, aForm is a small image that will change as a result of the BitEditor changing a second and magnified view of me. magnifiedFormLocation is where the magnified form is to be located on the screen. scaleFactor is the amount of magnification. This method implements a scheduled view containing both a small and magnified view of aForm. Upon accept, aForm is updated." | aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent | scaledFormView _ FormHolderView new model: aForm. scaledFormView scaleBy: scaleFactor. bitEditor _ self new. bitEditor setColor: #black. scaledFormView controller: bitEditor. topView _ StandardSystemView new. remoteView == nil ifTrue: [topView label: 'Bit Editor']. topView borderWidth: 2. topView insideColor: Form white. topView addSubView: scaledFormView. remoteView == nil ifTrue: "If no remote view, then provide a local view of the form" [aFormView _ FormView new model: scaledFormView workingForm. aFormView controller: NoController new. (aForm isMemberOf: OpaqueForm) ifTrue: [scaledFormView insideColor: Form gray. aFormView insideColor: Form white]. aForm height < 50 ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2] ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0]. topView addSubView: aFormView below: scaledFormView] ifFalse: "Otherwise, the remote one should view the same form" [remoteView model: scaledFormView workingForm]. lowerRightExtent _ remoteView == nil ifTrue: [(scaledFormView viewport width - aFormView viewport width) @ (aFormView viewport height max: 50)] ifFalse: [scaledFormView viewport width @ 50]. menuView _ self buildColorMenu: lowerRightExtent colorCount: ((aForm isMemberOf: OpaqueForm) ifTrue: [3] ifFalse: [2]). menuView model: bitEditor. menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0. topView addSubView: menuView align: menuView viewport topRight with: scaledFormView viewport bottomRight. extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y) + (4 @ 4). "+4 for borders" topView minimumSize: extent. topView maximumSize: extent. topView translateBy: magnifiedFormLocation. ^topView! buildColorMenu: extent colorCount: nColors "BitEditor magnifyWithSmall." | menuView form aSwitchView connector button formExtent highlightForm color leftOffset | connector _ Object new. menuView _ FormMenuView new. menuView window: (0@0 corner: extent). formExtent _ 30@30 min: extent//(nColors*2+1@2). "compute this better" leftOffset _ extent x-(nColors*2-1*formExtent x)//2. highlightForm _ Form extent: formExtent. highlightForm borderWidth: 4 mask: Form black. 1 to: nColors do: [:index | color _ (nColors=2 ifTrue: [#(white black)] ifFalse: [#(white gray black)]) at: index. form _ Form extent: formExtent. form fill: form boundingBox mask: (Form perform: color). form borderWidth: 5 mask: Form black. color = #black ifTrue: [form borderWidth: 5 mask: Form white]. form borderWidth: 4 mask: Form white. button _ color = #black ifTrue: [OneOnSwitch newOn] ifFalse: [OneOnSwitch newOff]. button onAction: [menuView model setColor: color]. button connection: connector. aSwitchView _ SwitchView new model: button. aSwitchView key: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index). aSwitchView label: form. aSwitchView window: (0@0 extent: form extent). aSwitchView translateBy: (index-1*2*form width+leftOffset) @ (form height//2). aSwitchView insideColor: Form white. aSwitchView highlightForm: highlightForm. aSwitchView borderWidth: 1. aSwitchView controller selector: #turnOn. menuView addSubView: aSwitchView]. ^menuView! locateMagnifiedView: aForm scale: scaleFactor "Answers with a rectangle at the location where the scaled view of the form aForm should be displayed." | tempExtent tempRect | tempExtent _ aForm extent * scaleFactor + (0@50). tempRect _ (Sensor cursorPoint" grid: scaleFactor") extent: tempExtent. "show magnified form size until mouse is depressed" [Sensor redButtonPressed] whileFalse: [Display reverse: tempRect. Display reverse: tempRect. tempRect _ (Sensor cursorPoint grid: scaleFactor) extent: tempExtent]. ^tempRect! ! BitEditor initialize! ContextPart variableSubclass: #BlockContext instanceVariableNames: 'nargs startpc home ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! BlockContext comment: 'Instances of class BlockContext function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution. Instance Variables: *indexed* nargs number of block arguments startpc home An instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity. '! !BlockContext methodsFor: 'initialize-release'! home: aContextPart startpc: position nargs: anInteger "This is the initialization message. The receiver has been initialized with the correct size only." home _ aContextPart. startpc _ position. nargs _ anInteger. pc _ position. stackp _ 0! ! !BlockContext methodsFor: 'accessing'! fixTemps "Fix the values of the temporary variables used in the block that are ordinarily shared with the method in which the block is defined." home _ home copy. home swapSender: nil! hasMethodReturn "answer true if there is an ^ in the code of this block" | method scanner end | method _ self method. "Determine end of block from long jump preceding it" end _ (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1. scanner _ InstructionStream new method: method pc: startpc. scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. ^ scanner pc <= end! home "Answer the context in which the receiver was defined." ^home! method "Answer the compiled method in which the receiver was defined." ^home method! receiver ^home receiver! ! !BlockContext methodsFor: 'temporaries'! tempAt: index ^home at: index! tempAt: index put: value ^home at: index put: value! ! !BlockContext methodsFor: 'evaluating'! value "Evaluate the block represented by the receiver. Fail if the block expects any arguments or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: #()! value: arg "Evaluate the block represented by the receiver. Fail if the block expects other than one argument or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg)! value: arg1 value: arg2 "Evaluate the block represented by the receiver. Fail if the block expects other than two arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2)! value: arg1 value: arg2 value: arg3 "Evaluate the block represented by the receiver. Fail if the block expects other than three arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2 with: arg3)! valueWithArguments: anArray "Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." nargs = anArray size ifTrue: [self valueError] ifFalse: [self error: 'The block needs more or fewer arguments defined']! ! !BlockContext methodsFor: 'controlling'! whileFalse "Evaluate the receiver once and then repeatedly as long as the value returned by the evaluation is false." ^[self value] whileFalse: []! whileFalse: aBlock "Evaluate the argument, aBlock, as long as the value of the receiver is false. Ordinarily compiled in-line. But could also be done in Smalltalk as follows" ^self value ifFalse: [aBlock value. self whileFalse: aBlock]! whileTrue "Evaluate the receiver once and then repeatedly as long as the value returned by the evaluation is true." ^[self value] whileTrue: []! whileTrue: aBlock "Evaluate the argument, aBlock, as long as the value of the receiver is true. Ordinarily compiled in-line. But could also be done in Smalltalk as follows" ^self value ifTrue: [aBlock value. self whileTrue: aBlock]! ! !BlockContext methodsFor: 'scheduling'! fork "Create and schedule a process running the code in the receiver." self newProcess resume! forkAt: priority "Create and schedule a process running the code in the receiver. The priority of the process is the argument, priority." | forkedProcess | forkedProcess _ self newProcess. forkedProcess priority: priority. forkedProcess resume! newProcess "Answer a new process running the code in the receiver. The process is not scheduled." ^Process forContext: [self value. Processor terminateActive] priority: Processor activePriority! newProcessWith: anArray "Answer a new process running the code in the receiver. The receiver's block arguments are bound to the contents of the argument, anArray. The process is not scheduled." ^Process forContext: [self valueWithArguments: anArray. Processor terminateActive] priority: Processor activePriority! ! !BlockContext methodsFor: 'instruction decoding'! blockReturnTop "Simulate the interpreter's action when a ReturnTopOfStack bytecode is encountered in the receiver." | save dest | save _ home. "Needed because return code will nil it" dest _ self return: self pop to: self sender. home _ save. sender _ nil. ^dest! pushArgs: args from: sendr "Simulates action of the value primitive." args size ~= nargs ifTrue: [^self error: 'incorrect number of args']. stackp _ 0. args do: [:arg | self push: arg]. sender _ sendr. pc _ startpc! ! !BlockContext methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil']. aStream nextPutAll: '[] in '. super printOn: aStream! ! !BlockContext methodsFor: 'private'! valueError self error: 'Incompatible number of args, or already active'! ! ParseNode subclass: #BlockNode instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode sourceRange endPC ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! BlockNode comment: 'I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.'! !BlockNode methodsFor: 'initialize-release'! arguments: argNodes statements: statementsCollection returns: returnBool from: encoder sourceEnd: sourceEnd "compile" sourceRange _ sourceEnd to: sourceEnd. arguments _ argNodes. statements _ statementsCollection size > 0 ifTrue: [statementsCollection] ifFalse: [argNodes size > 0 ifTrue: [statementsCollection copyWith: arguments last] ifFalse: [Array with: NodeNil]]. returns _ returnBool! default "[] argument of missing kwyword in ifTrue: or ifFalse:" statements _ Array with: NodeNil. arguments _ Array new: 0. returns _ false! statements: statementsCollection returns: returnBool "decompile" | returnLast | returnLast _ returnBool. returns _ false. statements _ (statementsCollection size > 1 and: [(statementsCollection at: statementsCollection size - 1) isReturningIf]) ifTrue: [returnLast _ false. statementsCollection copyFrom: 1 to: statementsCollection size - 1] ifFalse: [statementsCollection size = 0 ifTrue: [Array with: NodeNil] ifFalse: [statementsCollection]]. arguments _ Array new: 0. returnLast ifTrue: [self returnLast]! ! !BlockNode methodsFor: 'accessing'! arguments: argNodes "decompile" arguments _ argNodes! numberOfArguments ^arguments size! returnLast self returns ifFalse: [returns _ true. statements at: statements size put: statements last asReturnNode]! returnSelfIfNoOther self returns ifFalse: [statements last == NodeSelf ifFalse: [statements add: NodeSelf]. self returnLast]! ! !BlockNode methodsFor: 'testing'! canBeSpecialArgument "can I be an argument of (e.g.) ifTrue:?" ^arguments size = 0! isComplex ^statements size > 1! isJust: node returns ifTrue: [^false]. ^statements size = 1 and: [statements first == node]! isQuick ^statements size = 1 and: [statements first isVariableReference]! returns ^returns or: [statements last isReturningIf]! ! !BlockNode methodsFor: 'code generation'! code ^statements first code! emitExceptLast: stack on: aStream 1 to: statements size - 1 do: [:i | (statements at: i) emitForEffect: stack on: aStream]! emitForEvaluatedEffect: stack on: aStream self returns ifTrue: [self emitForEvaluatedValue: stack on: aStream. stack pop: 1] ifFalse: [self emitExceptLast: stack on: aStream. statements last emitForEffect: stack on: aStream]! emitForEvaluatedValue: stack on: aStream self emitExceptLast: stack on: aStream. statements last emitForValue: stack on: aStream! emitForValue: stack on: aStream | blockStack | aStream nextPut: LdThisContext. stack push: 1. nArgsNode emitForValue: stack on: aStream. remoteCopyNode emit: stack args: 1 on: aStream. "jmp-around must be 2 bytes" self emitLongJump: size on: aStream. "Block gets its own stack in blockContext" blockStack _ ParseStack new init. blockStack push: arguments size. arguments reverseDo: [:arg | arg emitStorePop: blockStack on: aStream]. self emitForEvaluatedValue: blockStack on: aStream. endPC _ aStream position+1. self returns ifFalse: [aStream nextPut: EndRemote]. blockStack pop: 1. stack max: blockStack size! pc ^ endPC! sizeExceptLast: encoder | totalSize | totalSize _ 0. 1 to: statements size - 1 do: [:i | totalSize _ totalSize + ((statements at: i) sizeForEffect: encoder)]. ^totalSize! sizeForEvaluatedEffect: encoder self returns ifTrue: [^self sizeForEvaluatedValue: encoder]. ^(self sizeExceptLast: encoder) + (statements last sizeForEffect: encoder)! sizeForEvaluatedValue: encoder ^(self sizeExceptLast: encoder) + (statements last sizeForValue: encoder)! sizeForValue: encoder nArgsNode _ encoder encodeLiteral: arguments size. remoteCopyNode _ encoder encodeSelector: #blockCopy:. size _ self sizeForEvaluatedValue: encoder. self returns ifFalse: [size _ size+1. "end-block" encoder noteSourceRange: sourceRange forNode: self]. arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)]. ^1 + (nArgsNode sizeForValue: encoder) + (remoteCopyNode size: encoder) + 2 + size! ! !BlockNode methodsFor: 'printing'! printArgumentsOn: aStream indent: level arguments size = 0 ifFalse: [arguments do: [:arg | aStream nextPut: $:. aStream nextPutAll: arg key. aStream space]. aStream nextPutAll: '| '. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]]! printOn: aStream indent: level statements size <= 1 ifFalse: [aStream crtab: level]. aStream nextPut: $[. self printArgumentsOn: aStream indent: level. self printStatementsOn: aStream indent: level. aStream nextPut: $]! printStatementsOn: aStream indent: level | len shown thisStatement | comment == nil ifFalse: [self printCommentOn: aStream indent: level. aStream crtab: level]. len _ shown _ statements size. (level = 1 and: [statements last isReturnSelf]) ifTrue: [shown _ 1 max: shown - 1] ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)]) ifTrue: [shown _ shown - 1]]. 1 to: shown do: [:i | thisStatement _ statements at: i. thisStatement == NodeSelf ifFalse: [thisStatement printOn: aStream indent: level. i < shown ifTrue: [aStream nextPut: $.; crtab: level]. thisStatement comment size > 0 ifTrue: [i = shown ifTrue: [aStream crtab: level]. thisStatement printCommentOn: aStream indent: level. i < shown ifTrue: [aStream crtab: level]]]]! ! Object subclass: #Boolean instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! Boolean comment: 'Class Boolean is an abstract class that implements behavior common to true and false. Its subclasses are True and False. Subclasses must implement methods for logical operations & not | controlling and: or: ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: '! !Boolean methodsFor: 'logical operations'! & aBoolean "Evaluating conjunction. Evaluate the argument. Answer true if both the receiver and the argument are true." self subclassResponsibility! eqv: aBoolean "Answer true if the receiver is equivalent to aBoolean." ^self == aBoolean! not "Negation. Answer true if the receiver is false, answer false if the receiver is true." self subclassResponsibility! xor: aBoolean "Exclusive OR. Answer true if the receiver is not equivalent to aBoolean." ^(self == aBoolean) not! | aBoolean "Evaluating disjunction (OR). Evaluate the argument. Answer true if either the receiver or the argument is true." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! and: alternativeBlock "Nonevaluating conjunction. If the receiver is true, answer the value of the argument, alternativeBlock; otherwise answer false without evaluating the argument." self subclassResponsibility! ifFalse: alternativeBlock "If the receiver is true (i.e., the condition is true), then the value is the true alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Same as ifTrue:ifFalse:" self subclassResponsibility! ifTrue: alternativeBlock "If the receiver is false (i.e., the condition is false), then the value is the false alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock "If the receiver is true (i.e., the condition is true), then answer the value of the argument trueAlternativeBlock. If the receiver is false, answer the result of evaluating the argument falseAlternativeBlock. If the receiver is a nonBoolean then create an error message. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! or: alternativeBlock "Nonevaluating disjunction. If the receiver is false, answer the value of the argument, alternativeBlock; otherwise answer true without evaluating the argument." self subclassResponsibility! ! !Boolean methodsFor: 'copying'! deepCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self." ^self! shallowCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self." ^self! ! !Boolean methodsFor: 'printing'! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver." self printOn: aStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Boolean class instanceVariableNames: ''! !Boolean class methodsFor: 'instance creation'! new "Provide an error notification that it is not appropriate to create an instance of the receiver." self error: 'You may not create any more Booleans - this is two-valued logic'! ! SwitchView subclass: #BooleanView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! BooleanView comment: 'BooleanView is a "pluggable" view of a boolean value. The notion of pluggable views is an experiment in user interface design. The idea is to provide a view which can be plugged onto any object, rather than having to define a new subclass specific to every kind of object which needs to be viewed. The chief mechanism is a set of selectors, which can be thought of as an adaptor to convert the generic textView operations (such as interrogateModel) into model-specific operations (such as metaclassSelected). See the creation messages in my class for an explication of the various parameters. Browse senders of the creation messages in my class for examples in the system.'! !BooleanView methodsFor: 'updating'! interrogateModel ^ (model perform: selector) = arguments first! update: aspect aspect == selector ifTrue: [super update: aspect]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BooleanView class instanceVariableNames: ''! !BooleanView class methodsFor: 'instance creation'! on: model aspect: aspect label: label change: changeSel value: onValue "Create a 'pluggable' (see class comment) switchView viewing anObject. aspect is sent to read the current boolean value in the model. It is also used as the changed: parameter for this view. changeSel is sent to inform anObject of new boolean value for the model." | view args | view _ self new. view model: model. view selector: aspect; arguments: (args _ Array with: onValue). view controller selector: changeSel; arguments: args. view label: label asParagraph. ^view! ! Model subclass: #Browser instanceVariableNames: 'organization category className meta protocol selector textMode ' classVariableNames: 'CategoryMenu ClassMenu LastProtocol MessageMenu MethodMoveCategory MethodMoveProtocol ProtocolMenu TextMenu ' poolDictionaries: '' category: 'Interface-Browser'! Browser comment: 'A browser represents a hierarchical query path which identifies a method to be examined. organization - a SystemOrganizer category - a selection from all categories in the organization. className - a selection from all classes in the category. meta - false for viewing normal methods, true for class methods. protocol - a selection from all protocols in the class. selector - a selection from all messages in the protocol. textMode - symbol indicating the nature of the currently viewed text.'! !Browser methodsFor: 'initialization'! on: anOrganizer organization _ anOrganizer. meta _ false! onClass: aClass organization _ SystemOrganization. className _ aClass isMeta ifTrue: [aClass soleInstance name] ifFalse: [aClass name]. meta _ aClass isMeta! ! !Browser methodsFor: 'category list'! category ^ category! category: selection category _ selection. selection isNil ifTrue: [self textMode: nil]. self newClassList: className! categoryList ^ organization categories! categoryMenu "Browser flushMenus" category == nil ifTrue: [^ ActionMenu labels: 'add category\update\edit all\find class' withCRs lines: #(1 3) selectors: #(addCategory updateCategories editCategories findClass)]. CategoryMenu == nil ifTrue: [CategoryMenu _ ActionMenu labels: 'file out\print out\spawn\add category\rename\remove\update\edit all\find class' withCRs lines: #(3 6 8) selectors: #(fileOutCategory printOutCategory spawnCategory addCategory renameCategory removeCategory updateCategories editCategories findClass)]. ^ CategoryMenu! newCategoryList: initialSelection category _ initialSelection. self changed: #category! ! !Browser methodsFor: 'category functions'! addCategory | aString newCategory | self changeRequest ifFalse: [^self]. aString _ self prompt: 'Enter new category name' initially: 'category name'. aString isEmpty ifTrue: [^ self]. newCategory _ aString asSymbol. organization addCategory: newCategory before: category. Smalltalk changes reorganizeSystem. self newCategoryList: newCategory! editCategories self changeRequest ifFalse: [^self]. self textMode: #categories! fileOutCategory |fileName aFileStream| fileName _ FillInTheBlank request: 'File out on' initialAnswer: (category, '.st'). fileName = '' ifTrue: [^nil]. aFileStream _ FileStream fileNamed: fileName. organization fileOutCategory: category on: aFileStream. aFileStream shorten; close! findClass "Prompt for a class and position myself there." | testClass | testClass _ self pickAClass: 'Find class:'. testClass == nil ifTrue: [^Transcript cr; show: 'Nobody']. (testClass isKindOf: Metaclass) ifTrue: [testClass _ testClass soleInstance]. (testClass isKindOf: Class) ifFalse: [testClass _ testClass class]. self changeRequest ifFalse: [^self]. self newCategoryList: testClass category. self newClassList: testClass name! pickAClass: prompt "Choose a class with a prompter. Bring up menu for wildcards." | destClassName destClass classes chosenSelector | destClassName _ FillInTheBlank request: prompt initialAnswer: '*'. destClassName = '' ifTrue: [^nil]. (destClassName findString: '*' startingAt: 1) ~=0 ifTrue: [classes _ OrderedCollection new. Cursor execute showWhile: [classes _ Smalltalk classNames select: [ :cn | destClassName match: cn]]. (classes == nil or: [classes size = 0]) ifTrue: [^nil]. (chosenSelector _ (PopUpMenu labelList: (Array with: classes)) startUp) = 0 ifTrue: [^nil] ifFalse: [destClassName _ classes at: chosenSelector]]. destClass _ Smalltalk at: destClassName asSymbol ifAbsent: [^nil]. meta ifTrue: [destClass _ destClass class]. ^destClass! printOutCategory "Default to being the same as file out." self fileOutCategory! removeCategory | classes | self changeRequest ifFalse: [^self]. classes _ organization superclassOrder: category. classes isEmpty ifFalse: [(self confirm: 'Are you certain that you want to remove all classes in this category?') ifFalse: [^self]. classes reverseDo: [:cls | cls removeFromSystem]]. organization removeCategory: category. Smalltalk changes reorganizeSystem. self newCategoryList: nil! renameCategory | aString newCategory | self changeRequest ifFalse: [^self]. aString _ self prompt: 'Enter new category name' initially: category. aString isEmpty ifTrue: [^ self]. newCategory _ aString asSymbol. (organization renameCategory: category to: newCategory) ifTrue: [Smalltalk changes reorganizeSystem. self newCategoryList: newCategory]! spawnCategory BrowserView openCategoryBrowserOn: self copy! updateCategories self changeRequest ifFalse: [^self]. self newCategoryList: category! ! !Browser methodsFor: 'class list'! classList category == nil ifTrue: [^ nil]. category = '**Hierarchy**' ifTrue: [^ (self selectedClass withAllSuperclasses reverse , self selectedClass allSubclasses) collect: [:cls | cls name]]. ^ organization listAtCategoryNamed: category! classMenu "Browser flushMenus" className == nil ifTrue: [^nil]. ClassMenu == nil ifTrue: [ClassMenu _ ActionMenu labels: 'file out\print out\spawn\spawn hierarchy hierarchy\definition\comment\protocols inst var refs\class var refs\class refs find method rename\remove' withCRs lines: #(4 8 11 12) selectors: #(fileOutClass printOutClass spawnClass spawnHierarchy showHierarchy editClass editComment editProtocols browseFieldReferences browseClassVariables browseClassReferences findMethodAndSelectAlphabetic renameClass removeClass)]. ^ ClassMenu! className ^ className! className: selection className _ selection. self newProtocolList: protocol. selection isNil & category notNil ifTrue: [self textMode: #classDefinition] ifFalse: [self classMode ifTrue: [self changed: #text]]! newClassList: initialSelection className _ initialSelection. self changed: #className! selectedClass className == nil ifTrue: [^ nil]. meta ifTrue: [^ (Smalltalk at: className) class] ifFalse: [^ Smalltalk at: className]! ! !Browser methodsFor: 'class functions'! acceptClass: aText from: aController | oldClass class name| oldClass _ className == nil ifTrue: [Object] ifFalse: [self selectedClass]. class _ oldClass subclassDefinerClass evaluate: aText string notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [(class isKindOf: Metaclass) ifTrue: [name _ class soleInstance name] ifFalse: [name _ class name]. self newClassList: name. ^true] ifFalse: [^false]! browseClassReferences Smalltalk browseAllCallsOn: (Smalltalk associationAt: className)! browseClassVariables "Show a menu of all class variables of the currently selected class and its superclasses. Browse all methods which refer to the variable selected." | association selectedClass | selectedClass _ self nonMetaClass. association _ selectedClass showVariableMenu: [:class | class classPool associations asSortedCollection] collect: [:assoc | assoc key]. association notNil ifTrue: [BrowserView openListBrowserOn: (selectedClass allCallsOn: association) label: 'Users of ' , association key initialSelection: association key]! browseFieldReferences "Show a menu of all instance variables of the currently selected class and its superclasses. Browse all methods which refer to the variable selected." | name | name _ self selectedClass showVariableMenu: [:class | class instVarNames] collect: [:cname | cname]. name notNil ifTrue: [BrowserView openListBrowserOn: (self selectedClass allAccessesTo: name) label: name initialSelection: name]! browseHierarchy "I am a copy; put me in the right state to browse a hierarchy" category _ '**Hierarchy**'. self meta: false! classMode ^#(classDefinition hierarchy comment protocols) includes: textMode! editClass self changeRequest ifFalse: [^self]. self textMode: #classDefinition. self newProtocolList: nil! editComment self changeRequest ifFalse: [^self]. self textMode: #comment. self newProtocolList: nil! editProtocols self changeRequest ifFalse: [^self]. self textMode: #protocols. self newProtocolList: nil! fileOutClass |fileName fileStream| fileName _ FillInTheBlank request: 'File out on' initialAnswer: (self nonMetaClass name, '.st'). fileName = '' ifTrue: [^nil]. fileStream _ FileStream fileNamed: fileName. fileStream timeStamp. self nonMetaClass fileOutOn: fileStream. fileStream close. self nonMetaClass removeFromChanges.! findMethodAndSelectAlphabetic "Show a menu of the methods implemented by this class. Select the chosen one." | chosenSelector selectorCollection | (selectorCollection _ self selectedClass organization elements asSortedCollection) size = 0 ifTrue: [^self]. chosenSelector _ (PopUpMenu labelList: (Array with: selectorCollection)) startUp. chosenSelector _ chosenSelector = 0 ifTrue: [nil] ifFalse: [selectorCollection at: chosenSelector]. chosenSelector isNil ifFalse: [self newProtocolList: (self selectedClass whichCategoryIncludesSelector: chosenSelector). self newSelectorList: chosenSelector]! nonMetaClass ^ meta ifTrue: [self selectedClass soleInstance] ifFalse: [self selectedClass]! printOutClass "Default to filing out the class." self fileOutClass! promptClass self newClassList: nil. self textMode: #classDefinition! removeClass | class | self changeRequest ifFalse: [^self]. class _ self nonMetaClass. (self confirm: 'Are you certain that you want to remove the class ', class name, '?') ifTrue: [class subclasses size > 0 ifTrue: [self notify: class name , ' has subclasses']. class removeFromSystem. self newClassList: nil]! renameClass | aString newName cleanString | self changeRequest ifFalse: [^self]. aString _ self prompt: 'Enter new ClassName' initially: self selectedClass name. aString isEmpty ifTrue: [^self]. cleanString _ aString select: [:char | char isAlphaNumeric]. cleanString = aString ifFalse: [aString _ cleanString. (self confirm: 'Invalid characters in class name. Should I use ', aString, '?') ifFalse: [^self]]. aString first isUppercase ifFalse: [aString at: 1 put: (aString at: 1) asUppercase. (self confirm: 'Class names must be capitalized. Should I use ', aString, '?') ifFalse: [^self]]. newName _ aString asSymbol. aString = self selectedClass name ifFalse: [self selectedClass rename: newName. self newClassList: newName. Transcript cr; show: 'Searching for references to this class...'. self browseClassReferences]! showHierarchy self changeRequest ifFalse: [^self]. self textMode: #hierarchy. self newProtocolList: nil! spawnClass BrowserView openClassBrowserOn: self copy! spawnHierarchy BrowserView openCategoryBrowserOn: self copy browseHierarchy! ! !Browser methodsFor: 'class/inst switch'! meta ^ meta! meta: aBoolean self changeRequest ifFalse: [^ self changed: #meta]. meta _ aBoolean. self changed: #meta. self newProtocolList: protocol. self classMode ifTrue: [self changed: #text]! ! !Browser methodsFor: 'protocol list'! newProtocolList: initialSelection protocol _ initialSelection. self changed: #protocol! protocol ^ protocol! protocol: selection protocol _ selection. selection == nil "save for addProtocol" ifFalse: [LastProtocol _ selection]. self classMode ifTrue: [^ self newSelectorList: nil]. selection isNil & className notNil ifTrue: [self textMode: #classDefinition]. self newSelectorList: selector! protocolList className == nil ifTrue: [^ nil]. ^ self selectedClass organization categories! protocolMenu "Browser flushMenus" protocol == nil ifTrue: [^ ActionMenu labels: 'add protocol' selectors: #(addProtocol)]. ProtocolMenu == nil ifTrue: [ProtocolMenu _ ActionMenu labels: 'file out\print out\spawn\add protocol\rename\remove' withCRs lines: #(3) selectors: #(fileOutProtocol printOutProtocol spawnProtocol addProtocol renameProtocol removeProtocol)]. ^ ProtocolMenu! ! !Browser methodsFor: 'protocol functions'! addProtocol | aString newProtocol | self changeRequest ifFalse: [^self]. aString _ self prompt: 'Enter new protocol name' initially: (LastProtocol == nil ifTrue: ['protocol name'] ifFalse: [LastProtocol]). aString isEmpty ifTrue: [^ self]. newProtocol _ aString asSymbol. self selectedClass organization addCategory: newProtocol before: protocol. self logProtocolChange: self selectedClass name, ' organization addCategory: ', newProtocol storeString, ' before: ', protocol storeString. self selectedClass reorganize. self newProtocolList: newProtocol! fileOutProtocol |fileName fileStream| fileName _ FillInTheBlank request: 'File out on' initialAnswer: (self selectedClass name, '-', protocol, '.st'). fileName = '' ifTrue: [^nil]. fileStream _ FileStream fileNamed: fileName. fileStream timeStamp. self selectedClass fileOutCategory: protocol on: fileStream moveSource: false toFile: 0. fileStream close! printOutProtocol "Default to filing out." self fileOutProtocol! removeProtocol | selectors | self changeRequest ifFalse: [^self]. selectors _ self selectedClass organization listAtCategoryNamed: protocol. selectors isEmpty ifFalse: [(self confirm: 'Are you certain that you want to remove all methods in this protocol?') ifFalse: [^self]. selectors do: [:sel | self selectedClass removeSelector: sel]]. self selectedClass organization removeCategory: protocol. self logProtocolChange: self selectedClass name, ' organization removeCategory: ', protocol storeString. self selectedClass reorganize. self newProtocolList: nil! renameProtocol | aString newProtocol | self changeRequest ifFalse: [^self]. aString _ self prompt: 'Enter new protocol name' initially: protocol. aString isEmpty ifTrue: [^ self]. newProtocol _ aString asSymbol. (self selectedClass organization renameCategory: protocol to: newProtocol) ifTrue: [self logProtocolChange: self selectedClass name, ' organization renameCategory: ', protocol storeString, ' to: ', newProtocol storeString. self selectedClass reorganize. self newProtocolList: newProtocol]! spawnProtocol BrowserView openProtocolBrowserOn: self copy! ! !Browser methodsFor: 'selector list'! newSelectorList: initialSelection selector _ initialSelection. self changed: #selector! selector ^ selector! selector: selection selector _ selection. (selection == nil and: [protocol == nil]) ifTrue: [^ self]. self textMode: #methodDefinition! selectorList protocol == nil ifTrue: [^ nil]. ^ self selectedClass organization listAtCategoryNamed: protocol! selectorMenu "Browser flushMenus" selector == nil ifTrue: [^ nil]. MessageMenu == nil ifTrue: [MessageMenu _ ActionMenu labels: 'file out\print out\spawn\senders\implementors\messages\move\remove' withCRs lines: #(3 6) selectors: #(fileOutMessage printOutMessage spawnMethod browseSenders browseImplementors browseMessages moveMethod removeMethod)]. ^ MessageMenu! ! !Browser methodsFor: 'selector functions'! acceptMethod: aText from: aController | newSelector | newSelector _ self selectedClass compile: aText classified: protocol notifying: aController. newSelector == nil ifTrue: [^false]. newSelector == selector ifFalse: [self newSelectorList: newSelector]. ^true! browseImplementors Smalltalk browseAllImplementorsOf: selector! browseMessages Smalltalk showMenuThenBrowse: (self selectedClass compiledMethodAt: selector) messages asSortedCollection! browseSenders Smalltalk browseAllCallsOn: selector! fileOutMessage |fileName fileStream sel| selector isKeyword ifTrue: [sel _ WriteStream on: (String new: 20). selector keywords do: [:each | sel nextPutAll: (each copyFrom: 1 to: each size - 1)]. sel _ sel contents] ifFalse: [sel _ selector]. fileName _ FillInTheBlank request: 'File out on' initialAnswer: (self selectedClass name, '-', sel, '.st'). fileName = '' ifTrue: [^nil]. fileStream _ FileStream fileNamed: fileName. fileStream timeStamp. self selectedClass fileOutMessage: selector on: fileStream moveSource: false toFile: 0. fileStream close! moveMethod | newProtocol classPart destClass protStart moved destClassName | self changeRequest ifFalse: [^self]. newProtocol _ self prompt: 'Type destination protocol (Class>protocol will copy)' initially: MethodMoveProtocol. newProtocol isEmpty ifTrue: [^self]. MethodMoveProtocol _ newProtocol. moved _ false. (newProtocol includes: $>) ifTrue: ["copy to another class" classPart _ newProtocol copyUpTo: $>. destClassName _ classPart copyUpTo: Character space. destClass _ Smalltalk at: destClassName asSymbol ifAbsent: [nil]. (destClass isKindOf: ClassDescription) ifFalse: [(Display flash: Display boundingBox). ^nil]. classPart size = destClassName size ifFalse: [(classPart size-destClassName size = 6 and: [(classPart copyFrom: classPart size - 5 to: classPart size) = ' class']) ifTrue: [destClass _ destClass class] ifFalse: [(Display flash: Display boundingBox). ^nil]]. protStart _ classPart size + 2. [(newProtocol at: protStart) = $ ] whileTrue: [protStart _ protStart + 1]. newProtocol _ (newProtocol copyFrom: protStart to: newProtocol size) asSymbol. destClass == self selectedClass ifFalse: [moved _ true. destClass compile: self text classified: newProtocol notifying: nil]] ifFalse: ["move within this class" destClass _ self selectedClass. newProtocol _ newProtocol asSymbol]. moved ifFalse: [(destClass organization categories includes: newProtocol) ifFalse: [destClass organization addCategory: newProtocol. self newProtocolList: protocol]. destClass organization classify: selector under: newProtocol. self logProtocolChange: destClass name , ' organization classify: ' , selector storeString , ' under: ' , newProtocol storeString. destClass reorganize]. self newSelectorList: selector! printOutMessage "Default to filing out." self fileOutMessage! removeMethod (self changeRequest and: [self confirm: 'Are you certain that you want to remove this method?']) ifTrue: [self selectedClass removeSelector: selector. self newSelectorList: nil. ^ true]. ^ false! spawnEdits: aText from: aController | newController | newController _ aController copy. "Copy gets the changes" aController cancel; controlTerminate. "Cancel changes in spawning browser" category == nil ifTrue: [BrowserView openOn: self copy withController: newController]. className == nil ifTrue: [BrowserView openCategoryBrowserOn: self copy withController: newController]. protocol == nil ifTrue: [BrowserView openClassBrowserOn: self copy withController: newController]. selector == nil ifTrue: [BrowserView openProtocolBrowserOn: self copy withController: newController]. BrowserView openMethodBrowserOn: self copy withController: newController! spawnMethod BrowserView openMethodBrowserOn: self copy! ! !Browser methodsFor: 'text'! prompt: promptString initially: initialString | aString | FillInTheBlank request: promptString , ' then accept or CR' displayAt: Sensor cursorPoint centered: false action: [:str | aString _ str] initialAnswer: initialString. ^ aString! text | text | textMode == #classDefinition ifTrue: [className == nil ifTrue: [^ (Class template: category) asText] ifFalse: [^ self selectedClass definition asText]]. textMode == #methodDefinition ifTrue: [selector == nil ifTrue: [^ self selectedClass sourceCodeTemplate asText] ifFalse: [^ (self selectedClass sourceCodeAt: selector) asText makeSelectorBoldIn: self selectedClass]]. textMode == #category ifTrue: [^ 'category to add' asText]. textMode == #categories ifTrue: [^ organization printString asText]. textMode == #protocol ifTrue: [^ 'protocol to add' asText]. textMode == #protocols ifTrue: [^ self selectedClass organization printString asText]. textMode == #comment ifTrue: [text _ self selectedClass comment asText. text isEmpty ifFalse: [^ text]. self selectedClass isMeta ifTrue: [^'Select the browser switch "instance" to see the comment' asText]. ^ 'This class has no comment' asText]. textMode == #hierarchy ifTrue: [^ self selectedClass printHierarchy asText]. ^ Text new! textMenu "Browser flushMenus" TextMenu == nil ifTrue: [TextMenu _ ActionMenu labels: 'again\undo\copy\cut\paste\do it\print it\inspect\accept\cancel\format\spawn\explain' withCRs lines: #(2 5 8 10) selectors: #(again undo copySelection cut paste doIt printIt inspectIt accept cancel format spawnEdits:from: explain)]. ^ TextMenu! textMode: aSymbol textMode _ aSymbol. self changed: #text! ! !Browser methodsFor: 'doIt/accept/explain'! acceptText: aText from: aController textMode == #classDefinition ifTrue: [^ self acceptClass: aText from: aController]. textMode == #methodDefinition ifTrue: [^ self acceptMethod: aText from: aController]. textMode == #categories ifTrue: [organization changeFromString: aText string. self newCategoryList: category. ^true]. textMode == #protocols ifTrue: [self selectedClass organization changeFromString: aText string. self selectedClass reorganize. self selectedClass logOrganizationChange. self textMode: #protocol; newProtocolList: nil. ^ true]. textMode == #comment ifTrue: [self selectedClass comment: aText string. self textMode: #comment; newProtocolList: nil. ^ true]. textMode == #hierarchy ifTrue: [aController flash]. ^ false! doItContext ^ nil! doItReceiver ^ self nonMetaClass! doItValue: ignored! explainSpecial: string "Answer with a string explaining the code pane selection if it is displaying one of the special edit functions." | classes whole lits reply | (textMode == #classDefinition) ifTrue: ["Selector parts in class definition" string last == $: ifFalse: [^nil]. lits _ Array with: #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] ifFalse: [^nil]. classes _ Smalltalk allClassesImplementing: whole. classes _ 'these classes ' , classes printString. ^reply , ' It is defined in ' , classes , '." Smalltalk browseAllImplementorsOf: #' , whole]. textMode == #hierarchy ifTrue: ["Instance variables in subclasses" classes _ self selectedClass allSubclasses. classes _ classes detect: [:each | (each instVarNames detect: [:name | name = string] ifNone: []) ~~ nil] ifNone: [^nil]. classes _ classes printString. ^'"is an instance variable in class ' , classes , '." ' , classes , ' browseAllAccessesTo: ''' , string , '''.']. ^nil! ! !Browser methodsFor: 'change management'! logProtocolChange: aString "Add aString, which is an executable account of the last protocol change (rename, remove, selector move) to the changes file." | file | SourceFiles == nil ifFalse: [file _ SourceFiles at: 2. file setToEnd; readWriteShorten. file cr; nextChunkPut: aString. file cr; readOnly].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Browser class instanceVariableNames: ''! !Browser class methodsFor: 'instance creation'! newOnClass: aClass BrowserView openClassBrowserOn: (self new onClass: aClass)! ! !Browser class methodsFor: 'class initialization'! flushMenus "Browser flushMenus." "Causes all menus to be newly created (so changes appear)" MethodMoveProtocol _ 'protocol name'. CategoryMenu _ nil. ClassMenu _ nil. MessageMenu _ nil. ProtocolMenu _ nil. TextMenu _ nil! ! StandardSystemView subclass: #BrowserView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Browser'! BrowserView comment: 'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the various system browsers: System Browser, System Category Browser, Class Browser, Message Category Browser, Message Browser.'! !BrowserView methodsFor: 'subview creation'! addCategoryView: area on: aBrowser readOnly: RO self addSubView: (SelectionInListView on: aBrowser printItems: false oneItem: RO aspect: #category change: #category: list: #categoryList menu: #categoryMenu initialSelection: #category) in: area borderWidth: 1! addClassView: area on: aBrowser readOnly: RO self addSubView: (SelectionInListView on: aBrowser printItems: false oneItem: RO aspect: #className change: #className: list: #classList menu: #classMenu initialSelection: #className) in: area borderWidth: 1! addMetaView: area on: aBrowser readOnly: ingored | mid | mid _ (area left + area right) * 0.5. self addSubView: (BooleanView on: aBrowser aspect: #meta label: 'instance' asText change: #meta: value: false) in: (area copy right: mid) borderWidth: 1. self addSubView: (BooleanView on: aBrowser aspect: #meta label: 'class' asText change: #meta: value: true) in: (area copy left: mid) borderWidth: 1! addMethodView: area on: aBrowser readOnly: RO self addSubView: (SelectionInListView on: aBrowser printItems: false oneItem: RO aspect: #methodName change: #methodName: list: #methodList menu: #methodMenu initialSelection: #methodName) in: area borderWidth: 1! addProtocolView: area on: aBrowser readOnly: RO self addSubView: (SelectionInListView on: aBrowser printItems: false oneItem: RO aspect: #protocol change: #protocol: list: #protocolList menu: #protocolMenu initialSelection: #protocol) in: area borderWidth: 1! addSelectorView: area on: aBrowser readOnly: RO self addSubView: (SelectionInListView on: aBrowser printItems: false oneItem: RO aspect: #selector change: #selector: list: #selectorList menu: #selectorMenu initialSelection: #selector) in: area borderWidth: 1! addTextView: area on: aBrowser initialSelection: sel self addSubView: (CodeView on: aBrowser aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: sel) in: area borderWidth: 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BrowserView class instanceVariableNames: ''! !BrowserView class methodsFor: 'instance creation'! openCategoryBrowserOn: aBrowser | topView | (topView _ self model: aBrowser label: (aBrowser category, ' Category Browser') minimumSize: 400@250) addCategoryView: (0@0 extent: 0.3@0.06) on: aBrowser readOnly: true; addClassView: (0@0.06 extent: 0.3@0.28) on: aBrowser readOnly: false; addMetaView: (0@0.34 extent: 0.3@0.06) on: aBrowser readOnly: false; addProtocolView: (0.3@0 extent: 0.3@0.4) on: aBrowser readOnly: false; addSelectorView: (0.6@0 extent: 0.4@0.4) on: aBrowser readOnly: false; addTextView: (0@0.4 extent: 1.0@0.6) on: aBrowser initialSelection: nil. topView controller open! openCategoryBrowserOn: aBrowser withController: aController | topView textView | (topView _ self model: aBrowser label: (aBrowser category, ' Category Browser') minimumSize: 400@250) addCategoryView: (0@0 extent: 0.3@0.06) on: aBrowser readOnly: true; addClassView: (0@0.06 extent: 0.3@0.28) on: aBrowser readOnly: false; addMetaView: (0@0.34 extent: 0.3@0.06) on: aBrowser readOnly: false; addProtocolView: (0.3@0 extent: 0.3@0.4) on: aBrowser readOnly: false; addSelectorView: (0.6@0 extent: 0.4@0.4) on: aBrowser readOnly: false. textView _ CodeView on: aBrowser aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil. textView controller: aController. topView addSubView: textView in: (0@0.4 extent: 1.0@0.6) borderWidth: 1. topView controller open! openClassBrowserOn: aBrowser | topView | (topView _ self model: aBrowser label: (aBrowser className,' Class Browser') minimumSize: 400@250) addClassView: (0@0 extent: 0.5@0.1) on: aBrowser readOnly: true; addMetaView: (0.5@0 extent: 0.5@0.1) on: aBrowser readOnly: false; addProtocolView: (0@0.1 extent: 0.5@0.3) on: aBrowser readOnly: false; addSelectorView: (0.5@0.1 extent: 0.5@0.3) on: aBrowser readOnly: false; addTextView: (0@0.4 extent: 1.0@0.6) on: aBrowser initialSelection: nil. topView controller open! openClassBrowserOn: aBrowser withController: aController | topView textView | (topView _ self model: aBrowser label: (aBrowser className,' Class Browser') minimumSize: 400@250) addClassView: (0@0 extent: 0.5@0.1) on: aBrowser readOnly: true; addMetaView: (0.5@0 extent: 0.5@0.1) on: aBrowser readOnly: false; addProtocolView: (0@0.1 extent: 0.5@0.3) on: aBrowser readOnly: false; addSelectorView: (0.5@0.1 extent: 0.5@0.3) on: aBrowser readOnly: false. textView _ CodeView on: aBrowser aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil. textView controller: aController. topView addSubView: textView in: (0@0.4 extent: 1.0@0.6) borderWidth: 1. topView controller open! openListBrowserOn: aCollection label: labelString self openListBrowserOn: aCollection label: labelString initialSelection: nil! openListBrowserOn: aCollection label: labelString initialSelection: selector "Create and schedule a Method List browser for the methods in aCollection. If the collection is empty, print -Nobody- in the System Transcript. " | topView aBrowser label | aCollection isEmpty ifTrue: [^Transcript cr; show: 'Nobody']. aBrowser _ MethodListBrowser new on: aCollection. label _ (labelString isKindOf: LookupKey) ifTrue: [labelString key] ifFalse: [labelString asString]. topView _ self model: aBrowser label: label minimumSize: 300 @ 100. topView addMethodView: (0 @ 0 extent: 1.0 @ 0.25) on: aBrowser readOnly: false; addTextView: (0 @ 0.25 extent: 1 @ 0.75) on: aBrowser initialSelection: selector. topView controller open! openMethodBrowserOn: aBrowser | topView | (topView _ self model: aBrowser label: 'Method Browser on ' , aBrowser selectedClass name minimumSize: 250 @ 120) addSelectorView: (0 @ 0 extent: 1 @ 0.15) on: aBrowser readOnly: true; addTextView: (0 @ 0.15 extent: 1 @ 0.85) on: aBrowser initialSelection: nil. topView controller open! openMethodBrowserOn: aBrowser withController: aController "Create and schedule a method browser for a method that is being edited." "aController may contain changes that haven't already been accepted " | topView textView | topView _ self model: aBrowser label: 'Method Browser on ' , aBrowser selectedClass name minimumSize: 250 @ 120. topView addSelectorView: (0 @ 0 extent: 1 @ 0.15) on: aBrowser readOnly: true. textView _ CodeView on: aBrowser aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil. textView controller: aController. topView addSubView: textView in: (0 @ 0.15 extent: 1 @ 0.85) borderWidth: 1. topView controller open! openOn: anOrganizer "Create and schedule a browser on an entire collection of organized classes. For example, evaluate BrowserView openOn: SystemOrganization." | topView aBrowser topY bottomY metaY | aBrowser _ Browser new on: anOrganizer. topY _ 0.35. "change this to re-proportion system browser" bottomY _ 1 - topY. metaY _ 0.05. "change this to re-proportion system browser" (topView _ self model: aBrowser label: 'System Browser' minimumSize: 400 @ 250) addCategoryView: (0 @ 0 extent: 0.25 @ topY) on: aBrowser readOnly: false; addClassView: (0.25 @ 0 extent: 0.25 @ (topY - metaY)) on: aBrowser readOnly: false; addMetaView: (0.25 @ (topY - metaY) extent: 0.25 @ metaY) on: aBrowser readOnly: false; addProtocolView: (0.5 @ 0 extent: 0.25 @ topY) on: aBrowser readOnly: false; addSelectorView: (0.75 @ 0 extent: 0.25 @ topY) on: aBrowser readOnly: false; addTextView: (0 @ topY extent: 1.0 @ bottomY) on: aBrowser initialSelection: nil. topView icon: (Icon constantNamed: #default). topView controller open! openOn: aBrowser withController: aController "Create and schedule a browser on an entire collection of organized classes. aController may contain changes that haven't already been accepted" | topView textView | (topView _ self model: aBrowser label: 'System Browser' minimumSize: 400@250) addCategoryView: (0@0 extent: 0.25@0.4) on: aBrowser readOnly: false; addClassView: (0.25@0 extent: 0.25@0.34) on: aBrowser readOnly: false; addMetaView: (0.25@0.34 extent: 0.25@0.06) on: aBrowser readOnly: false; addProtocolView: (0.5@0 extent: 0.25@0.4) on: aBrowser readOnly: false; addSelectorView: (0.75@0 extent: 0.25@0.4) on: aBrowser readOnly: false. textView _ CodeView on: aBrowser aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil. textView controller: aController. topView addSubView: textView in: (0@0.4 extent: 1@0.6) borderWidth: 1. topView controller open! openProtocolBrowserOn: aBrowser | topView | (topView _ self model: aBrowser label: aBrowser selectedClass name, ' Protocol Browser' minimumSize: 400@200) addProtocolView: (0@0 extent: 1@0.1) on: aBrowser readOnly: true; addSelectorView: (0@0.1 extent: 1@0.3) on: aBrowser readOnly: false; addTextView: (0@0.4 extent: 1.0@0.6) on: aBrowser initialSelection: nil. topView controller open! openProtocolBrowserOn: aBrowser withController: aController | topView textView | (topView _ self model: aBrowser label: aBrowser selectedClass name, ' Protocol Browser' minimumSize: 400@200) addProtocolView: (0@0 extent: 1@0.1) on: aBrowser readOnly: true; addSelectorView: (0@0.1 extent: 1@0.3) on: aBrowser readOnly: false. textView _ CodeView on: aBrowser aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil. textView controller: aController. topView addSubView: textView in: (0@0.4 extent: 1.0@0.6) borderWidth: 1. topView controller open! ! Switch subclass: #Button instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! Button comment: 'I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.'! !Button methodsFor: 'state'! turnOff "Sets the state of the receiver to 'off'. The off action of the receiver is not executed." on _ false! turnOn "The receiver remains in the 'off' state'." self doAction: onAction. self doAction: offAction! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Button class instanceVariableNames: ''! !Button class methodsFor: 'instance creation'! newOn self error: 'Buttons cannot be created in the on state'. ^nil! ! ArrayedCollection variableByteSubclass: #ByteArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! ByteArray comment: 'Elements of a ByteArray can only be integers between 0 and 255. The access messages at: and at:put: are handled primitively in class Object. Instance Variables: *byte indexed*'! !ByteArray methodsFor: 'accessing'! doubleWordAt: i "Answer the value of the double word (4 bytes) starting at byte index i." | b0 b1 b2 w | "Primarily for reading socket #s in Pup headers" b0 _ self at: i. b1 _ self at: i+1. b2 _ self at: i+2. w _ self at: i+3. "Following sequence minimizes LargeInteger arithmetic for small results." b2=0 ifFalse: [w _ (b2 bitShift: 8) + w]. b1=0 ifFalse: [w _ (b1 bitShift: 16) + w]. b0=0 ifFalse: [w _ (b0 bitShift: 24) + w]. ^w! doubleWordAt: i put: value "Set the value of the double word (4 bytes) starting at byte index i." | w | "Primarily for setting socket #s in Pup headers" w _ value truncated. self at: i put: (w digitAt: 4). self at: i + 1 put: (w digitAt: 3). self at: i + 2 put: (w digitAt: 2). self at: i + 3 put: (w digitAt: 1)! replaceFrom: start to: stop with: replacement startingAt: repStart "This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver." (replacement isKindOf: ByteArray) ifTrue: [self primReplaceFrom: start to: stop with: replacement startingAt: repStart] ifFalse: [super replaceFrom: start to: stop with: replacement startingAt: repStart]! replaceFrom: start to: stop withString: aString startingAt: repStart "This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the string, aString. Answer the receiver." | index repOff | repOff _ repStart - start. index _ start - 1. [(index _ index + 1) <= stop] whileTrue: [self at: index put: (aString at: repOff + index) asInteger]! wordAt: i "Answer the value of the word (2 bytes) starting at index i." | j | j _ i + i. ^((self at: j - 1) bitShift: 8) + (self at: j)! wordAt: i put: v "Set the value of the word (2 bytes) starting at index i." | j | j _ i + i. self at: j - 1 put: ((v bitShift: -8) bitAnd: 8r377). self at: j put: (v bitAnd: 8r377)! ! !ByteArray methodsFor: 'converting'! asString ^(String new: self size) replaceFrom: 1 to: self size withByteArray: self startingAt: 1! packBits: fieldSize into: byteArray "Pack the low order fieldSize bits of the receiver's bytes into the bytes of byteArray." ^self packBits: fieldSize startBit: 8-fieldSize into: byteArray! packBits: fieldSize startBit: fieldStart into: byteArray "Pack fieldSize bits of the receiver's bytes into the bytes of byteArray. fieldSize must be 1, 2, 4, or 8. fieldStart is the bit offset of the field within the byte (8-fieldSize for low order bits). The receiver's size must be a multiple of 16/fieldSize. byteArray's size must be even. Answers the packed array." | unpackedForm packedForm sourceX destX bitBlt fieldsPerWord ht | fieldsPerWord _ 16//fieldSize. ht _ self size//fieldsPerWord. unpackedForm _ Form new extent: fieldsPerWord*8@ht offset: 0@0 bits: self. packedForm _ Form new extent: 16@ht offset: 0@0 bits: byteArray. bitBlt _ BitBlt destForm: packedForm sourceForm: unpackedForm halftoneForm: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: 0@0 extent: fieldSize@ht clipRect: (0@0 corner: 16@ht). sourceX _ fieldStart. destX _ 0. fieldsPerWord timesRepeat: [bitBlt sourceX: sourceX; destX: destX; copyBits. sourceX _ sourceX + 8. destX _ destX + fieldSize]. ^byteArray! unpackBits: fieldSize into: byteArray "Unpack the packed bit fields of the receiver's bytes into the low order fieldSize bits of byteArray twice as large. fieldSize must be 1, 2, 4, or 8. The receiver's size must be even. byteArray's size must be a multiple of 16/fieldSize. Answers the unpacked array." | unpackedForm packedForm sourceX destX bitBlt fieldsPerWord ht | fieldsPerWord _ 16//fieldSize. ht _ self size//2. unpackedForm _ Form new extent: fieldsPerWord*8@ht offset: 0@0 bits: byteArray. packedForm _ Form new extent: 16@ht offset: 0@0 bits: self. bitBlt _ BitBlt destForm: unpackedForm sourceForm: packedForm halftoneForm: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: 0@0 extent: fieldSize@ht clipRect: unpackedForm boundingBox. sourceX _ 0. destX _ 8-fieldSize. fieldsPerWord timesRepeat: [bitBlt sourceX: sourceX; destX: destX; copyBits. sourceX _ sourceX + fieldSize. destX _ destX + 8]. ^byteArray! ! !ByteArray methodsFor: 'private'! defaultElement ^0! primReplaceFrom: start to: stop with: replacement startingAt: repStart "This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. No range checks are performed - this may be primitively implemented." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! ParseNode subclass: #CascadeNode instanceVariableNames: 'receiver messages ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! CascadeNode comment: 'The first message has the common receiver, the rest have receiver == nil, which signifies cascading.'! !CascadeNode methodsFor: 'initialize-release'! receiver: receivingObject messages: msgs "user show: 'abc'; tab; show: 'abc'; cr" receiver _ receivingObject. messages _ msgs! ! !CascadeNode methodsFor: 'code generation'! emitForValue: stack on: aStream receiver emitForValue: stack on: aStream. 1 to: messages size - 1 do: [:i | aStream nextPut: Dup. stack push: 1. (messages at: i) emitForValue: stack on: aStream. aStream nextPut: Pop. stack pop: 1]. messages last emitForValue: stack on: aStream! sizeForValue: encoder | size | size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2). messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)]. ^size! ! !CascadeNode methodsFor: 'printing'! printOn: aStream indent: level receiver printOn: aStream indent: level precedence: 0. 1 to: messages size do: [:i | (messages at: i) printOn: aStream indent: level. i < messages size ifTrue: [aStream nextPut: $;]]! ! Object subclass: #Change instanceVariableNames: 'file position ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! Change comment: 'Class Change represents a single change of some kind. It has many subclasses for specific kinds of changes. The text which represents the instance is a chunk of a file starting at a particular position. Since so many kinds of changes are related to classes, categories, and methods, there are dummy accessing methods for these parameters in class Change. Instance Variables: file position '! !Change methodsFor: 'initialize-release'! file: aFileStream position: anInteger file _ aFileStream. position _ anInteger! ! !Change methodsFor: 'accessing'! category ^''! className ^''! classObject "Return the class in the present system referenced by my className" ^nil! defaultName: initialString "The default name is the first few characters of the text." | text cr | text _ WriteStream on: (String new: 50). text nextPutAll: initialString. cr _ Character cr. self text do: [:char | (char = cr or: [text position >= 40]) ifTrue: [text nextPutAll: ' ...'. ^text contents]. text nextPut: char]. ^text contents! name "Return the name which should appear in the list view." self subclassResponsibility! parameters "Return the parameters used for the 'same as' test" self subclassResponsibility! selector ^''! text file position: position. ^file nextChunk! text: aString | tempStream | tempStream _ ReadWriteStream on: (String new: aString size + 20). tempStream nextChunkPut: aString. tempStream position: 0. "Needed to set readLimit = writePosition" file _ ReadStream on: tempStream contents. position _ 0! values "Return the value to be used for the 'same as' filter" ^Array with: self class with: self parameters! ! !Change methodsFor: 'file accessing'! file ^file! fileName (file isKindOf: FileStream) ifTrue: [^file name] ifFalse: [^'some local stream']! ! !Change methodsFor: 'checking'! checkWith: aConflictChecker "This is a default, most subclasses do something more intelligent." aConflictChecker addDoIt: self! ! !Change methodsFor: 'fileIn/Out'! fileIn ^Compiler evaluate: self text logged: true! fileOutOn: aStream "Default, subclasses may do something different" aStream nextChunkPut: self text; cr; cr! fileOutOn: aStream previous: previousChange next: nextChange "Default, subclasses may be able to encode runs more compactly" self fileOutOn: aStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Change class instanceVariableNames: ''! !Change class methodsFor: 'instance creation'! file: f position: p ^super new file: f position: p! ! StringHolderController subclass: #ChangeController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Changes'! ChangeController comment: 'I am the text view controller for a change browser.'! !ChangeController methodsFor: 'menu messages'! accept model isUnlocked ifTrue: [^view flash]. self controlTerminate. "Submit the new contents to the model for validation before accepting." (model contents: paragraph string notifying: self) ifTrue: [super accept]. self controlInitialize! ! StringHolder subclass: #ChangeList instanceVariableNames: 'listName changes selectionIndex list filter removed filterList filterKey changeDict doItDict checkSystem fieldList ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Changes'! ChangeList comment: 'I know how to scan a changes file and produce Change objects from it. I also function as a model for a ListView. Instance variables: listName "label for browser, the set of files that I have read" changes "my underlying collection of changes" selectionIndex "currently selected change, or 0 if none" currentChange "text of current selection" list "filtered collection of changes" filter "filter predicate" removed "removed changes" filterList "individual filters, or nil" filterKey "the change supplying the key value(s) for the filter(s)" changeDict "cross-index for conflict detection" doItDict "cross-index for conflict detection" fieldList "individual field options, or nil" '! !ChangeList methodsFor: 'initialize-release'! addChanges: changedMessages ChangeScanner new scanChangedMessages: changedMessages do: [:change | changes add: change]. self updateList! addChangeSet: aChangeSet self addChanges: aChangeSet changedMessageList! initialize super initialize. listName _ ''. changes _ OrderedCollection new. list _ OrderedCollection new. selectionIndex _ 0. filter _ [:change | true]. removed _ Set new. filterList _ #(). fieldList _ #()! recoverFile: aFileStream "Recover all the changes from a .changes file since the last snapshot" | position | position _ self findLast: ' ''----SNAPSHOT----''!! ' in: aFileStream. position isNil ifTrue: [position _ 0]. aFileStream position: position. self scanFile: aFileStream! release "break BlockContext cycles" filter _ nil. filterList _ #()! scanFile: aFileStream ChangeScanner new scanFile: aFileStream do: [:change | changes add: change]. listName size = 0 ifTrue: [listName _ aFileStream name] ifFalse: [listName _ listName, ' ..']. self updateList! scheduleMessageBrowser | change | selectionIndex > 0 ifTrue: [change _ list at: selectionIndex. (change isKindOf: MethodDefinitionChange) ifTrue: [^BrowserView openListBrowserOn: (Array with: change name) label: 'current definition']]. ^nil! ! !ChangeList methodsFor: 'accessing'! contents: newText notifying: requestor | oldChange newChange | selectionIndex = 0 ifTrue: [^false]. oldChange _ list at: selectionIndex. newChange _ oldChange accept: newText notifying: requestor. newChange isNil ifTrue: [^false]. list at: selectionIndex put: newChange. changes at: (changes indexOf: oldChange) put: newChange. self contents: newText. self changed: #list! filterCopy ^self class new listName: '(', self listName, ')' changes: list removed: (list select: [:c | removed includes: c])! hasRemoved: index ^index > 0 and: [index <= list size and: [removed includes: (list at: index)]]! list | name v | ^list collect: [:c | name _ nil. fieldList do: [:f | f == nil ifFalse: [v _ c perform: f. v == nil ifFalse: [name == nil ifTrue: [name _ WriteStream on: (String new: 50)]. name nextPut: $(; nextPutAll: v; nextPutAll: ') ']]]. name == nil ifTrue: [c name] ifFalse: [name nextPutAll: c name. name contents]]! listName listName size = 0 ifTrue: [^'Changes'] ifFalse: [^listName]! listSize ^list size! ! !ChangeList methodsFor: 'selecting'! contents: aString "ignore"! deselect selectionIndex _ 0. contents _ ''! listIndex ^selectionIndex! selection selectionIndex > 0 ifTrue: [^(list at: selectionIndex) text]! toggleListIndex: anInteger selectionIndex = anInteger ifTrue: [self deselect] ifFalse: [selectionIndex _ anInteger. contents _ self selection]. self changed: #listIndex! ! !ChangeList methodsFor: 'filter'! hasFilter: index ^index <= filterList size and: [(filterList at: index) notNil]! switchFilter: index perform: aSymbol index > filterList size ifTrue: [filterList _ filterList , (Array new: index - filterList size)]. (filterList at: index) isNil ifTrue: [selectionIndex > 0 ifTrue: [filterKey _ list at: selectionIndex. filterList at: index put: aSymbol]] ifFalse: [filterList at: index put: nil]. self updateList! ! !ChangeList methodsFor: 'showing'! showingField: index ^index <= fieldList size and: [(fieldList at: index) notNil]! switchField: index perform: aSymbol index > fieldList size ifTrue: [fieldList _ fieldList , (Array new: index - fieldList size)]. (fieldList at: index) isNil ifTrue: [fieldList at: index put: aSymbol] ifFalse: [fieldList at: index put: nil]. self updateSelection: selectionIndex! ! !ChangeList methodsFor: 'removing'! forget changes _ changes select: [:c | (removed includes: c) not]. removed _ Set new. self updateList! removeAll removed addAll: list! removeCurrent selectionIndex > 0 ifTrue: [removed add: (list at: selectionIndex)]! restoreAll list do: [:change | removed remove: change ifAbsent: []]! restoreCurrent selectionIndex > 0 ifTrue: [removed remove: (list at: selectionIndex) ifAbsent: []]! ! !ChangeList methodsFor: 'checking'! checkWith: aConflictChecker list do: [:change | (removed includes: change) ifFalse: [change checkWith: aConflictChecker]]! checkWithSystem: aBoolean changeDict _ Dictionary new. doItDict _ Dictionary new. checkSystem _ aBoolean. list do: [:change | (removed includes: change) ifFalse: [change checkWith: self]]! ! !ChangeList methodsFor: 'checking-Change'! addDoIt: aChange | fileName | fileName _ aChange fileName. (doItDict at: fileName ifAbsent: [doItDict at: fileName put: OrderedCollection new]) add: aChange! changesAt: changeName ^changeDict at: changeName ifAbsent: [#()]! changesAt: changeName add: aChange (changeDict at: changeName ifAbsent: [changeDict at: changeName put: OrderedCollection new]) add: aChange! checkSystem ^checkSystem! equalWithoutComments: text1 and: text2 | stream1 stream2 t | stream1 _ ReadStream on: text1. stream2 _ ReadStream on: text2. [(t _ self nextNonComment: stream1) = (self nextNonComment: stream2)] whileTrue: [t == nil ifTrue: [^true]]. ^false! ! !ChangeList methodsFor: 'checking-reporting'! reportConflictsByClassWithExtension: extension "report conflicts among the changes" self reportChangesOn: nil extension: extension. ^self finishReportOn: (FileStream fileNamed: 'DoIts', extension)! reportConflictsOn: aStream "report conflicts among the changes" self reportChangesOn: aStream extension: nil. ^self finishReportOn: aStream! ! !ChangeList methodsFor: 'checking-private'! finishReportOn: aStream "report conflicts among the changes" doItDict associationsDo: [:aDoIt | aStream cr; nextChunkPut: '"*** DoIts in ', aDoIt key, ' ***"'; cr; cr. aDoIt value do: [:doit | self tabText: doit text on: aStream] ]. aStream isEmpty ifTrue: [Transcript show: '*** no conflicts ***'. aStream nextChunkPut: '"*** no conflicts ***"'; cr]. ^aStream close! nextNonComment: sourceStream "Return the next item from the sourceStream (assumed not atEnd), carefully ignoring comments and separators." | char sepr | sepr _ false. [true] whileTrue: [sourceStream atEnd ifTrue: [^nil]. char _ sourceStream peek. char = $$ ifTrue: [sourceStream next. ^sourceStream next]. "catch chars/strings" char = $' ifTrue: [^String readFrom: sourceStream]. char = $" ifTrue: [sourceStream next; skipTo: $". sepr _ true] ifFalse: [char isSeparator ifTrue: [sourceStream skipSeparators. sepr _ true] ifFalse: [sepr ifTrue: [^Character space]. sourceStream next. ^char]]]! reportChangesOn: reportStream extension: extension "report conflicts among the changes" | aStream contendors oldText | aStream _ reportStream. changeDict keys asSortedCollection do: [:change | contendors _ changeDict at: change. contendors size > 1 ifTrue: [extension == nil ifFalse: [aStream _ FileStream fileNamed: ((change copyUpTo: $ ) copyWithout: $ ), extension. aStream setToEnd]. aStream cr; nextChunkPut: '"*** conflict: ', change, ' ***"'; cr. oldText _ '...'. contendors do: [:contendor | oldText _ self writeContendor: contendor on: aStream oldText: oldText]. extension == nil ifFalse: [aStream close]] ].! tabText: text on: aStream "report conflicts among the changes" | cr previous terminator | cr _ Character cr. terminator _ $!!. previous _ cr. text do: [:char | char = cr ifFalse: [previous = cr ifTrue: [aStream tab]]. aStream nextPut: (previous _ char). char = terminator ifTrue: [aStream nextPut: char]]. aStream nextPut: terminator; cr! writeContendor: source on: aStream oldText: oldText "write out the change" | text method endComment code | aStream cr; nextChunkPut: '"File: ', source fileName, '"'; cr. text _ source text. (source isKindOf: MethodDefinitionChange) ifFalse: [self tabText: text on: aStream. ^oldText]. method _ ReadStream on: text. method skipSeparators; skipTo: Character cr; skipSeparators. "skip header" (method peekFor: $") ifTrue: [method skipTo: $"; skipSeparators]. endComment _ method position. code _ method nextChunk. (self equalWithoutComments: code and: oldText) ifTrue: [method reset. aStream cr; nextPutAll: (method next: endComment); nextPutAll: '[SAME CODE AS ABOVE]'; cr] ifFalse: [aStream cr; nextChunkPut: text; cr]. ^code! ! !ChangeList methodsFor: 'lock access'! isUnlocked ^true! lock "ignore"! unlock "ignore"! ! !ChangeList methodsFor: 'fileIn/Out'! doThis selectionIndex > 0 ifTrue: [(list at: selectionIndex) fileIn]! doThis: listIndex (list at: listIndex) fileIn! fileOutOn: aFile | previous current | current _ previous _ nil. list do: [:next | (removed includes: next) ifFalse: [current == nil ifFalse: [current fileOutOn: aFile previous: previous next: next]. previous _ current. current _ next]]. current == nil ifFalse: [current fileOutOn: aFile previous: previous next: nil]! ! !ChangeList methodsFor: 'private'! addFilter: aSymbol | value oldFilter | value _ filterKey perform: aSymbol. filter isNil ifTrue: [filter _ [:change | (change perform: aSymbol) = value]] ifFalse: [oldFilter _ filter. filter _ [:change | (oldFilter value: change) and: [(change perform: aSymbol) = value]]]! findLast: aString in: aStream "Return the position in the stream of the end of the last occurrence of aString (presumably a snapshot message)" | firstChar endPosition position count index lastEnd | firstChar _ aString first. aStream setToEnd. position _ aStream position. lastEnd _ nil. [endPosition _ position. lastEnd == nil and: [(position _ endPosition - 5000 max: 0) < endPosition]] whileTrue: [aStream position: position. count _ endPosition - position. [count > 0] whileTrue: [count _ count - 1. aStream next = firstChar ifTrue: [index _ 2. [index <= aString size and: [(aString at: index) = aStream next]] whileTrue: [index _ index + 1]. index > aString size ifTrue: [lastEnd _ aStream position] ifFalse: [aStream position: endPosition - count]]]]. ^lastEnd! listName: aString changes: aChangeCollection removed: aSet listName _ aString. changes addAll: aChangeCollection. list addAll: aChangeCollection. removed addAll: aSet! updateList | oldChange newIndex | selectionIndex > 0 ifTrue: [oldChange _ list at: selectionIndex]. filter _ nil. filterList do: [:aSymbol | aSymbol notNil ifTrue: [self addFilter: aSymbol]]. filter isNil ifTrue: [filter _ [:change | true]]. list _ changes select: [:change | filter value: change]. newIndex _ oldChange == nil ifTrue: [0] ifFalse: [list indexOf: oldChange]. self updateSelection: newIndex! updateSelection: newIndex self deselect. self changed: #list. newIndex > 0 ifTrue: [self toggleListIndex: newIndex]! ! LockedListController subclass: #ChangeListController instanceVariableNames: '' classVariableNames: 'ChangeListYellowButtonMenu ChangeListYellowButtonMessages ' poolDictionaries: '' category: 'Interface-Changes'! ChangeListController comment: 'I am the controller for ChangeListView, handling the list menu.'! !ChangeListController methodsFor: 'initialize-release'! initialize super initialize. self initializeYellowButtonMenu! ! !ChangeListController methodsFor: 'menu messages'! browse "Create and schedule a list browser containing only the displayed items." self controlTerminate. model scheduleMessageBrowser. self controlInitialize! check self controlTerminate. self checkWithSystem: false. self controlInitialize! checkWithSystem self controlTerminate. self checkWithSystem: true. self controlInitialize! checkWithSystem: aBoolean self getFile: #fileNamed: withPrompt: 'type name of file on which to write confilicts' do: [:aFile | Cursor execute showWhile: [model checkWithSystem: aBoolean]. Cursor write showWhile: [model reportConflictsOn: aFile]. aFile shorten; close]! copyView "Create and schedule a list browser containing only the displayed items. Accessed by choosing the menu command clone." self controlTerminate. ChangeListView openOn: model filterCopy! doAll self controlTerminate. self doFrom: 1. self controlInitialize! doFrom: firstIndex "Reset selection each time through the loop, so that if an error occurs, the selection is left at the item which caused it." firstIndex to: model listSize do: [:index | (model hasRemoved: index) ifFalse: [model toggleListIndex: index. model doThis: index]]! doThis self controlTerminate. model doThis. self controlInitialize! fileIn self controlTerminate. self getFile: #oldFileNamed: withPrompt: 'type name of file for reading' do: [:aFile | aFile readOnly. model scanFile: aFile. aFile close]. self controlInitialize! fileOut self controlTerminate. self getFile: #fileNamed: withPrompt: 'type name of file for writing' do: [:aFile | model fileOutOn: aFile. aFile shorten; close]. self controlInitialize! forget self controlTerminate. Cursor execute showWhile: [model forget]. self controlInitialize! getChanges self controlTerminate. model addChangeSet: Smalltalk changes. self controlInitialize! recover self controlTerminate. model recoverFile: (SourceFiles at: 2). self changeLabel. self controlInitialize! removeAll self controlTerminate. view deselect. model removeAll. view displaySelectionBox. self controlInitialize! removeItem view deselect. model removeCurrent. view displaySelectionBox! restoreAll view deselect. model restoreAll. view displaySelectionBox! restoreItem view deselect. model restoreCurrent. view displaySelectionBox! ! !ChangeListController methodsFor: 'scrolling'! scrollView: anInteger | viewList maximumAmount minimumAmount amount | viewList _ view list. maximumAmount _ viewList clippingRectangle top - viewList compositionRectangle top max: 0. minimumAmount _ viewList clippingRectangle bottom - viewList compositionRectangle bottom min: 0. amount _ (anInteger min: maximumAmount) max: minimumAmount. amount ~= 0 ifTrue: [view deselect. viewList scrollBy: amount negated. view displaySelectionBox]! ! !ChangeListController methodsFor: 'private'! changeLabel | superView | "This method accesses the label with a terrible kludge. It would be better if the label were a view of its own, but there would still be problems." superView _ view superView. Display gray: superView labelDisplayBox. superView label: model listName. superView displayView! changeModelSelection: anInteger model toggleListIndex: anInteger! getFile: aSymbol withPrompt: promptString do: actionBlock "find out the file name" | fixedBlock fileName | fixedBlock _ actionBlock fixTemps. FillInTheBlank request: promptString displayAt: Sensor cursorPoint centered: true action: [:fileNamex | fileName _ fileNamex. fileName] initialAnswer: ''. fileName isEmpty ifFalse: [(FileDirectory isLegalFileName: fileName) ifTrue: [Cursor wait showWhile: [fixedBlock value: (FileStream perform: aSymbol with: fileName)]] ifFalse: [Transcript cr; show: 'You specified an illegal file name.']]! initializeYellowButtonMenu self yellowButtonMenu: ChangeListYellowButtonMenu yellowButtonMessages: ChangeListYellowButtonMessages.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeListController class instanceVariableNames: ''! !ChangeListController class methodsFor: 'class initialization'! initialize "ChangeListController initialize" ChangeListYellowButtonMenu _ PopUpMenu labels: 'file in file out recover last changes display system changes do all remove all restore all spawn all forget do it remove it restore it spawn it check conflicts check with system' lines: #( 4 8 9 13 ). ChangeListYellowButtonMessages _ #(fileIn fileOut recover getChanges doAll removeAll restoreAll copyView forget doThis removeItem restoreItem browse check checkWithSystem)! ! ChangeListController initialize! ListView subclass: #ChangeListView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Changes'! ChangeListView comment: 'I am a list view of various system changes.'! !ChangeListView methodsFor: 'initialize-release'! release model release. super release! ! !ChangeListView methodsFor: 'model access'! model: aChangeList super model: aChangeList. self list: model list. selection _ model listIndex.! ! !ChangeListView methodsFor: 'controller access'! defaultControllerClass ^ChangeListController! ! !ChangeListView methodsFor: 'selecting'! displaySelectionBox super displaySelectionBox. self reverseRemoved! reverseRemoved | box line | self selectionInterval do: [:index | (model hasRemoved: index) ifTrue: [box _ self selectionBox: index. line _ Rectangle origin: box leftCenter - (0@1) extent: box width @ 2. emphasisOn ifTrue: [Display reverse: (line intersect: self clippingBox)] ifFalse: [Display fill: (line intersect: self clippingBox) rule: Form reverse mask: Form gray]]]! selectionBox: listIndex "Answer the rectangle in which a particular selection is displayed." ^(self insetDisplayBox left @ (list compositionRectangle top + (self selectionBoxOffset: listIndex)) extent: self insetDisplayBox width @ list lineGrid) insetBy: (Rectangle left: 1 right: 1 top: 1 bottom: 0)! selectionBoxOffset: listIndex "Answer an integer that determines the y position for the display box of a particular selection." ^(listIndex - 1 + self minimumSelection - 1) * list lineGrid! selectionIndex: yPosition "Answer the selection index corresponding to a particular Y coordinate." ^(yPosition - list compositionRectangle top) // list lineGrid - self minimumSelection + 2! selectionInterval "Answer the currently visible range of selection indices." ^((self selectionIndex: self insetDisplayBox top) max: 1) to: ((self selectionIndex: self insetDisplayBox bottom) min: model listSize)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeListView class instanceVariableNames: ''! !ChangeListView class methodsFor: 'instance creation'! open "Open a view for changes files. Starts as an empty template." self openOn: ChangeList new "ChangeListView open"! openOn: aChangeList "schedule a change browser" | topView aChangeListView aChangeView alignPoint | topView _ StandardSystemView new model: aChangeList. topView label: aChangeList listName. topView minimumSize: 180@180. topView borderWidth: 1. topView window: (0@0 extent: 180@410). aChangeListView _ self new. aChangeListView model: aChangeList. aChangeListView window: (0@0 extent: 180@120). aChangeListView insideColor: Form white. aChangeListView borderWidthLeft: 1 right: 1 top: 1 bottom: 1. topView addSubView: aChangeListView. alignPoint _ self openSwitches: #( ('show file' showingField: (1) switchField:perform: (1 fileName) 90) ('show category' showingField: (2) switchField:perform: (2 category) 90) ) topView: topView at: aChangeListView viewport bottomLeft model: aChangeList. alignPoint _ self openSwitches: #( (file hasFilter: (1) switchFilter:perform: (1 file) 30) (type hasFilter: (2) switchFilter:perform: (2 class) 30) (class hasFilter: (3) switchFilter:perform: (3 className) 30) (category hasFilter: (4) switchFilter:perform: (4 category) 30) (selector hasFilter: (5) switchFilter:perform: (5 selector) 30) (same hasFilter: (6) switchFilter:perform: (6 values) 30) ) topView: topView at: alignPoint model: aChangeList. aChangeView _ StringHolderView new. aChangeView model: aChangeList. aChangeView controller: ChangeController new. aChangeView window: (0@0 extent: 180@240). aChangeView insideColor: Form white. aChangeView borderWidthLeft: 1 right: 1 top: 1 bottom: 1. topView addSubView: aChangeView align: aChangeView viewport topLeft with: alignPoint. topView controller open.! recover "Open a view of the current changes file since the last snapshot." self openOn: (ChangeList new recoverFile: (SourceFiles at: 2)) "ChangeListView recover"! ! !ChangeListView class methodsFor: 'examples'! recoverExample "One example of the use of the ChangeList is to view actions taken before a system failure. Assuming the file 'fileName.st' contains these actions, this example opens a browser on the contents." "ChangeListView recoverExample." ChangeListView openOn: (ChangeList new recoverFile: (FileStream oldFileNamed: 'fileName.st')).! ! !ChangeListView class methodsFor: 'private'! openSwitches: parameters topView: topView at: initialPoint model: aChangeList "Define a related group of switches" | aSwitchView alignPoint | alignPoint _ initialPoint. parameters do: [:args | [:label :viewSelector :viewArguments :controllerSelector :controllerArguments :width | aSwitchView _ SwitchView new. aSwitchView model: aChangeList. aSwitchView controller: LockedSwitchController new. aSwitchView borderWidthLeft: 1 right: 1 top: 1 bottom: 1. aSwitchView selector: viewSelector. aSwitchView arguments: viewArguments. aSwitchView controller selector: controllerSelector. aSwitchView controller arguments: controllerArguments. aSwitchView window: (0 @ 0 extent: width @ 25). aSwitchView label: label asParagraph. topView addSubView: aSwitchView align: aSwitchView viewport topLeft with: alignPoint. alignPoint _ aSwitchView viewport topRight. ] valueWithArguments: args]. ^initialPoint x @ aSwitchView viewport bottom! ! Scanner subclass: #ChangeScanner instanceVariableNames: 'file chunkString ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! ChangeScanner comment: 'Class ChangeScanner knows how to parse a file into a collection of changes. Instance Variables: file of change information chunkString read from the file'! !ChangeScanner methodsFor: 'initialize-release'! initChangeScanner chunkString _ String new: 200! ! !ChangeScanner methodsFor: 'change set scanning'! scanChangedMessages: changedMessages do: aBlock | selector change className class category | changedMessages do: [:aString | super scan: (ReadStream on: aString). (className _ self nextClass) notNil ifTrue: [(selector _ self nextSelector) notNil ifTrue: [change _ MethodDefinitionChange new className: className; selector: selector. (className includes: Character space) ifTrue: [class _ (Smalltalk at: (className copyUpTo: Character space) asSymbol) class] ifFalse: [class _ Smalltalk at: className asSymbol]. category _ class whichCategoryIncludesSelector: selector asString asSymbol. category == nil ifTrue: [category _ 'As yet unclassified']. change category: category. change getSource. aBlock value: change]]]! ! !ChangeScanner methodsFor: 'file scanning'! scanFile: aFile do: aBlock "Evaluate aBlock with each item on the file" | position | file _ aFile. [file skipSeparators. file atEnd] whileFalse: [file peek = $!! ifTrue: [file next. super scan: self nextChunkStream. self scanSpecialDo: aBlock] ifFalse: [position _ file position. self scanExpression: self nextChunkStream do: [:item | aBlock value: (item file: file position: position)]]]! scanMethodsClass: class category: category do: aBlock | position method selector | [file skipSeparators. position _ file position. (method _ self nextChunkStream) atEnd] whileFalse: [method _ method contents. selector _ Parser new parseSelector: method. selector notNil ifTrue: [aBlock value: ((MethodDefinitionChange file: file position: position) className: class; selector: selector; category: category)]]! scanSpecialDo: aBlock "Scan a chunk of file beginning with a !!. For now, the only thing I understand is method definitions." | class category | (class _ self nextClass) notNil ifTrue: [(tokenType == #keyword and: [token = 'methodsFor:']) ifTrue: [self scanToken. tokenType == #string ifTrue: [category _ token. self scanToken. tokenType == #doIt ifTrue: [^self scanMethodsClass: class category: category asSymbol do: aBlock]]]]. "I don't understand what's on the file. Scan for a blank chunk and hope for the best." [self nextChunkStream atEnd] whileFalse: []! ! !ChangeScanner methodsFor: 'expression scanning'! scanClassDefinition: classType className: superName do: aBlock "Scan a presumed class definition. The classType is the first keyword of the class defining message (subclass:, variableSubclass:, etc.)" | newName parameters | (tokenType == #literal and: [token isKindOf: Symbol]) ifFalse: [^nil]. newName _ token. parameters _ #('instanceVariableNames:' 'classVariableNames:' 'poolDictionaries:' 'category:') collect: [:keyword | self scanToken. (tokenType == #keyword and: [token = keyword]) ifFalse: [^nil]. self scanToken. tokenType == #string ifFalse: [^nil]. token]. self scanToken. ^aBlock value: (ClassDefinitionChange new className: newName; superclassName: superName classType: classType otherParameters: parameters)! scanClassExpression: class do: aBlock "Scan an expression beginning with a class name. This might be a class definition, a class removal, a class comment change, a class initialization, a method removal, or a doIt." | firstToken selector newName | firstToken _ token. self scanToken. firstToken = 'removeSelector:' ifTrue: [(tokenType == #literal and: [token isKindOf: Symbol]) ifTrue: [selector _ token. self scanToken. ^aBlock value: (MethodOtherChange new className: class; selector: selector; type: #remove)]]. firstToken = 'rename:' ifTrue: [(tokenType == #literal and: [token isKindOf: Symbol]) ifTrue: [newName _ token. self scanToken. aBlock value: (ClassOtherChange new className: class; type: #rename). ^aBlock value: (ClassOtherChange new className: newName; type: 'rename to' asSymbol)]]. firstToken = 'comment:' ifTrue: [tokenType == #string ifTrue: [self scanToken. ^aBlock value: (ClassCommentChange new className: class)]]. (#('subclass:' 'variableSubclass:' 'variableByteSubclass:' 'variableWordSubclass:') includes: firstToken) ifTrue: [^self scanClassDefinition: firstToken className: class do: aBlock]. firstToken = 'initialize' ifTrue: [^aBlock value: (ClassOtherChange new className: class; type: #initialize)]. firstToken = 'removeFromSystem' ifTrue: [^aBlock value: (ClassOtherChange new className: class; type: #remove)]. firstToken = 'instanceVariableNames:' ifTrue: [tokenType == #string ifTrue: [self scanToken. ^aBlock value: (ClassOtherChange new className: class; type: 'inst vars for' asSymbol)]]. ^nil! scanExpression: aStream do: aBlock "Scan a chunk of file consisting of an expression. This might be a class definition, a class removal, a class comment change, a method removal, or a doIt." | class item | super scan: aStream. ((class _ self nextClass) notNil and: [tokenType == #keyword or: [tokenType == #word]]) ifTrue: [self scanClassExpression: class do: [:it | item _ it. tokenType == #doIt ifTrue: [aBlock value: item]]]. item == nil ifTrue: [aBlock value: OtherChange new]! ! !ChangeScanner methodsFor: 'private'! nextChunkStream "Answer a read stream on the next chunk of the file." | chunkStream char terminator | terminator _ $!!. file skipSeparators. chunkStream _ ReadWriteStream on: chunkString. [file atEnd] whileFalse: [char _ file next. char == terminator ifTrue: [(file peekFor: terminator) ifTrue: ["doubled terminator" chunkStream nextPut: char] ifFalse: [chunkStream position: 0. ^chunkStream]] ifFalse: [chunkStream nextPut: char]]. chunkStream position: 0. "Sets read limit to current position" ^chunkStream! nextClass | class | tokenType == #word ifTrue: [class _ token. self scanToken. (tokenType == #word and: [token = 'class']) ifTrue: [class _ (class, ' ', token) asSymbol. self scanToken] ifFalse: [class _ class asSymbol]. ^class]. ^nil! nextSelector | selector | tokenType == #keyword ifTrue: [self scanLitWord]. (tokenType == #word or: [tokenType == #keyword or: [tokenType == #binary]]) ifTrue: [selector _ token. self scanToken]. ^selector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeScanner class instanceVariableNames: ''! !ChangeScanner class methodsFor: 'instance creation'! new ^super new initChangeScanner! ! Object subclass: #ChangeSet instanceVariableNames: 'classChanges methodChanges classRemoves reorganizeSystem specialDoIts ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! ChangeSet comment: 'Instances of class ChangeSet keep track of the changes made to a system, so it is possible to make an incremental fileOut. Instances do not remember the order in which changes are made, although this sometimes matters. Instance variables: classChanges {class name -> {add, change, comment, rename, reorganize, ''oldName: xxx''}} methodChanges {class name -> {selector -> add | change | remove}} classRemoves {class name} reorganizeSystem - indicates if SystemOrganization was changed. specialDoIts of Smalltalk expressions.'! !ChangeSet methodsFor: 'initialize-release'! initialize "Reset the receiver to be empty." classChanges _ Dictionary new. methodChanges _ Dictionary new. classRemoves _ Set new. reorganizeSystem _ false. specialDoIts _ OrderedCollection new.! ! !ChangeSet methodsFor: 'testing'! isEmpty "Answer whether the receiver contains any elements." ^(((methodChanges isEmpty and: [classChanges isEmpty]) and: [classRemoves isEmpty]) and: [reorganizeSystem not]) and: [specialDoIts isEmpty]! ! !ChangeSet methodsFor: 'converting'! asSortedCollection "Answer a new instance of SortedCollection whose elements are Strings describing the changes represented by the receiver." | summary | summary _ SortedCollection new. classChanges associationsDo: [:clAssoc | clAssoc value do: [:changeType | summary add: clAssoc key, ' - ', changeType]]. methodChanges associationsDo: [:clAssoc | clAssoc value associationsDo: [:mAssoc | summary add: clAssoc key, ' ', mAssoc key, ' - ', mAssoc value]]. classRemoves do: [:name | summary add: name, ' - ', 'remove']. reorganizeSystem ifTrue: [summary add: 'Reorganize System']. specialDoIts isEmpty not ifTrue: [summary add: 'SpecialDoIts - (', specialDoIts size printString, ')']. ^summary! ! !ChangeSet methodsFor: 'change management'! addClass: class "Include indication that a new class was created." classRemoves remove: class name ifAbsent: []. self atClass: class add: #add! addDoIt: smalltalkExpression "When filing out changes, append this string to the file." specialDoIts add: smalltalkExpression! changeClass: class "Include indication that a class definition has been changed." self atClass: class add: #change! changedClasses "Answer a collection of the changed or edited classes, not including removed classes." | classes | classes _ Set new. methodChanges keys do: [:className | classes add: (self classNamed: className)]. classChanges keys do: [:className | classes add: (self classNamed: className)]. ^classes! commentClass: class "Include indication that a class comment has been changed." self atClass: class add: #comment! removeClass: class "Include indication that a class has been forgotten." | name | (self isNew: class) ifTrue: [^self removeClassChanges: class]. "only remember old classes" (self atClass: class includes: #rename) "remember as old name" ifTrue: [name _ self oldNameFor: class] ifFalse: [name _ class name]. self removeClassChanges: class. classRemoves add: name! removeClassChanges: class "Remove all memory of changes associated with this class and its metaclass." classChanges removeKey: class name ifAbsent: []. methodChanges removeKey: class name ifAbsent: []. classChanges removeKey: class class name ifAbsent: []. methodChanges removeKey: class class name ifAbsent: []. classRemoves remove: class name ifAbsent: [].! renameClass: class as: newName "Include indication that a class has been renamed." | value | (self atClass: class includes: #rename) ifFalse: [self atClass: class add: 'oldName: ', class name. "only original name matters" self atClass: class add: #rename]. "copy changes using new name (metaclass too)" (Array with: classChanges with: methodChanges) do: [:changes | (value _ changes at: class name ifAbsent: [nil]) == nil ifFalse: [changes at: newName put: value. changes removeKey: class name]. (value _ changes at: class class name ifAbsent: [nil]) == nil ifFalse: [changes at: (newName, ' class') put: value. changes removeKey: class class name]]! reorganizeClass: class "Include indication that a class was reorganized." self atClass: class add: #reorganize! reorganizeSystem "Include indication that the system classes were reorganized." reorganizeSystem _ true! ! !ChangeSet methodsFor: 'method changes'! addSelector: selector class: class "Include indication that a method has been added." self atSelector: selector class: class put: #add! changedMessageList "Answer an array that identifies the methods that have been changed. Each entry is a String containing the class name and method selector." | messageList | messageList _ SortedCollection new. methodChanges associationsDo: [:clAssoc | clAssoc value associationsDo: [:mAssoc | mAssoc value = #remove ifFalse: [messageList add: clAssoc key asString, ' ' , mAssoc key]]]. ^messageList asArray! changeSelector: selector class: class "Include indication that a method has been edited." (self atSelector: selector class: class) = #add ifFalse: [self atSelector: selector class: class put: #change] "Don't forget a method is new just because it's been changed"! removeSelector: selector class: class "Include indication that a method has been forgotten." (self atSelector: selector class: class) = #add ifTrue: [self removeSelectorChanges: selector class: class] "Forgot a new method, no-op" ifFalse: [self atSelector: selector class: class put: #remove]! removeSelectorChanges: selector class: class "Remove all memory of changes associated with the argument, selector, in this class." | dictionary | dictionary _ methodChanges at: class name ifAbsent: [^self]. dictionary removeKey: selector ifAbsent: []. dictionary isEmpty ifTrue: [methodChanges removeKey: class name]! ! !ChangeSet methodsFor: 'fileIn/Out'! fileOutChangesFor: class on: stream "Write out all the changes the receiver knows about this class." | changes removes | "first file out class changes" self fileOutClassChanges: class on: stream. "next file out changed methods" removes _ OrderedCollection new. changes _ OrderedCollection new. (methodChanges at: class name ifAbsent: [^self]) associationsDo: [:mAssoc | mAssoc value = #remove ifTrue: [removes add: mAssoc key] ifFalse: [changes add: mAssoc key]]. changes isEmpty ifFalse: [class fileOutChangedMessages: changes on: stream. stream cr]. removes do: [:selector | stream nextChunkPut: class name, ' removeSelector: ', selector storeString; cr]. "reintialize metaclass if necessary" ((class isMemberOf: Metaclass) and: [changes includes: #initialize]) ifTrue: [stream nextChunkPut: class soleInstance name, ' initialize'; cr].! fileOutOn: stream "Write out all the changes the receiver knows about." self isEmpty ifTrue: [self notify: 'Warning: no changes to file out']. (ChangeSet superclassOrder: self changedClasses asOrderedCollection) do: [:class | self fileOutChangesFor: class on: stream]. classRemoves do: [:className | stream nextChunkPut: 'Smalltalk removeClassNamed: #', className; cr]. reorganizeSystem ifTrue: [stream cr; nextPut: $!!; nextChunkPut: 'SystemOrganization'; cr. stream nextChunkPut: SystemOrganization printString; cr; cr]. specialDoIts do: [:expression | stream nextChunkPut: expression; cr].! putStatsOn: stream "Write out all the changes the receiver knows about." | changedClasses classes removes changes adds | self isEmpty ifTrue: [stream nextPutAll: 'an Empty ChangeSet'. ^self]. reorganizeSystem ifTrue: [stream nextPutAll: 'Reorganized System' ;cr;cr]. changedClasses _ ChangeSet superclassOrder: self changedClasses asOrderedCollection. classes _ changedClasses select: [:class | self atClass: class includes: #add]. classes isEmpty ifFalse: [stream nextPutAll: 'Added classes:'; cr. classes do: [:class | stream tab; nextPutAll: class name; cr]. stream cr]. classes _ changedClasses select: [:class | self atClass: class includes: #rename]. classes isEmpty ifFalse: [stream nextPutAll: 'Renamed classes:'; cr. classes do: [:class | stream tab; nextPutAll: (self oldNameFor: class); tab; nextPutAll: 'became'; tab; nextPutAll: class name; cr]. stream cr]. classes _ changedClasses select: [:class | self atClass: class includes: #change]. classes isEmpty ifFalse: [stream nextPutAll: 'Redefined classes:'; cr. classes do: [:class | stream tab; nextPutAll: class name; cr]. stream cr]. classes _ changedClasses select: [:class | self atClass: class includes: #comment]. classes isEmpty ifFalse: [stream nextPutAll: 'Classes with changed comment:'; cr. classes do: [:class | stream tab; nextPutAll: class name; cr]. stream cr]. classRemoves isEmpty ifFalse: [stream nextPutAll: 'Removed classes:'; cr. classRemoves do: [:class | stream tab; nextPutAll: class; cr]. stream cr]. classes _ changedClasses select: [:class | self atClass: class includes: #reorganize]. classes isEmpty ifFalse: [stream nextPutAll: 'ReOrganized classes:'; cr. classes do: [:class | stream tab; nextPutAll: class name; cr]. stream cr]. stream nextPutAll: 'Method changes:'; cr. methodChanges associationsDo: [:class | stream tab; nextPutAll: class key; cr. removes _ OrderedCollection new. changes _ OrderedCollection new. adds _ OrderedCollection new. class value associationsDo: [:mAssoc | mAssoc value = #remove ifTrue: [removes add: mAssoc key] ifFalse: [mAssoc value = #change ifTrue: [changes add: mAssoc key] ifFalse: [adds add: mAssoc key]]]. adds isEmpty ifFalse: [stream tab; tab; nextPutAll: 'Added methods:'; cr. adds do: [:selector | stream tab; tab; tab; nextPutAll: selector; cr]]. changes isEmpty ifFalse: [stream tab; tab; nextPutAll: 'Changed methods:'; cr. changes do: [:selector | stream tab; tab; tab; nextPutAll: selector; cr]]. removes isEmpty ifFalse: [stream tab; tab; nextPutAll: 'Removed methods:'; cr. removes do: [:selector | stream tab; tab; tab; nextPutAll: selector; cr]]. stream cr]! ! !ChangeSet methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." self putStatsOn: aStream! ! !ChangeSet methodsFor: 'private'! atClass: class add: changeType (self isNew: class) ifFalse: "new classes don't matter" [(classChanges at: class name ifAbsent: [^classChanges at: class name put: (Set with: changeType)]) add: changeType]! atClass: class includes: changeType ^(classChanges at: class name ifAbsent: [^false]) includes: changeType! atSelector: selector class: class ^(methodChanges at: class name ifAbsent: [^#none]) at: selector ifAbsent: [#none]! atSelector: selector class: class put: changeType | name dict | (self isNew: class) ifTrue: [^self]. "Don't keep method changes for new classes" name _ class name. (methodChanges at: name ifAbsent: [dict _ IdentityDictionary new. methodChanges at: name put: dict. dict]) at: selector put: changeType! classNamed: className "className is either a class name or a class name followed by ' class'. Answer the class or metaclass it names." | meta name class | (className size > 6 and: [(className copyFrom: className size - 5 to: className size) = ' class']) ifTrue: [meta _ true. name _ className copyFrom: 1 to: className size - 6] ifFalse: [meta _ false. name _ className]. class _ Smalltalk at: name asSymbol. meta ifTrue: [^class class] ifFalse: [^class]! fileOutClassChanges: class on: stream "Write out class changes. i.e. new class, definition, comment, renaming." (self atClass: class includes: #add) ifTrue: [stream cr. class fileOutOn: stream. stream cr. ^self atClass: class add: #add "fileOut clears this!!"]. (self atClass: class includes: #rename) ifTrue: [stream nextChunkPut: (self oldNameFor: class), ' rename: #', class name; cr]. (self atClass: class includes: #change) ifTrue: [stream emphasis: 5; nextChunkPut: class definition; cr; emphasis: 1]. (self atClass: class includes: #comment) ifTrue: [class organization putCommentOnFile: stream numbered: nil moveSource: false. stream cr]. (self atClass: class includes: #reorganize) ifTrue: [class fileOutOrganizationOn: stream. stream cr]! isNew: class "Answer whether this class was added since the ChangeSet was cleared." class isMeta ifTrue: [^self atClass: class soleInstance includes: #add "check class"] ifFalse: [^self atClass: class includes: #add]! oldNameFor: class | name | name _ (classChanges at: class name) asOrderedCollection detect: [:x | 'oldName: *' match: x]. ^(Scanner new scanTokens: name) last! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeSet class instanceVariableNames: ''! !ChangeSet class methodsFor: 'instance creation'! new ^super new initialize! ! !ChangeSet class methodsFor: 'fileIn/Out'! superclassOrder: classes "Arrange the classes in the collection, classes, in superclass order so the classes can be properly filed in. Class A must come before class B if A is a superclass of B, or if B is A's metaclass." | order left | left _ IdentitySet new. left addAll: classes. order _ OrderedCollection new. [left isEmpty] whileFalse: [left do: [:c | ((left includes: c superclass) or: [(c isKindOf: Metaclass) and: [left includes: c soleInstance]]) ifFalse: [order addLast: c. left remove: c]]]. ^order! ! Magnitude subclass: #Character instanceVariableNames: 'value ' classVariableNames: 'CharacterTable ' poolDictionaries: '' category: 'Collections-Text'! Character comment: 'An instance of class Character is an element of a String that represents an ASCII (extended to 256 codes) code. Instances of class Character are created uniquely, so that all instances are identical. There are 256 instances of the class in the system. Characters can be expressed literally by preceding the alphabetic character by a dollar sign $; $A for example represents the capital letter "A". Instance Variable: value ASCII code Class Variable: CharacterTable '! !Character methodsFor: 'accessing'! asciiValue "Answer the value of the receiver." ^value! digitValue "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." value <= $9 asciiValue ifTrue: [^value - $0 asciiValue]. value >= $A asciiValue ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]]. ^-1! ! !Character methodsFor: 'comparing'! < aCharacter "Answer whether the receiver's value is less than aCharacter's value." ^self asciiValue < aCharacter asciiValue! = aCharacter "Answer whether the receiver and the argument are the same object (have the same object pointer). Optional. See Object documentation whatIsAPrimitive. " ^self == aCharacter! > aCharacter "Answer whether the receiver's value > aCharacter's value." ^self asciiValue > aCharacter asciiValue! hash "Answer a SmallInteger unique to the receiver." ^value! ! !Character methodsFor: 'testing'! isAlphaNumeric "Answer whether the receiver is a letter or a digit." ^self isLetter or: [self isDigit]! isDigit "Answer whether the receiver is a digit." ^self >= $0 and: [self <= $9]! isLetter "Answer whether the receiver is a letter." ^(8r141 <= value and: [value <= 8r172]) or: [8r101 <= value and: [value <= 8r132]]! isLowercase "Answer whether the receiver is a lowercase letter." ^self >= $a and: [self <= $z]! isSeparator "Answer whether the receiver is one of the separator characters--space, cr, tab, line feed, null , or form feed." value > 32 ifTrue: [^false]. "normal character" value = 32 ifTrue: [^true]. "space" value = 13 ifTrue: [^true]. "cr" value = 9 ifTrue: [^true]. "tab" value = 10 ifTrue: [^true]. "line feed" value = 12 ifTrue: [^true]. "form feed" value = 0 ifTrue: [^true]. "null" ^false! isUppercase "Answer whether the receiver is an uppercase letter." ^self >= $A and: [self <= $Z]! isVowel "Answer whether the receiver is one of the vowels, AEIOU, in upper or lower case." ^'AEIOU' includes: self asUppercase! tokenish "Answer whether the receiver is a valid token-character--letter, digit, or colon." ^self isLetter or: [self isDigit or: [self = $:]]! ! !Character methodsFor: 'copying'! copy "Answer the receiver because Characters are unique." ^self! deepCopy "Answer the receiver becuase Characters are unique." ^self! ! !Character methodsFor: 'printing'! isLiteral "Answer true that the receiver is a literal." ^true! printOn: aStream "Append to the argument aStream a sequence of characters preceded by the literal $ that identifies the receiver." aStream nextPut: $$. aStream nextPut: self! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver. Character literals are preceded by '$'." aStream nextPut: $$; nextPut: self! ! !Character methodsFor: 'converting'! asCharacter "Answer the receiver itself." ^self! asInteger "Answer the value of the receiver." ^value! asLowercase "Answer a Character that is the lower case letter corresponding to the receiver. If the receiver is not an upper case letter, answer the receiver itself." 8r101 <= value ifTrue: [value <= 8r132 ifTrue: [^Character value: value+8r40]]! asSymbol "Answer the receiver converted into a Symbol." ^Symbol internCharacter: self! asUppercase "Answer a Character that is the upper case letter corresponding to the receiver. If the receiver is not a lower case letter, answer the receiver itself." 8r141 <= value ifTrue: [value <= 8r172 ifTrue: [^Character value: value-8r40]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Character class instanceVariableNames: ''! !Character class methodsFor: 'class initialization'! initialize "Create the table of unique Characters." "This code is not shown so that the user can not destroy the system by trying to recreate the table." ^self! ! !Character class methodsFor: 'instance creation'! digitValue: x "Answer the Character whose digit value is x. For example, answer $9 for x=9, $0 for x=0, $A for x=10, $Z for x=35." | index | index _ x truncated. ^CharacterTable at: (index < 10 ifTrue: [48 + index] ifFalse: [55 + index]) + 1! new "Provide an error notification that creating new characters is not allowed." self error: 'cannot create new characters'! value: anInteger "Answer the Character whose value is anInteger. Characters are unique; they are stored in the class variable CharacterTable." ^CharacterTable at: anInteger + 1! ! !Character class methodsFor: 'accessing untypeable characters'! backspace "Answer the Character representing a backspace." ^self value: 8! cr "Answer the Character representing a carriage return." ^self value: 13! esc "Answer the Character representing an escape." ^self value: 27! lf "Answer the Character representing a carriage return." ^self value: 10! newPage "Answer the Character representing a form feed." ^self value: 12! space "Answer the Character representing a space." ^self value: 32! tab "Answer the Character representing a tab." ^self value: 9! ! !Character class methodsFor: 'constants'! characterTable "Answer the class variable in which unique Characters are stored." ^CharacterTable! ! Character initialize! Rectangle subclass: #CharacterBlock instanceVariableNames: 'stringIndex character ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! CharacterBlock comment: 'Class CharacterBlock represents information about displayed characters. Instances are used to return the results of methods Paragraph characterBlockAtPoint: aPoint and Paragraph characterBlockForIndex: stringIndex. Any recomposition or movement of a Paragraph can make the information obsolete. Instance Variables: stringIndex the position of the receiver in the displayed string character the displayed character'! !CharacterBlock methodsFor: 'comparing'! < aCharacterBlock "Answer whether the string index of the receiver precedes that of the argument, aCharacterBlock." ^stringIndex < aCharacterBlock stringIndex! <= aCharacterBlock "Answer whether the string index of the receiver does not come after that of aCharacterBlock." ^(self > aCharacterBlock) not! = aCharacterBlock "Answer whether the string index of the receiver is that same as that of the argument, aCharacterBlock." self species = aCharacterBlock species ifTrue: [^stringIndex = aCharacterBlock stringIndex] ifFalse: [^false]! > aCharacterBlock "Answer whether the string index of the receiver comes after that of aCharacterBlock." ^aCharacterBlock < self! >= aCharacterBlock "Answer whether the string index of the receiver does not precede that of aCharacterBlock." ^(self < aCharacterBlock) not! ! !CharacterBlock methodsFor: 'copying'! copy "Answer another instance just like the receiver." ^self deepCopy! ! !CharacterBlock methodsFor: 'accessing'! character "Answer the character in the receiver." ^character! stringIndex "Answer the position of the receiver in the string that it indexes." ^stringIndex! stringIndex: index "Store the argument index as the position of the character in the string." stringIndex _ index! ! !CharacterBlock methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver. The general format is a CharacterBlock with index stringindex and character character and rectangle etc." aStream nextPutAll: 'a CharacterBlock with index '. stringIndex printOn: aStream. aStream nextPutAll: ' and character '. character printOn: aStream. aStream nextPutAll: ' and rectangle '. super printOn: aStream! ! !CharacterBlock methodsFor: 'private'! newStringIndex: anInteger Character: aCharacter BoundingRectangle: aRectangle stringIndex _ anInteger. character _ aCharacter. super origin: aRectangle topLeft. super corner: aRectangle corner! newStringIndex: anInteger Character: aCharacter TopLeft: originPoint Extent: extentPoint stringIndex _ anInteger. character _ aCharacter. super origin: originPoint. super extent: extentPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CharacterBlock class instanceVariableNames: ''! !CharacterBlock class methodsFor: 'instance creation'! stringIndex: anInteger character: aCharacter boundingRectangle: aRectangle "Answer an instance of the receiver with values set to the arguments." ^self new newStringIndex: anInteger Character: aCharacter BoundingRectangle: aRectangle! stringIndex: anInteger character: aCharacter topLeft: originPoint extent: extentPoint "Answer an instance of the receiver with values set to the arguments." ^self new newStringIndex: anInteger Character: aCharacter TopLeft: originPoint Extent: extentPoint! ! CharacterScanner subclass: #CharacterBlockScanner instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! CharacterBlockScanner comment: 'Instances of class CharacterBlockScanners are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location Instance Variables characterPoint Used in character location domain. The topLeft of the character to be returned in a CharacterBlock. characterIndex Used in character location domain. The index in the stylizedString of the character to be returned in a CharacterBlock. lastCharacter Used in character location domain. The character to be returned in a CharacterBlock. lastCharacterExtent Used in character location domain. The extent of the character to be returned in a CharacterBlock. The height is usually the stringStyle''s lineGrid. lastSpaceOrTabExtent Used in character location domain. If the lastCharacter is a space or a tab, this will be its extent, an unexpected value when justification is turned on, and a variable value in the case of tab no matter what the alignment value is. nextLeftMargin When, as in the case of cr, the left margin of the succeeding line is what is desired, this value, known to the paragraph is needed. Since the paragraph is not available to the stop conditions, this value is set when the line of the character is discovered and before access to the paragraph is lost. '! !CharacterBlockScanner methodsFor: 'scanning'! characterBlockAtPoint: aPoint in: aParagraph "Answer a CharacterBlock for character in aParagraph at point aPoint. It is assumed that aPoint has been transformed into coordinates appropriate to the text's destinationForm rectangle and the compositionRectangle." super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterPoint _ aPoint. ^self buildCharacterBlockIn: aParagraph! characterBlockForIndex: targetIndex in: aParagraph "Answer a CharacterBlock for character in aParagraph at targetIndex. The coordinates in the CharacterBlock will be appropriate to the intersection of the destinationForm rectangle and the compositionRectangle." super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterIndex _ targetIndex. characterPoint _ aParagraph rightMarginForDisplay @ (aParagraph topAtLineIndex: (aParagraph lineIndexOfCharacterIndex: characterIndex)). ^self buildCharacterBlockIn: aParagraph! characterNotInFont "Handle the situation when the character encountered is not defined in the current font." "This does not handle character selection nicely, i.e., illegal characters are a little tricky to select. Since the end of a run or line is subverted here by actually having the scanner scan a different string in order to manage the illegal character, things are not in an absolutely correct state for the character location code. " lastCharacterExtent _ (font widthOf: (font maxAscii + 1) asCharacter) @ textStyle lineGrid. ^super characterNotInFont! ! !CharacterBlockScanner methodsFor: 'stop conditions'! cr "Answer an instance of CharacterBlock that specifies the current location of the mouse relative to a carriage return stop condition that has just been encountered. The ParagraphEditor convention is to denote selections by CharacterBlocks, sometimes including the carriage return (cursor is at the end) and sometimes not (cursor is in the middle of the text)." ((characterIndex ~~ nil and: [characterIndex > text size]) or: [(line last = text size) and: [(destY + textStyle lineGrid) < characterPoint y]]) ifTrue: ["When off end of string, give data for next character" destY _ destY + textStyle lineGrid. lastCharacter _ nil. characterPoint _ Point x: ((text at: lastIndex) == CR ifTrue: [leftMargin] ifFalse: [nextLeftMargin]) y: destY. lastIndex _ lastIndex + 1. lastCharacterExtent x: 0. ^ true]. lastCharacter _ CR. characterPoint _ destX @ destY. lastCharacterExtent x: rightMargin - destX. ^true! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." | leadingTab currentX | ((characterPoint x <= (destX + ((lastCharacterExtent x) // 2))) or: [line last = lastIndex]) ifTrue: [lastCharacter _ (text at: lastIndex). ((lastCharacter = Space and: [textStyle alignment = Justified]) and: [destX + lastCharacterExtent x > rightMargin]) ifTrue: [characterPoint _ nextLeftMargin @ (destY + textStyle lineGrid). characterIndex notNil ifTrue: [lastIndex _ (characterIndex min: (line last + 1))] ifFalse: [lastIndex _ (lastIndex + 1) min: (line last + 1)]] ifFalse: [((lastCharacter = Tab) and: [line last = lastIndex]) ifTrue: [(characterPoint x <= (destX + ((lastCharacterExtent x) // 2))) ifFalse: [destX _ (destX + lastCharacterExtent x). characterPoint _ destX @ destY. ^ self endOfRun]]. characterPoint _ destX @ destY]. ^true]. "Pointing past middle of a character, return the next character." lastIndex _ lastIndex + 1. lastCharacter _ text at: lastIndex. currentX _ destX + lastCharacterExtent x. lastCharacterExtent x: (font widthOf: lastCharacter). characterPoint _ currentX @ destY. "Yukky if next character is space or tab." (lastCharacter = Space and: [textStyle alignment = Justified]) ifTrue: [lastCharacterExtent x: (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1))). ^true]. lastCharacter = Tab ifTrue: ["See tabForDisplay for illumination on the following awfulness." leadingTab _ true. (line first to: lastIndex - 1) do: [:index | (text at: index) = Space ifTrue: [leadingTab _ false]]. (textStyle alignment ~= Justified or: [leadingTab]) ifTrue: [lastCharacterExtent x: (textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin) - currentX] ifFalse: [lastCharacterExtent x: (((currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount))) - currentX) max: 0)]]. ^ true! endOfRun "Before arriving at the cursor location, the selection has encountered an end of run. Answer false if the selection continues, true otherwise. Set up indexes for building the appropriate CharacterBlock." | runLength lineStop | ((characterIndex ~~ nil and: [runStopIndex < characterIndex and: [runStopIndex < text size]]) or: [characterIndex == nil and: [lastIndex < line last]]) ifTrue: ["We're really at the end of a real run." runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). characterIndex ~~ nil ifTrue: [lineStop _ characterIndex "scanning for index"] ifFalse: [lineStop _ line last "scanning for point"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. self setStopConditions. ^false]. lastCharacter _ text at: lastIndex. characterPoint _ destX @ destY. ((lastCharacter == Space and: [textStyle alignment = Justified]) or: [lastCharacter == Tab]) ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent]. characterIndex ~~ nil ifTrue: ["If scanning for an index and we've stopped on that index, then we back destX off by the width of the character stopped on (it will be pointing at the right side of the character) and return" runStopIndex = characterIndex ifTrue: [characterPoint x: destX - lastCharacterExtent x. ^true]. "Otherwise the requested index was greater than the length of the string. Return string size + 1 as index, indicate further that off the string by setting character to nil and the extent to 0." lastIndex _ lastIndex + 1. lastCharacter _ nil. lastCharacterExtent x: 0. ^true]. "Scanning for a point and either off the end of the line or off the end of the string." runStopIndex = text size ifTrue: ["off end of string" lastIndex _ lastIndex + 1. lastCharacter _ nil. lastCharacterExtent x: 0. ^true]. "just off end of line without crossing x" lastIndex _ lastIndex + 1. ^true! onePixelBackspace "Decrement destX by 1 pixel size." | characterWidth | characterWidth _ 1. lastCharacterExtent x: characterWidth. lastIndex _ lastIndex + 1. destX _ (destX - characterWidth) max: leftMargin. ^ false! onePixelSpace "Increment destX by 1 pixel size." | characterWidth | characterWidth _ 1. lastCharacterExtent x: characterWidth. (destX + characterWidth) >= characterPoint x ifTrue: [^self crossedX]. lastIndex _ lastIndex + 1. destX _ destX + characterWidth. ^ false! paddedSpace "When the line is justified, the spaces will not be the same as the font's space character. A padding of extra space must be considered in trying to find which character the cursor is pointing at. Answer true if the scanning has crossed the cursor, false otherwise." | pad | spaceCount _ spaceCount + 1. pad _ line justifiedPadFor: spaceCount. lastSpaceOrTabExtent _ lastCharacterExtent copy. lastSpaceOrTabExtent x: spaceWidth + pad. destX + lastSpaceOrTabExtent x >= characterPoint x ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy. ^self crossedX]. lastIndex _ lastIndex + 1. destX _ destX + lastSpaceOrTabExtent x. ^false! setStopConditions "Set the font and the stop conditions for the current run." font _ textStyle fontAt: (text emphasisAt: lastIndex). super setStopConditions. stopConditions at: Space asInteger + 1 put: (textStyle alignment = Justified ifTrue: [#paddedSpace] ifFalse: [nil])! tab "Handle leading and internal tabs in a justified line. Leading tabs are considered legal and should be reflected on the display gracefully. Internal tabs (when the line is justified) are considered at the very best a misguided use of the character, and are reflected on the display the best we can." | leadingTab currentX | currentX _ destX. leadingTab _ true. (line first to: lastIndex) do: [:index | (text at: index) = Space ifTrue: [leadingTab _ false]]. (textStyle alignment ~= Justified or: [leadingTab]) ifTrue: [currentX _ textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin] ifFalse: [currentX _ currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]. lastSpaceOrTabExtent _ lastCharacterExtent copy. lastSpaceOrTabExtent x: (currentX - destX max: 0). currentX >= characterPoint x ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy. ^self crossedX]. destX _ currentX. lastIndex _ lastIndex + 1. ^false! ! !CharacterBlockScanner methodsFor: 'private'! buildCharacterBlockIn: aParagraph | lineIndex runLength lineStop done stopCondition | "handle nullText" (aParagraph numberOfLines = 0 or: [text size = 0]) ifTrue: [leftMargin _ (aParagraph leftMarginForDisplayForLine: 1). ^CharacterBlock stringIndex: 1 "like being off end of string" character: nil topLeft: (leftMargin @ (aParagraph compositionRectangle) top) extent: (0 @ textStyle lineGrid)]. "find the line" lineIndex _ aParagraph lineIndexOfTop: characterPoint y. destY _ (aParagraph topAtLineIndex: lineIndex). line _ aParagraph lineAt: lineIndex. text _ aParagraph textAt: lineIndex. rightMargin _ aParagraph rightMarginForDisplay. (lineIndex = aParagraph numberOfLines and: [(destY + textStyle lineGrid) < characterPoint y]) ifTrue: ["if beyond lastLine, force search to last character" characterPoint x: rightMargin] ifFalse: [characterPoint y < (aParagraph compositionRectangle) top ifTrue: ["force search to first line" characterPoint _ (aParagraph compositionRectangle) topLeft]. characterPoint x > rightMargin ifTrue: [characterPoint x: rightMargin]]. destX _ leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex. nextLeftMargin_ aParagraph leftMarginForDisplayForLine: lineIndex+1. lastIndex _ line first. self setStopConditions. "also sets font" runLength _ (text runLengthFor: line first). characterIndex ~~ nil ifTrue: [lineStop _ characterIndex "scanning for index"] ifFalse: [lineStop _ line last]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. lastCharacterExtent _ 0 @ textStyle lineGrid. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions displaying: false. "see setStopConditions for stopping conditions for character block operations." lastCharacterExtent x: (font widthOf: (text at: lastIndex)). (self perform: stopCondition) ifTrue: [^CharacterBlock stringIndex: lastIndex character: lastCharacter topLeft: characterPoint extent: lastCharacterExtent]]! ! BitBlt subclass: #CharacterScanner instanceVariableNames: 'lastIndex xTable stopConditions text textStyle leftMargin rightMargin font line runStopIndex spaceCount spaceWidth outputMedium ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! CharacterScanner comment: 'Instances of class CharacterScanner hold the state associated with scanning text. Instance Variables lastIndex String index of last character scanned. xTable Array left x-coordinates of character glyphs (cached from font). stopConditions Array of selectors to perform when scanning various characters. text The text being scanned. textStyle The style (font set, etc.) being used with this text. leftMargin, rightMargin Screen coordinates delimiting the text. font The font currently in use. line Giving the current range in text. runStopIndex Where the current run ends in text. spaceCount How many spaces have been scanned in this line. spaceWidth How wide spaces should be in this line. outputMedium Needed by CompositionScanner for determining the nature of the font to be used for character widths. For the DisplayScanner there are several places where distinguishing between displaying and printing is required. The first three variables are required (in addition to inherited BitBlt state) by the primitive scanning operation. '! !CharacterScanner methodsFor: 'access'! lastIndex "Answer the string index of last character scanned." ^lastIndex! stopConditions: anArray "Store the stop conditions to be the argument anArray." stopConditions _ anArray! xTable: anArray "Store the argument anArray to be the array of left x-coordinates of character glyphs." xTable _ anArray! ! !CharacterScanner methodsFor: 'scanning'! characterNotInFont "All fonts have an illegal character to be used when a character is not within the font's legal range. When characters out of ranged are encountered in scanning text, then this special character indicates the appropriate behavior. The character is usually treated as a unary message understood by a subclass of CharacterScanner." | illegalAsciiString saveIndex stopCondition | saveIndex _ lastIndex. illegalAsciiString _ String with: (font maxAscii + 1) asCharacter. (self isMemberOf: CompositionScanner) not ifTrue: [ stopCondition _ self scanCharactersFrom: 1 to: 1 in: illegalAsciiString rightX: rightMargin stopConditions: stopConditions displaying: self doesDisplaying] ifFalse: [ stopCondition _ self scanCharactersFrom: 1 to: 1 in: illegalAsciiString rightX: rightMargin stopConditions: stopConditions displaying: self doesDisplaying]. lastIndex _ saveIndex + 1. stopCondition ~= (stopConditions at: EndOfRun) ifTrue: [^self perform: stopCondition] ifFalse: [lastIndex = runStopIndex ifTrue: [^self perform: (stopConditions at: EndOfRun)]. ^false]! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops displaying: display "This is the inner loop of text display -- but consider scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable. If dextX would exceed rightX, then return stops at: 258. If displaying is true, then display the character. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Fail under the same conditions that the Smalltalk code below would cause an error. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX | lastIndex _ startIndex. [lastIndex <= stopIndex] whileTrue: [ascii _ (sourceString at: lastIndex) asciiValue. (stopConditions at: ascii + 1) ~~ nil ifTrue: [^stops at: ascii + 1]. sourceX _ xTable at: ascii + 1. nextDestX _ destX + (width _ (xTable at: ascii + 2) - sourceX). nextDestX > rightX ifTrue: [^stops at: CrossedX]. display ifTrue: [self copyBits]. destX _ nextDestX. lastIndex _ lastIndex + 1]. lastIndex _ stopIndex. ^stops at: EndOfRun! ! !CharacterScanner methodsFor: 'stop conditions'! setStopConditions "Set default stop conditions for the font." spaceWidth _ font spaceWidth. sourceForm _ font glyphs. xTable _ font xTable. height _ font height. stopConditions _ font stopConditions. stopConditions at: Space asInteger + 1 put: #space. stopConditions at: Tab asInteger + 1 put: #tab. stopConditions at: CR asInteger + 1 put: #cr. stopConditions at: 10 + 1 put: #cr. stopConditions at: EndOfRun put: #endOfRun. stopConditions at: CrossedX put: #crossedX. stopConditions at: Ctrls asInteger + 1 put: #onePixelSpace. stopConditions at: CtrlS asInteger + 1 put: #onePixelBackspace. stopConditions at: Ctrlz asInteger + 1 put: #characterNotInFont.! ! !CharacterScanner methodsFor: 'private'! doesDisplaying ^false! initializeFromParagraph: aParagraph clippedBy: clippingRectangle text _ aParagraph text. textStyle _ aParagraph textStyle. destForm _ aParagraph destinationForm. outputMedium _ aParagraph outputMedium. halftoneForm _ aParagraph mask. self combinationRule: aParagraph rule. self clipRect: clippingRectangle. sourceY _ 0.! ! Arc subclass: #Circle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! Circle comment: 'A full circle is made from four arcs. Class Circle modifies the Arc methods for displaying.'! !Circle methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Display the receiver on the display medium aDisplayMedium positioned at aDisplayPoint within the rectangle clipRectangle and with the rule, ruleInteger, and mask, aForm. " 1 to: 4 do: [:i | super quadrant: i. super displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm]! displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger mask: aForm "Display the receiver, translated and scaled by aTransformation, displaying with combination rule ruleInteger, masked by aForm, and clipped with the rectangle clipRectangle." 1 to: 4 do: [:i | super quadrant: i. super displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger mask: aForm]! ! !Circle methodsFor: 'display box access'! computeBoundingBox "Answer the minimum enclosing rectangle around the image." ^center - radius + form offset extent: form extent + (radius * 2) asPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Circle class instanceVariableNames: ''! !Circle class methodsFor: 'examples'! exampleOne "Click any button somewhere on the screen. The point will be the center of the circcle of radius 150." "Circle exampleOne." | aCircle aForm | aForm _ Form new extent: 1@30. aForm black. aCircle _ Circle new. aCircle form: aForm. aCircle radius: 150. aCircle center: Sensor waitButton. aCircle displayOn: Display! exampleTwo "Designate a rectangular area that should be used as the brush for displaying the circle. Click any button at a point on the screen which will be the center location for the circle. The curve will be displayed with a long black form." "Circle exampleTwo." | aCircle aForm | aForm _ Form fromUser. aCircle _ Circle new. aCircle form: aForm. aCircle radius: 150. aCircle center: Sensor waitButton. aCircle displayOn: Display at: 0 @ 0 rule: Form reverse! ! ClassDescription subclass: #Class instanceVariableNames: 'name classPool sharedPools ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! Class comment: 'Instances of class Class describe the representation and behavior of objects. Class adds more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. An example is accessing shared (pool) variables. Instance Variables: name name of class for printing and global reference classPool of variables common to all instances sharedPools of Dictionaries access to other shared variables '! !Class methodsFor: 'initialize-release'! declare: varString "Declare class variables common to all instances. Answer whether recompilation is advisable." | newVars conflicts | newVars _ (Scanner new scanFieldNames: varString) collect: [:x | x asSymbol]. newVars do: [:var | var first isLowercase ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']]. conflicts _ false. classPool == nil ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: [:var | self removeClassVarName: var]]. (newVars reject: [:var | self classPool includesKey: var]) do: [:var | "adding" "check if new vars defined elsewhere" (self scopeHas: var ifTrue: [:ignored]) ifTrue: [self error: var , ' is defined elsewhere'. conflicts _ true]]. newVars size > 0 ifTrue: [classPool _ self classPool. "in case it was nil" newVars do: [:var | classPool declare: var from: Undeclared]]. ^conflicts! obsolete "Change the receiver to an obsolete class by changing its name to have the prefix -AnObsolete-, and nilling the fields of any instances." self isPointers ifTrue: [self allInstancesDo: [:instance | instance nilFields]]. "nil fields of instances" ('AnObsolete*' match: name) ifFalse: [name _ 'AnObsolete' , name]. classPool _ Dictionary new. self class obsolete. super obsolete! removeFromSystem "Forget the receiver, and all of its subclasses, from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." Smalltalk removeClassNamed: self name. "remove from system dictionary"! sharing: poolString "Set up sharedPools. Answer whether recompilation is advisable." | oldPools | oldPools _ self sharedPools. sharedPools _ Set new. (Scanner new scanFieldNames: poolString) do: [:poolName | sharedPools add: (Smalltalk at: poolName asSymbol)]. sharedPools isEmpty ifTrue: [sharedPools _ nil]. oldPools detect: [:pool | (self sharedPools includes: pool) not] ifNone: [^false]. ^true "A pool got deleted - who knows if there are still references?"! superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet "Answer an instance of me, a new class, using the arguments of the message as the needed information." superclass _ sup. methodDict _ md. format _ ft. name _ nm. organization _ org. instanceVariables _ nilOrArray. classPool _ pool. sharedPools _ poolSet! validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods "Recompile the receiver and redefine its subclasses if necessary." super validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods. self ~~ oldClass ifTrue: [environ at: name put: self. self updateInheritanceTables: oldClass. oldClass obsolete]! ! !Class methodsFor: 'accessing'! classPool "Answer the dictionary of class variables." classPool == nil ifTrue: [^Dictionary new] ifFalse: [^classPool]! name "Answer the name of the receiver." name == nil ifTrue: [^super name] ifFalse: [^name]! smashName: aSymbol name _ aSymbol! ! !Class methodsFor: 'accessing class hierarchy'! hasMultipleSuperclasses ^self class instHasMultipleSuperclasses! isObsolete "Answer whether the receiver is an obsolete class." ^self class isObsolete "ask the metaclass"! ! !Class methodsFor: 'testing method dictionary'! hasMethods "Answer a Boolean as to whether any methods are defined for the receiver (includes whether there are methods defined in the receiver's metaclass)." ^super hasMethods or: [self class hasMethods]! ! !Class methodsFor: 'copying'! copy "Answer another instance just like the receiver." | newClass | newClass _ self class copy new superclass: superclass methodDict: methodDict copy format: format name: name organization: organization copy instVarNames: instanceVariables copy classPool: classPool copy sharedPools: sharedPools. Class instSize to: self class instSize do: [:offset | newClass instVarAt: offset put: (self instVarAt: offset)]. ^newClass! copyForValidation "Make a copy of the receiver (a class) but do not install the created class as a new class in the system. This is used for creating a new version of the receiver in which the installation is deferred until all changes are successfully completed." ^self class copy new superclass: superclass methodDict: methodDict copy format: format name: name organization: organization instVarNames: instanceVariables copy classPool: classPool sharedPools: sharedPools! ! !Class methodsFor: 'class name'! rename: aString "The new name of the receiver is the argument, aString." | newName | newName _ aString asSymbol. (Smalltalk includesKey: newName) ifTrue: [^self error: newName , ' already exists']. Smalltalk renameClass: self as: newName. name _ newName. self comment: self comment. self class comment: self class comment! ! !Class methodsFor: 'instance variables'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." superclass class name: self name inEnvironment: Smalltalk subclassOf: superclass instanceVariableNames: self instanceVariablesString , aString variable: self isVariable words: self isWords pointers: self isPointers classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category comment: nil changed: false! removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables." | newInstVarString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newInstVarString _ ''. (self instVarNames copyWithout: aString) do: [:varName | newInstVarString _ newInstVarString , ' ' , varName]. superclass class name: self name inEnvironment: Smalltalk subclassOf: superclass instanceVariableNames: newInstVarString variable: self isVariable words: self isWords pointers: self isPointers classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category comment: nil changed: false! ! !Class methodsFor: 'class variables'! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver." aString first isLowercase ifTrue: [self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. self withAllSubclasses do: [:subclass | subclass poolHas: aString asSymbol ifTrue: [:ignored | ^self error: aString , ' is already used as a variable name in ' , subclass name]]. classPool _ self classPool. "might be nil" classPool add: (Association key: aString asSymbol value: nil)! allClassVarNames "Answer a Set of the names of the receiver's class variables, including those defined in the superclasses of the receiver." | aSet | superclass == nil ifTrue: [^self classVarNames] "This is the keys so it is a new Set." ifFalse: [aSet _ superclass allClassVarNames. aSet addAll: self classVarNames. ^aSet]! classVarNames "Answer a Set of the names of the class variables defined in the receiver." ^self classPool keys! initialize "Typically used for the initialization of class variables and metaclass instance variables. Does nothing, but may be overridden in Metaclasses." ^self! removeClassVarName: aString "Remove the class variable whose name is the argument, aString, from the names defined in the receiver, a class." | aSymbol | aSymbol _ aString asSymbol. (classPool includesKey: aSymbol) ifFalse: [^self error: aString, ' is not a class variable']. (self superclass allClassVarNames includes: aSymbol) ifFalse: [self withAllSubclasses do: [:subclass | (Array with: subclass with: subclass class) do: [:classOrMeta | (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) isEmpty ifFalse: [^self error: aString , ' is still used in code of class ' , classOrMeta name]]]]. classPool removeKey: aSymbol! ! !Class methodsFor: 'pool variables'! addSharedPool: aDictionary "Add the argument, aDictionary, as one of the receiver's pool dictionaries. Create an error if the dictionary is already one of the pools." (self sharedPools includes: aDictionary) ifTrue: [^self error: 'The dictionary is already in my pool']. sharedPools == nil ifTrue: [sharedPools _ Set with: aDictionary] ifFalse: [sharedPools add: aDictionary]! allSharedPools "Answer a Set of the pools the receiver shares, including those defined in the superclasses of the receiver." | aSet | superclass == nil ifTrue: [^self sharedPools copy] ifFalse: [aSet _ superclass allSharedPools. aSet addAll: self sharedPools. ^aSet]! removeSharedPool: aDictionary "Remove the pool dictionary, aDictionary, as one of the receiver's pool dictionaries. Create an error if the dictionary is not one of the pools." | satisfiedSet workingSet aSubclass | (self sharedPools includes: aDictionary) ifFalse: [^self error: 'the dictionary is not in my pool']. "first see if it is declared in a superclass in which case we can remove it." (self allSuperclasses select: [:class | class sharedPools includes: aDictionary]) isEmpty ifFalse: [sharedPools remove: aDictionary. sharedPools isEmpty ifTrue: [sharedPools _ nil]. ^self]. "second get all the subclasses that reference aDictionary through me rather than a superclass that is one of my subclasses." workingSet _ self subclasses asOrderedCollection. satisfiedSet _ Set new. [workingSet isEmpty] whileFalse: [aSubclass _ workingSet removeFirst. (aSubclass sharedPools includes: aDictionary) ifFalse: [satisfiedSet add: aSubclass. workingSet addAll: aSubclass subclasses]]. "for each of these, see if they refer to any of the variables in aDictionary because if they do, we can not remove the dictionary." satisfiedSet add: self. satisfiedSet do: [:sub | aDictionary associationsDo: [:aGlobal | (sub whichSelectorsReferTo: aGlobal) isEmpty ifFalse: [^self error: aGlobal key , ' is still used in code of class ' , sub name]]]. sharedPools remove: aDictionary. sharedPools isEmpty ifTrue: [sharedPools _ nil]! sharedPools "Answer a Set of the pool dictionaries declared in the receiver." sharedPools == nil ifTrue: [^Set new] ifFalse: [^sharedPools]! ! !Class methodsFor: 'compiling'! compileAllFrom: otherClass super compileAllFrom: otherClass. self class compileAllFrom: otherClass class! poolHas: varName ifTrue: assocBlock "Look up the first argument in the context of the receiver. If it is there, pass the association to assocBlock, and answer true, else answer false." | assoc | assoc _ self classPool associationAt: varName ifAbsent: []. assoc == nil ifFalse: [assocBlock value: assoc. ^true]. self sharedPools do: [:pool | assoc _ pool associationAt: varName ifAbsent: []. assoc == nil ifFalse: [assocBlock value: assoc. ^true]]. ^ false! ! !Class methodsFor: 'subclass creation'! subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver)." self isVariable ifTrue: [self isPointers ifTrue: [^self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat]. self isBytes ifTrue: [^self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat]. ^self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat]. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: false words: true pointers: true classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! subclass: t otherSupers: others instanceVariableNames: f classVariableNames: d category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver)." self isVariable ifTrue: [self isPointers ifTrue: [^self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: '' category: cat]. self isBytes ifTrue: [^self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: '' category: cat]. ^self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: '' category: cat]. ^self class name: t inEnvironment: Smalltalk subclassOf: self and: others instanceVariableNames: f variable: false words: true pointers: true classVariableNames: d poolDictionaries: '' category: cat comment: nil changed: false! variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable byte-sized nonpointer variables." self instSize > 0 ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. (self isVariable and: [self isWords]) ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields']. (self isVariable and: [self isPointers]) ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. ((Scanner new scanFieldNames: f ) size > 0) ifTrue: [^self error: 'cannot make a byte subclass with pointer fields']. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: true words: false pointers: false classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable pointer variables." self isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: true words: true pointers: true classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable word-sized nonpointer variables." self instSize > 0 ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. self isBytes ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields']. (self isVariable and: [self isPointers]) ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. ((Scanner new scanFieldNames: f ) size > 0) ifTrue: [^self error: 'cannot make a word subclass with pointer fields']. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: true words: true pointers: false classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! ! !Class methodsFor: 'fileIn/Out'! fileOut "Create a file whose name is the name of the receiver with -.st- as the extension, and file a description of the receiver onto it" | fileStream | Transcript refresh; cr; cr; show: 'Filing out class:'. fileStream _ FileStream fileNamed: self name , '.st'. fileStream timeStamp. self fileOutOn: fileStream moveSource: false toFile: 0. fileStream shorten; close. self removeFromChanges.! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." Transcript cr; show: name. super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. self class nonTrivial ifTrue: [aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. self class fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex].! printOut "Create a readable version of my definition, and send to a printer. Defaults to fileOut." self fileOut! removeFromChanges "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet." Smalltalk changes removeClassChanges: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Class class instanceVariableNames: ''! !Class class methodsFor: 'instance creation'! getSuperclasses: superNames | supers | "find the superclasses corresponding to the superclass names" supers _ (Scanner new scanTokens: superNames) collect: [:each | Smalltalk at: each]. "check that each is a kind of Behavior" supers do: [:each | (each isKindOf: Behavior) ifFalse: [self error: 'superclass must be a class-describing object']]. ^supers! named: newClassName superclasses: newSuperNames instanceVariableNames: myInstVarNames classVariableNames: classVarNames category: cat | newClass supers | "find the superclasses corresponding to the superclass names" supers _ self getSuperclasses: newSuperNames. supers size=1 ifTrue: [^supers first "if there's only one superclass, just use old code" subclass: newClassName instanceVariableNames: myInstVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat]. newClass _ supers first subclass: newClassName otherSupers: (supers copyFrom: 2 to: supers size) instanceVariableNames: myInstVarNames classVariableNames: classVarNames category: cat. ^newClass! template: category "Answer an expression that can be edited and evaluated in order to define a new class." ^'NameOfSuperclass subclass: #NameOfClass instanceVariableNames: ''instVarName1 instVarName2'' classVariableNames: ''ClassVarName1 ClassVarName2'' poolDictionaries: '''' category: ''' , category , ''''! ! Object subclass: #ClassCategoryReader instanceVariableNames: 'class category ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Support'! ClassCategoryReader comment: 'An instance of class ClassCategoryReader is created during file in in response to "class methodsFor: cat" message. The instance subsequently scans consecutive "chunks" from the file in stream and asks class to compile them in this category. It continues in this way until an empty chunk is found. Instance Variables: class the class being read in category the category for methods being read in '! !ClassCategoryReader methodsFor: 'fileIn/Out'! scanFrom: aStream "Files in methods from the stream, aStream. Prints the name and category of the methods in the transcript view." | string | Transcript nextPutAll: class name; nextPut: $<; nextPutAll: category; cr; endEntry. [string _ aStream nextChunk. string size > 0] "done when double terminators" whileTrue: [class compile: string classified: category]! ! !ClassCategoryReader methodsFor: 'private'! setClass: aClass category: aCategory class _ aClass. category _ aCategory! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassCategoryReader class instanceVariableNames: ''! !ClassCategoryReader class methodsFor: 'instance creation'! class: aClass category: aCategory "Answer a new instance of ClassCategoryReader for the category, aCategory, of the class, aClass." ^self new setClass: aClass category: aCategory! ! ClassRelatedChange subclass: #ClassChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! ClassChange comment: 'Class ClassChange represents a change to some part of a class definition (actual definition, comment, name, ...) as opposed to a change to a method within a class. As this class currently adds no further information, it is being used to fulfill class hierarchy symmetry with MethodChange.'! ClassOtherChange subclass: #ClassCommentChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! ClassCommentChange comment: 'Class ClassCommentChange represents a change to some part of a class comment.'! !ClassCommentChange methodsFor: 'accessing'! text ^file == nil ifTrue: [className, ' comment: ', (Smalltalk at: className) comment printString] ifFalse: [super text]! ! !ClassCommentChange methodsFor: 'checking'! checkWith: aChecker aChecker changesAt: className, '<', type, '>' add: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassCommentChange class instanceVariableNames: ''! !ClassCommentChange class methodsFor: 'instance creation'! new ^super new type: #comment! ! ClassChange subclass: #ClassDefinitionChange instanceVariableNames: 'superclassName classType otherParameters ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! ClassDefinitionChange comment: 'Class ClassDefinitionChange represents a change to some part of a class definition. Instance Variables: superclassName classType otherParameters '! !ClassDefinitionChange methodsFor: 'accessing'! name ^' define ', className! superclassName: aSymbol classType: aSelector otherParameters: anArray superclassName _ aSymbol. classType _ aSelector. otherParameters _ anArray! text ^file == nil ifTrue: [(Smalltalk at: className) definition] ifFalse: [super text]! ! !ClassDefinitionChange methodsFor: 'checking'! checkWith: aChecker | class | aChecker changesAt: className add: self. aChecker checkSystem ifTrue: [class _ Smalltalk at: className ifAbsent: [^self]. self text = class definition ifFalse: [aChecker changesAt: className add: (self class new className: className)]]! ! Behavior subclass: #ClassDescription instanceVariableNames: 'instanceVariables organization ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! ClassDescription comment: 'ClassDescription adds a number of facilities to basic Behavior: - named instance variables - category organization for methods - the notion of a name of this class (implemented as subclass responsibility) - the maintenance of the Changes set, and logging changes on a file - most of the mechanism for fileOut ClassDescription is an abstract class: its facilities are intended for inheritance by the two subclasses, Class and Metaclass. Instance Variables: instanceVariables names of instance fields organization provides organization of message protocol '! !ClassDescription methodsFor: 'initialize-release'! obsolete "Make the receiver obsolete." organization _ nil. super obsolete! subclassOf: newSuper oldClass: oldClass instanceVariableNames: newInstVarString variable: v words: w pointers: p ifBad: badBlock "Basic initialization message for creating classes using the information provided as arguments. Answer whether old instances will be invalidated." | old new usedNames invalid oldSuperMeta newInstVarArray | old _ self allInstVarNames. usedNames _ #(self super thisContext true false nil ) asSet. newInstVarArray _ Scanner new scanFieldNames: newInstVarString. (invalid _ superclass ~~ newSuper) ifTrue: ["superclass changed" oldSuperMeta _ superclass class. superclass removeSubclass: self. superclass _ newSuper. superclass addSubclass: self. self class superclass == oldSuperMeta ifTrue: ["Only false when self is a metaclass" self class superclass: newSuper class]]. instanceVariables _ nil. "To give us all super names" new _ self allInstVarNames , newInstVarArray. new do: [:fieldName | (usedNames includes: fieldName) ifTrue: [self error: fieldName , ' is reserved (maybe in a superclass)'. ^badBlock value]. usedNames add: fieldName]. instanceVariables _ newInstVarArray size = 0 ifTrue: [nil] ifFalse: [newInstVarArray]. invalid _ invalid | (new ~= old). "field names changed" old _ format. self format: new size variable: v words: w pointers: p. invalid _ invalid | (format ~= old). "format changed" ^invalid! updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary." | oldInstVarNames map variable new instSize | oldClass someInstance == nil ifTrue: [^self]. "no instances to convert" oldInstVarNames _ oldClass allInstVarNames. map _ self allInstVarNames collect: [:instVarName | oldInstVarNames indexOf: instVarName]. variable _ self isVariable. instSize _ self instSize. oldClass allInstances do: [:old | "note allInstsDo would get confused by becoming" variable ifTrue: [new _ self basicNew: old basicSize] ifFalse: [new _ self basicNew]. 1 to: instSize do: [:offset | (map at: offset) > 0 ifTrue: [new instVarAt: offset put: (old instVarAt: (map at: offset))]]. variable ifTrue: [1 to: old basicSize do: [:offset | new basicAt: offset put: (old basicAt: offset)]]. old become: new]! validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods "Recompile the receiver, a class, and redefine its subclasses if necessary." | newSub | invalidFields & invalidMethods ifFalse: [^self]. invalidMethods & self hasMethods ifTrue: [Transcript show: 'recompiling ' , self name , '...'. self compileAllFrom: oldClass. Transcript show: ' done'; cr]. self ~~ oldClass ifTrue: [self updateInstancesFrom: oldClass]. oldClass subclasses do: [:sub | newSub _ sub copyForValidation. newSub subclassOf: self oldClass: sub instanceVariableNames: sub instVarNames variable: sub isVariable words: sub isBytes not pointers: sub isBits not ifBad: [self error: 'terrible problem in recompiling subclasses!!']. newSub validateFrom: sub in: environ instanceVariableNames: invalidFields methods: invalidMethods]! ! !ClassDescription methodsFor: 'accessing'! comment "Answer the receiver's comment." | aString | aString _ self organization classComment. aString size = 0 ifTrue: [^'']. "get string only of classComment, undoubling quotes" ^ String readFromString: aString! comment: aString "Set the receiver's comment to be the argument, aString." | aStream | aString size = 0 ifTrue: [self organization classComment: aString] ifFalse: ["double internal quotes of the comment string" aStream _ WriteStream on: (String new: aString size). aStream nextPutAll: self name , ' comment:'; cr. aString storeOn: aStream. self organization classComment: aStream contents. Smalltalk changes commentClass: self]! commentTemplate "Answer an expression to edit and evaluate in order to produce the receiver's comment." | aString | aString _ self organization classComment. aString size = 0 ifTrue: [^self name , ' comment: ''This class has not yet been commented. A proper comment should include the purpose of the class and the type and purpose of each instance variable. '''] ifFalse: [^aString]! name "Answer a String that is the name of the receiver." self subclassResponsibility! ! !ClassDescription methodsFor: 'copying'! copy: sel from: class "Install the method associated with the first arugment, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under -as yet not classified-" self copy: sel from: class classified: nil! copy: sel from: class classified: cat "Install the method associated with the first arugment, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under the third argument, cat." | code category | "Useful when modifying an existing class" code _ class sourceMethodAt: sel. code == nil ifFalse: [cat == nil ifTrue: [category _ class organization categoryOfElement: sel] ifFalse: [category _ cat]. (methodDict includesKey: sel) ifTrue: [code asString = (self sourceMethodAt: sel) asString ifFalse: [self error: self name , ' ' , sel , ' will be redefined if you proceed.']]. self compile: code classified: category]! copyAll: selArray from: class "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under -as yet not classified-" self copyAll: selArray from: class classified: nil! copyAll: selArray from: class classified: cat "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under the third argument, cat." selArray do: [:s | self copy: s from: class classified: cat]! copyAllCategoriesFrom: aClass "Specify that the categories of messages for the receiver include all of those found in the class, aClass. Install each of the messages found in these categories into the method dictionary of the receiver, classified under the appropriate categories." aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! copyCategory: cat from: class "Specify that one of the categories of messages for the receiver is cat, as found in the class, aClass. Copy each message found in this category." self copyCategory: cat from: class classified: cat! copyCategory: cat from: aClass classified: newCat "Specify that one of the categories of messages for the receiver is the third argument, newCat. Copy each message found in the category cat in class aClass into this new category." self copyAll: (aClass organization listAtCategoryNamed: cat) from: aClass classified: newCat! ! !ClassDescription methodsFor: 'testing'! isMeta ^ false! ! !ClassDescription methodsFor: 'printing'! classVariablesString "Answer a string of my class variable names separated by spaces, in alphabetical order." | aStream | aStream _ WriteStream on: (String new: 100). self classPool keys asSortedCollection do: [:key | aStream nextPutAll: key; space]. ^ aStream contents! definition "Answer a string that defines the receiver." | aStream | aStream _ WriteStream on: (String new: 300). self hasMultipleSuperclasses ifTrue: [aStream nextPutAll: 'Class named: '. self name storeOn: aStream. aStream cr; tab; nextPutAll: 'superclasses: '. aStream store: self superclassesString. aStream cr; tab; nextPutAll: 'instanceVariableNames: '. aStream store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '. aStream store: self classVariablesString] ifFalse: [aStream nextPutAll: (superclass == nil ifTrue: ['nil'] ifFalse: [superclass name]). aStream nextPutAll: self kindOfSubclass. self name storeOn: aStream. aStream cr; tab; nextPutAll: 'instanceVariableNames: '. aStream store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '. aStream store: self classVariablesString. aStream cr; tab; nextPutAll: 'poolDictionaries: '. aStream store: self sharedPoolsString]. aStream cr; tab; nextPutAll: 'category: '. (SystemOrganization categoryOfElement: self name) asString storeOn: aStream. ^aStream contents! instanceVariablesString "Answer a string of my instance variable names separated by spaces." | aStream names | aStream _ WriteStream on: (String new: 100). names _ self instVarNames. 1 to: names size do: [:i | aStream nextPutAll: (names at: i); space]. ^ aStream contents! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." aStream nextPutAll: self name! sharedPoolsString "Answer a string of my class variable names separated by spaces." | aStream | aStream _ WriteStream on: (String new: 100). self sharedPools do: [:x | aStream nextPutAll: (Smalltalk keyAtValue: x); space]. ^ aStream contents! storeOn: aStream "Append to the argument aStream the global names of. Classes and Metaclasses." aStream nextPutAll: self name! superclassesString "Answer a string of my superclass names separated by spaces." | aStream | aStream _ WriteStream on: (String new: 100). self superclasses do: [:each | aStream nextPutAll: each name; space]. ^ aStream contents! ! !ClassDescription methodsFor: 'instance variables'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." self subclassResponsibility! instVarNames "Answer an Array of the names of instance variables defined in the receiver." instanceVariables == nil ifTrue: [^#()] ifFalse: [^instanceVariables]! removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables." self subclassResponsibility! ! !ClassDescription methodsFor: 'method dictionary'! removeCategory: aString "Remove each of the messages categorized under aString in the method dictionary of the receiver. Then remove the category aString." (self organization listAtCategoryNamed: aString asSymbol) do: [:sel | self removeSelector: sel]. self organization removeEmptyCategories! removeSelector: aSymbol "Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise." (methodDict includesKey: aSymbol) ifFalse: [^nil]. super removeSelector: aSymbol. self organization removeElement: aSymbol. Smalltalk changes removeSelector: aSymbol class: self. Smalltalk logChange: self name , ' removeSelector: #' , aSymbol! ! !ClassDescription methodsFor: 'organization'! category "Answer the system organization category for the receiver." ^SystemOrganization categoryOfElement: self name! category: cat "Categorize the receiver under the system category, cat, removing it from any previous categorization." (cat isKindOf: String) ifTrue: [SystemOrganization classify: self name under: cat asSymbol] ifFalse: [self errorCategoryName]! logOrganizationChange "Record that the receiver is being reorganized on the changes file." | file | SourceFiles == nil ifFalse: [file _ SourceFiles at: 2. file setToEnd; readWriteShorten. file cr; nextChunkPut: self name, ' organization changeFromString: ', self organization printString storeString. file cr; readOnly]! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization==nil ifTrue: [organization _ ClassOrganizer new]. ^organization! reorganize "Record that the receiver is being reorganized and answer the receiver's organization." Smalltalk changes reorganizeClass: self. ^self organization! whichCategoryIncludesSelector: aSelector "Answer the category of the argument, aSelector, in the organization of the receiver, or answer nil if the receiver does not inlcude this selector." (self includesSelector: aSelector) ifTrue: [^organization categoryOfElement: aSelector] ifFalse: [^nil]! ! !ClassDescription methodsFor: 'compiling'! compile: code classified: heading "Compile the argument, code, as source code in the context of the receiver and install the result in the receiver's method dictionary under the classification indicated by the second argument, heading. nil is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." ^self compile: code classified: heading notifying: nil! compile: code classified: heading notifying: requestor "Compile the argument, code, as source code in the context of the receiver and install the result in the receiver's method dictionary under the classification indicated by the second argument, heading The third argument, requestor, is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." | selector | selector _ self compile: code notifying: requestor remoteString: RemoteString empty ifFail: [^nil]. (methodDict at: selector) putSource: code asString class: self category: heading inFile: 2. self organization classify: selector under: heading. ^selector! compile: code notifying: requestor remoteString: aRemoteString ifFail: failBlock "Intercept this message in order to remember system changes." | methodNode selector | Cursor execute showWhile: [methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. selector _ methodNode selector. (methodDict includesKey: selector) ifTrue: [Smalltalk changes changeSelector: selector class: self] ifFalse: [Smalltalk changes addSelector: selector class: self]. self addSelector: selector withMethod: (methodNode generateAt: aRemoteString)]. ^selector! ! !ClassDescription methodsFor: 'fileIn/Out'! fileOutCategory: aString "Create a file whose name is the name of the receiver with -.st- as the extension, and file a description of the receiver's category aString onto it." | fileName fileStream | fileName _ FileDirectory default checkName: self name , '-' , aString , '.st' fixErrors: true. fileStream _ FileStream fileNamed: fileName. fileStream timeStamp. self fileOutCategory: aString on: fileStream moveSource: false toFile: 0. fileStream shorten; close! fileOutCategory: aString on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver's category, aString, onto aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." self printCategoryChunk: aString on: aFileStream. (self organization listAtCategoryNamed: aString) do: [:sel | self printMethodChunk: sel on: aFileStream moveSource: moveSource toFile: fileIndex]. aFileStream nextChunkPut: ' '! fileOutChangedMessages: aSet on: aFileStream "File a description of the messages of the receiver that have been changed (i.e., are entered into the system ChangeSet) onto aFileStream." self fileOutChangedMessages: aSet on: aFileStream moveSource: false toFile: 0! fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the messages of the receiver that have been changed (i.e., are entered into the system ChangeSet) onto aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." | org sels | (org _ self organization) categories do: [:cat | sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels size > 0 ifTrue: [Transcript cr; show: self name , '>' , cat. self printCategoryChunk: cat on: aFileStream. sels do: [:sel | self printMethodChunk: sel on: aFileStream moveSource: moveSource toFile: fileIndex]. aFileStream nextChunkPut: ' ']]! fileOutMessage: aString "Create a fileName which is the name of the receiver with -.st as the extension, and file a description of the receiver's message aString onto it" self fileOutMessage: aString fileName: (FileDirectory default checkName: self name , '-' , aString , '.st' fixErrors: true)! fileOutMessage: aString fileName: fileName "Create a local file named fileName and file a description of the receiver's message aString onto it" | fileStream | fileStream _ FileStream fileNamed: fileName. fileStream timeStamp. self fileOutMessage: aString on: fileStream moveSource: false toFile: 0. fileStream close! fileOutMessage: aString on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver's message, aString, onto aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." | cat | cat _ self organization categoryOfElement: aString. cat == nil ifTrue: [^self error: 'no such message']. self printCategoryChunk: cat on: aFileStream. self printMethodChunk: aString on: aFileStream moveSource: moveSource toFile: fileIndex. aFileStream nextChunkPut: ' '! fileOutOn: aFileStream "File a description of the receiver on aFileStream." self fileOutOn: aFileStream moveSource: false toFile: 0! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "file me out on aFileStream" aFileStream emphasis: 5. "Meant to be 12 point bold font." aFileStream nextChunkPut: self definition. self organization putCommentOnFile: aFileStream numbered: fileIndex moveSource: moveSource. aFileStream cr. self organization categories do: [:heading | self fileOutCategory: heading on: aFileStream moveSource: moveSource toFile: fileIndex]! fileOutOrganizationOn: aFileStream "File a description of the receiver's organization onto aFileStream." aFileStream emphasis: 3. aFileStream cr; nextPut: $!!. aFileStream nextChunkPut: self name, ' reorganize'; cr. aFileStream nextChunkPut: self organization printString; cr. aFileStream emphasis: 1! kindOfSubclass "Answer a string that describes what kind of subclass the receiver is, i.e., variable, variable byte, variable word, or not variable." self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [^' variableByteSubclass: '] ifFalse: [^' variableWordSubclass: ']] ifFalse: [^' variableSubclass: ']] ifFalse: [^' subclass: ']! methodsFor: aString "Answer a ClassCategoryReader for accessing the messages in the method dictionary category, aString, of the receiver." ^ClassCategoryReader class: self category: aString asSymbol "False methodsFor: 'logical operations' inspect"! moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | self organization moveChangedCommentToFile: newFile numbered: 2. changes _ methodDict keys select: [:sel | (methodDict at: sel) fileIndex = 2]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! printCategoryChunk: aString on: aFileStream "print category definition on aFileStream" aFileStream cr; cr; nextPut: $!!. aFileStream nextChunkPut: self name , ' methodsFor: ' , '''' , aString , ''''! printMethodChunk: aSelector on: aFileStream moveSource: moveSource toFile: fileIndex "Print the source code for the method associated with the argument selector onto the fileStream. aFileStream, and, for backup, if the argument moveSource (a Boolean) is true, also set the file index within the method to be the argument fileIndex. " | position | aFileStream cr. Cursor write showWhile: [moveSource ifTrue: [position _ aFileStream position. aFileStream nextChunkPut: (self sourceCodeAt: aSelector). (self compiledMethodAt: aSelector) setSourcePosition: position inFile: fileIndex] ifFalse: [aFileStream cr; nextChunkPut: (self sourceCodeAt: aSelector)]]! printOutCategory: aString "Create a readable version of the message category aString, and send to a printer. Defaults to fileOut." self fileOutCategory: aString! printOutMessage: aString "Create a readable version of the message with selector aString, and send to a printer. Defaults to fileOut." self fileOutMessage: aString! ! !ClassDescription methodsFor: 'private'! errorCategoryName self error: 'Category name must be a String'! ! Object subclass: #ClassOrganizer instanceVariableNames: 'globalComment categoryArray categoryStops elementArray ' classVariableNames: 'Default ' poolDictionaries: '' category: 'Kernel-Support'! ClassOrganizer comment: 'ClassOrganizers contain the categorization information for classes. A ClassOrganizer consists of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories _ Array with: #firstCat with: secondCat with: thirdCat stops _ Array with: 1 with: 4 with: 4 elements _ Array with: #a with: #b with: #c with: #d means that category firstCat has ony #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size. Instance variables: globalComment comment for the class as a whole categoryArray category names categoryStops see below elementArray message selectors Class Variable: Default label for a yet-to-named protocol '! !ClassOrganizer methodsFor: 'accessing'! changeFromString: aString "Parse the string and make this be the receiver's structure. Categories or elements not found are not affected. New elements are ignored." | scanner oldElements newElements newCategories newStops currentStop anArray | scanner _ Scanner new scanTokens: aString. "If nothing was scanned and I had no elements before, then default me" (scanner size = 0 and: [elementArray size = 0]) ifTrue: [^self setDefaultList]. oldElements _ elementArray asSet. newCategories _ Array new: scanner size. newStops _ Array new: scanner size. currentStop _ 0. newElements _ WriteStream on: (Array new: 16). 1 to: scanner size do: [:i | anArray _ scanner at: i. newCategories at: i put: anArray first asSymbol. (anArray copyFrom: 2 to: anArray size) asSortedCollection do: [:elem | (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue: [newElements nextPut: elem. currentStop _ currentStop+1]]. newStops at: i put: currentStop]. "Ignore extra elements but don't lose any existing elements!!" oldElements _ oldElements collect: [:elem | Array with: (self categoryOfElement: elem) with: elem]. newElements _ newElements contents. categoryArray _ newCategories. categoryStops _ newStops. elementArray _ newElements. oldElements do: [:pair | self classify: pair last under: pair first].! ! !ClassOrganizer methodsFor: 'categories'! addCategory: heading "Add a new category named heading." ^ self addCategory: heading before: nil! addCategory: heading before: nextHeading | nextIndex elements | "Add a new category named heading. If nextHeading is specified (not nil) and can be found, then INSERT before that entry. Otherwise ADD it at the end. If heading already exists, then MOVE it where it would have gone otherwise." (categoryArray indexOf: heading) > 0 ifTrue: "already there - maybe move" ["slow but sure; remove all, then insert all" elements _ self listAtCategoryNamed: heading. "Save elements" elements do: [:elt | self removeElement: elt]. self removeCategory: heading. "Remove old entry" self addCategory: heading before: nextHeading. "Now insert anew" self classifyAll: elements under: heading. "And restore elements" ^self]. nextIndex _ categoryArray indexOf: nextHeading ifAbsent: [categoryArray size+1]. categoryArray _ categoryArray "insert before nextIndex" copyReplaceFrom: nextIndex to: nextIndex-1 with: (Array with: heading). categoryStops _ categoryStops copyReplaceFrom: nextIndex to: nextIndex-1 with: (Array with: (nextIndex=1 ifTrue: [0] ifFalse: [categoryStops at: nextIndex-1])).! categories "Answer an array of categories (names)." (categoryArray size = 1 and: [categoryArray first = Default & (elementArray size = 0)]) ifTrue: [^Array new]. ^categoryArray! categories: anArray "Reorder my categories to be in the order of anArray. If the resulting organization does not include all elements, then give an error." | newCategories newStops newElements catName list runningTotal | newCategories _ Array new: anArray size. newStops _ Array new: anArray size. newElements _ Array new: 0. runningTotal _ 0. 1 to: anArray size do: [:i | catName _ (anArray at: i) asSymbol. list _ self listAtCategoryNamed: catName. newElements _ newElements, list. newCategories at: i put: catName. newStops at: i put: (runningTotal _ runningTotal + list size)]. elementArray do: [:element | "check to be sure all elements are included" (newElements includes: element) ifFalse: [^self error: 'New categories must match old ones']]. "Everything is good, now update my three arrays." categoryArray _ newCategories. categoryStops _ newStops. elementArray _ newElements! categoryOfElement: element "Answer the category associated with the argument, element." | index | index _ self numberOfCategoryOfElement: element. index = 0 ifTrue: [^nil] ifFalse: [^categoryArray at: index]! removeCategory: cat "Remove the category named, cat. Create an error if the category has any elements in it." | index lastStop | index _ categoryArray indexOf: cat ifAbsent: [^self]. lastStop _ index = 1 ifTrue: [0] ifFalse: [categoryStops at: index - 1]. (categoryStops at: index) - lastStop > 0 ifTrue: [^self error: 'cannot remove non-empty category']. categoryArray _ (categoryArray copyFrom: 1 to: index - 1) , (categoryArray copyFrom: index + 1 to: categoryArray size). categoryStops _ (categoryStops copyFrom: 1 to: index - 1) , (categoryStops copyFrom: index + 1 to: categoryStops size).! removeEmptyCategories "Remove empty categories." | categoryIndex currentStop keptCategories keptStops | keptCategories _ WriteStream on: (Array new: 16). keptStops _ WriteStream on: (Array new: 16). currentStop _ categoryIndex _ 0. [(categoryIndex _ categoryIndex + 1) <= categoryArray size] whileTrue: [(categoryStops at: categoryIndex) > currentStop ifTrue: [keptCategories nextPut: (categoryArray at: categoryIndex). keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]]. categoryArray _ keptCategories contents. categoryStops _ keptStops contents. "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! renameCategory: oldName to: newName "Answer the array of elements associated with the name, categoryName." | i symbol | i _ categoryArray indexOf: oldName ifAbsent: [^ false]. symbol _ newName asSymbol. categoryArray indexOf: symbol ifAbsent: [categoryArray at: i put: symbol. ^ true]. ^ false "newName was already there"! ! !ClassOrganizer methodsFor: 'elements'! classify: element under: heading "Store the argument, element, in the category named heading." | catName catIndex elemIndex realHeading | realHeading _ heading asSymbol. (catName _ self categoryOfElement: element) ~~ nil ifTrue: "Element already there" [realHeading = Default ifTrue: [^self]. "Default causes no change" realHeading = catName ifTrue: [^self]. "heading didnt change" self removeElement: element]. "remove from old heading if did change" (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. "add realHeading if not there already" catIndex _ categoryArray indexOf: realHeading. elemIndex _ catIndex > 1 ifTrue: [categoryStops at: catIndex - 1] ifFalse: [0]. [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) and: [element >= (elementArray at: elemIndex)]] whileTrue. "elemIndex is now the index for inserting the element. Do the insertion before it." elementArray _ (elementArray copyFrom: 1 to: elemIndex - 1) , (Array with: element) , (elementArray copyFrom: elemIndex to: elementArray size). "insertion" "add one to stops for this and later categories" catIndex to: categoryArray size do: [:i | categoryStops at: i put: (categoryStops at: i) + 1]. "remove empty default category if any" categoryArray indexOf: Default ifAbsent: [^self]. (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default].! classifyAll: aCollection under: heading aCollection do: [:element | self classify: element under: heading]! elements ^elementArray! includesElement: element ^ (self categoryOfElement: element) ~~ nil! listAtCategoryNamed: categoryName "Answer the array of elements associated with the name, categoryName." | i | i _ categoryArray indexOf: categoryName ifAbsent: [^Array new]. ^self listAtCategoryNumber: i! removeElement: element "Remove the selector, element, from all categories." | categoryIndex elementIndex nextStop newElements | categoryIndex _ 1. elementIndex _ 0. nextStop _ 0. "nextStop keeps track of the stops in the new element array" newElements _ WriteStream on: (Array new: elementArray size). [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: [[elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. element = (elementArray at: elementIndex) ifFalse: [nextStop _ nextStop + 1. newElements nextPut: (elementArray at: elementIndex)]]. [categoryIndex <= categoryStops size] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. elementArray _ newElements contents! ! !ClassOrganizer methodsFor: 'comment'! classComment "Answer the comment associated with the object that refers to the receiver." globalComment == nil ifTrue: [^'']. ^globalComment string! classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." aString size = 0 ifTrue: [globalComment _ nil] ifFalse: [globalComment _ RemoteString newString: aString onFileNumber: 2]! hasNoComment "Answer whether the class classified by the receiver has a comment." ^globalComment == nil! moveChangedCommentToFile: aFileStream numbered: sourceIndex "This is part of source code compression. Move the comment about the class classified by the receiver from the file referenced by sourceIndex and to the stream, aFileStream." (globalComment ~~ nil and: [globalComment sourceFileNumber > 1]) ifTrue: [aFileStream cr; cr. globalComment _ RemoteString newString: globalComment string onFileNumber: sourceIndex toFile: aFileStream]! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource "Store the comment about the class onto file, aFileStream." | newRemoteString saveEmphasis | saveEmphasis _ aFileStream emphasis. aFileStream emphasis: 3. "meant to be 10 point italic font" globalComment ~~ nil ifTrue: [aFileStream cr. newRemoteString _ RemoteString newString: globalComment string onFileNumber: sourceIndex toFile: aFileStream. moveSource ifTrue: [globalComment _ newRemoteString]]. aFileStream emphasis: saveEmphasis.! ! !ClassOrganizer methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." | elementIndex | elementIndex _ 1. 1 to: categoryArray size do: [:i | aStream nextPut: $(. (categoryArray at: i) asString printOn: aStream. [elementIndex <= (categoryStops at: i)] whileTrue: [aStream space. (elementArray at: elementIndex) printOn: aStream. elementIndex _ elementIndex + 1]. aStream nextPut: $). aStream cr]! ! !ClassOrganizer methodsFor: 'fileIn/Out'! scanFrom: aStream "Reads in the organization from the next chunk on aStream. Categories or elements not found in the definition are not affected. New elements are ignored." self changeFromString: aStream nextChunk! ! !ClassOrganizer methodsFor: 'private'! listAtCategoryNumber: index "Answer the array of elements stored at the position index." | firstIndex lastIndex | firstIndex _ index = 1 ifTrue: [1] ifFalse: [(categoryStops at: index - 1) + 1]. lastIndex _ categoryStops at: index. ^ elementArray copyFrom: firstIndex to: lastIndex! numberOfCategoryOfElement: element "Answer the index of the category with which the argument, element, is associated." | categoryIndex elementIndex | categoryIndex _ 1. elementIndex _ 0. [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: ["point to correct category" [elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryIndex _ categoryIndex + 1]. "see if this is element" element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. ^0! setDefaultList self classComment: ''. categoryArray _ categoryStops _ elementArray _ Array new! setDefaultList: aSortedCollection self classComment: ''. categoryArray _ Array with: Default. categoryStops _ Array with: aSortedCollection size. elementArray _ aSortedCollection asArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassOrganizer class instanceVariableNames: ''! !ClassOrganizer class methodsFor: 'class initialization'! defaultProtocol ^Default! initialize Default _ 'As yet unclassified' asSymbol "ClassOrganizer initialize"! ! !ClassOrganizer class methodsFor: 'instance creation'! new "Answer a new instance of ClassOrganizer with no initial elements." ^super new setDefaultList! ! ClassOrganizer initialize! ClassChange subclass: #ClassOtherChange instanceVariableNames: 'type ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! ClassOtherChange comment: 'Class ClassOtherChange represents a change to a class, other than a class definition. Instance Variable: type Possible types are: comment, initialize, inst vars for, rename, and rename to.'! !ClassOtherChange methodsFor: 'accessing'! name ^' ', type, ' ', className! type ^type! type: aSymbol type _ aSymbol! ! !ClassOtherChange methodsFor: 'checking'! checkWith: aChecker aChecker changesAt: className add: self. type == 'inst vars for' asSymbol ifFalse: [aChecker addDoIt: self]! ! Change subclass: #ClassRelatedChange instanceVariableNames: 'className ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! ClassRelatedChange comment: 'Class ClassRelatedChange represents a change related in some way to a particular class. Instance Variable: className '! !ClassRelatedChange methodsFor: 'accessing'! className ^className! className: aSymbol className _ aSymbol asSymbol! classObject | class | ^Smalltalk at: className ifAbsent: [(className size > 6 and: [(className copyFrom: className size - 5 to: className size) = ' class']) ifTrue: [class _ Smalltalk at: (className copyFrom: 1 to: className size - 6) asSymbol ifAbsent: [^nil]. (class isKindOf: Class) ifTrue: [class class] ifFalse: [nil]] ifFalse: [nil]]! getSource "Set me up to point to the version of this change which is currently installed in the system." self subclassResponsibility! parameters ^className! ! MouseMenuController subclass: #ClockController instanceVariableNames: 'clockProcess ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Clocks'! ClockController comment: 'I am the controller for clock views. I set up the process that updates the clock every minute.'! !ClockController methodsFor: 'initialize-release'! initialize "start the process to update the clock every minute. One might want to make this less frequent (like every 3 minutes)." super initialize. clockProcess _ [[(Delay forSeconds: 60) wait. view displaySafe: [view topView display]. true] whileTrue] newProcess. clockProcess resume! release "stop the update process." clockProcess terminate! ! !ClockController methodsFor: 'control activity'! isControlActive "am i awake?" ^super isControlActive & sensor blueButtonPressed not! ! TextController subclass: #CodeController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! CodeController comment: 'This controller adds some capability appropriate only to viewing Smalltalk code, such as ''explain'' and ''format''.'! !CodeController methodsFor: 'menu messages'! doIt "Evaluate the current text selection as an expression" | result selectionStart oldTextSize selection | self controlTerminate. selectionStart _ startBlock stringIndex. oldTextSize _ self text size. selection _ self selection. result _ model doItReceiver class evaluatorClass new evaluate: self selectionAsStream in: model doItContext to: model doItReceiver notifying: self ifFail: [self controlInitialize. ^#failedDoit]. self selection asString = selection asString ifFalse: [self selectFrom: selectionStart "Reselect doIt range after compiler interaction" to: selectionStart + selection size - 1 + (self text size - oldTextSize)]. Smalltalk logChange: self selection string. model doItValue: result. self controlInitialize. ^result! explain "Try to shed some light on what kind of entity the current selection is. The selection must be a single token or construct. Insert the answer after the selection. Call private routines whose names begin with 'explain'. They return a String if they recognise the selection, else nil." | reply | reply _ (Explainer new class: model selectedClass selector: model selector instance: model doItReceiver context: model doItContext methodText: model text) explain: self selection string for: model. reply size = 0 ifTrue: [reply _ '"Sorry, I can''t explain that. Please select a single token, construct, or special character.' , (model isUnlocked ifTrue: ['"'] ifFalse: [' Also, please cancel or accept."']). ]. self insertAndSelect: reply at: stopBlock stringIndex! format "Reformat the contents of the receiver's view, formatted, if the view is unlocked." | selectedClass aCompiler newText | Sensor leftShiftDown ifTrue: [^self miniFormat]. selectedClass _ model selectedClass. selectedClass == nil ifTrue: [^self]. self controlTerminate. Cursor execute showWhile: [aCompiler _ selectedClass compilerClass new. self selectFrom: 1 to: paragraph text size. self deselect. newText _ aCompiler format: paragraph text in: selectedClass notifying: self. newText == nil ifFalse: [self replaceSelectionWith: (newText asText makeSelectorBoldIn: selectedClass). self selectAt: 1]]. self controlInitialize! inspectIt "Evaluate the current text selection as an expression" | result selectionStart oldTextSize selection | self controlTerminate. selectionStart _ startBlock stringIndex. oldTextSize _ self text size. selection _ self selection. result _ model doItReceiver class evaluatorClass new evaluate: self selectionAsStream in: model doItContext to: model doItReceiver notifying: self ifFail: [self controlInitialize. ^#failedDoit]. self selection asString = selection asString ifFalse: [self selectFrom: selectionStart "Reselect doIt range after compiler interaction" to: selectionStart + selection size - 1 + (self text size - oldTextSize)]. Smalltalk logChange: self selection string. model doItValue: result. result inspect! localMenuItem: selector ^ (#(doIt printIt inspectIt format explain) includes: selector) or: [super localMenuItem: selector]! miniFormat "Replace selection with selection un-wrapped." | inStream outStream char | inStream _ ReadStream on: (self selection copyWithout: Character tab). outStream _ WriteStream on: (String new: self selection size). [inStream atEnd] whileFalse: [char _ inStream next. char isSeparator ifTrue: [outStream space. [inStream atEnd not and: [inStream peek isSeparator]] whileTrue: [inStream next]] ifFalse: [outStream nextPut: char]]. self deselect. self replaceSelectionWith: outStream contents asText. self select! printIt "Evaluate the current selection as an expression. If successful, insert and select the printString of the result of evaluation after the current selection." | result | result _ self doIt. result ~~ #failedDoit ifTrue: [self insertAndSelect: result printString at: stopBlock stringIndex]! ! TextView subclass: #CodeView instanceVariableNames: 'initialSelection ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! CodeView comment: 'I am a TextView that assumes the text is code. I include support for initial selection of a part of the text.'! !CodeView methodsFor: 'initialize-release'! initialSelection: sel initialSelection _ sel! newText: aText super newText: aText. initialSelection==nil ifFalse: [self controller find: initialSelection]! ! !CodeView methodsFor: 'controller access'! defaultControllerClass ^ CodeController! ! !CodeView methodsFor: 'updating'! update: aSymbol | range | aSymbol == #pc ifTrue: [range _ model pcRange. self controller selectAndScrollFrom: range first to: range last]. super update: aSymbol! ! !CodeView methodsFor: 'control'! isSelected "Answer true for use with OnlyWhenSelectedCodeController" ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CodeView class instanceVariableNames: ''! !CodeView class methodsFor: 'instance creation'! on: anObject aspect: m1 change: m3 menu: m4 initialSelection: sel "Create an instance viewing anObject. See super method in TextView for full explanation. initialSelection (if not nil) is a string which will be searched for, and then highlighted if found, whenever the viewed text changes." ^ (super on: anObject aspect: m1 change: m3 menu: m4) initialSelection: sel! ! Object subclass: #Collection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! Collection comment: 'The abstract class Collection is at the top of the collection hierarchy. Its subclasses are Bag, MappedCollection, SequenceableCollection, and Set. Bag and Set are unordered and their elements are not accessible by an external key. Duplicates are not allowed in a Set. Elements of a SequenceableCollection are ordered and the ordering can be determined externally, as in an ArrayedCollection, or internally, as in an Interval. MappedCollection represents an indirect access path to a collection whose elements are accessible via external keys. Concrete subclasses must implement methods for adding add: removing remove: ifAbsent: enumerating do:'! !Collection methodsFor: 'accessing'! size "Answer how many elements the receiver contains." | tally | tally _ 0. self do: [:each | tally _ tally + 1]. ^tally! ! !Collection methodsFor: 'testing'! includes: anObject "Answer whether anObject is one of the receiver's elements." self do: [:each | anObject = each ifTrue: [^true]]. ^false! isEmpty "Answer whether the receiver contains any elements." ^self size = 0! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." | tally | tally _ 0. self do: [:each | anObject = each ifTrue: [tally _ tally + 1]]. ^tally! ! !Collection methodsFor: 'adding'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject. This message should not be sent to instances of subclasses of ArrayedCollection." self subclassResponsibility! addAll: aCollection "Include all the elements of aCollection as the receiver's elements. Answer aCollection." aCollection do: [:each | self add: each]. ^aCollection! ! !Collection methodsFor: 'removing'! remove: oldObject "Remove oldObject as one of the receiver's elements. Answer oldObject unless no element is equal to oldObject, in which case, provide an error notification. " ^self remove: oldObject ifAbsent: [self errorNotFound]! remove: oldObject ifAbsent: anExceptionBlock "Remove oldObject as one of the receiver's elements. If several of the elements are equal to oldObject, only one is removed. If no element is equal to oldObject, answer the result of evaluating anExceptionBlock. Otherwise, answer the argument, oldObject. SequenceableCollections can not respond to this message." self subclassResponsibility! removeAll: aCollection "Remove each element of aCollection from the receiver. If successful for each, answer aCollection." aCollection do: [:each | self remove: each]. ^aCollection! ! !Collection methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of the values of the receiver as the argument. Collect the resulting values into a collection that is like the receiver. Answer the new collection." | newCollection | newCollection _ self species new. self do: [:each | newCollection add: (aBlock value: each)]. ^newCollection! detect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true." ^self detect: aBlock ifNone: [self errorNotFound]! detect: aBlock ifNone: exceptionBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true." self do: [:each | (aBlock value: each) ifTrue: [^each]]. ^exceptionBlock value! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." self subclassResponsibility! inject: thisValue into: binaryBlock "Accumulate a running value associated with evaluating the argument, binaryBlock, with the current value and the receiver as block arguments. The initial value is the value of the argument, thisValue." "For example, to sum a collection, use: collection inject: 0 into: [:subTotal :next | subTotal + next]." | nextValue | nextValue _ thisValue. self do: [:each | nextValue _ binaryBlock value: nextValue value: each]. ^nextValue! reject: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to false. Answer the new collection." ^self select: [:element | (aBlock value: element) == false]! select: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to true. Answer the new collection." | newCollection | newCollection _ self species new. self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^newCollection! ! !Collection methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the collection. The general format for collections is Collection-name ( element element element ) unless there are a large number in which case the listing is truncated with the words ...etc..." | tooMany | tooMany _ aStream position + self maxPrint. aStream nextPutAll: self class name, ' ('. self do: [:element | aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self]. element printOn: aStream. aStream space]. aStream nextPut: $)! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an collection similar to the receiver. The general format for collections is ((class-name new) add: element; add: element; .... ; yourself)" | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new)'. noneYet _ true. self do: [:each | noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' add: '. aStream store: each]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !Collection methodsFor: 'converting'! asBag "Answer a new instance of Bag whose elements are the elements of the receiver." | aBag | aBag _ Bag new. self do: [:each | aBag add: each]. ^aBag! asOrderedCollection "Answer a new instance of OrderedCollection whose elements are the elements of the receiver. The order in which elements are added depends on the order in which the receiver enumerates its elements. In the case of unordered collections, the ordering is not necessarily the same for multiple requests for the conversion." | anOrderedCollection | anOrderedCollection _ OrderedCollection new: self size. self do: [:each | anOrderedCollection addLast: each]. ^anOrderedCollection! asSet "Answer a new instance of Set whose elements are the unique elements of the receiver." | aSet | aSet _ Set new: self size. self do: [:each | aSet add: each]. ^aSet! asSortedCollection "Answer a new instance of SortedCollection whose elements are the elements of the receiver. The sort order is the default less than or equal ordering." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. aSortedCollection addAll: self. ^aSortedCollection! asSortedCollection: aBlock "Answer a new instance of SortedCollection whose elements are the elements of the receiver. The sort order is defined by the argument, aBlock." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. aSortedCollection sortBlock: aBlock. aSortedCollection addAll: self. ^aSortedCollection! ! !Collection methodsFor: 'private'! emptyCheck "Provide an error notification if the collection is empty." self isEmpty ifTrue: [self errorEmptyCollection]! errorEmptyCollection "Answer an error notification because the collection is empty." self error: 'this collection is empty'! errorNoMatch "Answer an error notification because the collection sizes do not match." self error: 'collection sizes do not match'! errorNotFound "Answer an error notification because an object is not in the collection." self error: 'Object is not in the collection.'! errorNotKeyed "Answer an error notification because the collection does not respond to keyed accessing messages." self error: self class name, 's do not respond to keyed accessing messages.'! growSize "Answer an amount by which the receiver should grow to make room for more elements." ^self basicSize max: 2! maxPrint "Answer the maximum number of characters to print with printOn:." ^5000! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Collection class instanceVariableNames: ''! !Collection class methodsFor: 'instance creation'! with: anObject "Answer a new instance of a Collection containing anObject." | newCollection | newCollection _ self new. newCollection add: anObject. ^newCollection! with: firstObject with: secondObject "Answer a new instance of a Collection containing the two arguments as elements." | newCollection | newCollection _ self new. newCollection add: firstObject. newCollection add: secondObject. ^newCollection! with: firstObject with: secondObject with: thirdObject "Answer with a new instance of a Collection containing the three arguments as elements." | newCollection | newCollection _ self new. newCollection add: firstObject. newCollection add: secondObject. newCollection add: thirdObject. ^newCollection! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer a new instance of a Collection containing the four arguments as the elements." | newCollection | newCollection _ self new. newCollection add: firstObject. newCollection add: secondObject. newCollection add: thirdObject. newCollection add: fourthObject. ^newCollection! ! ByteArray variableByteSubclass: #CompiledMethod instanceVariableNames: '' classVariableNames: 'BytesForHeader BytesForSource BytesPerLiteral LargeFrame SmallFrame TempNameCache ' poolDictionaries: '' category: 'Kernel-Methods'! CompiledMethod comment: 'Class CompiledMethod represents a method suitable for interpretation by the virtual machine. Its instances have pointer fields, including a header and some literals, followed by non-pointer fields comprising the byte encoded instructions for the method. The header encodes the number of arguments, the number of literals, and the amount of temporary space needed (for context allocation). An extra three bytes are added after the executable code. These contain an external file address to the source code for the method. Instance Variables: *byte indexed* Class Variables: BytesForHeader size of a header BytesPerLiteral size of one literal LargeFrame SmallFrame Context range for temps+stack SpecialConstants TempNameCache of the receiver with a list of temporary names'! !CompiledMethod methodsFor: 'initialize-release'! needsStack: newStackSize encoder: encoder "If newStackSize does not fit in the receiver, then the receiver becomes a method with large stack." (self numTemps + newStackSize + 1) > SmallFrame ifTrue: [(self numTemps + newStackSize + 1) > LargeFrame ifTrue: [^self error: 'Stack (including temps) is too deep']. self objectAt: 1 put: (self header bitOr: 64) "setLargeStack"]! ! !CompiledMethod methodsFor: 'accessing'! endPC "Answer the index of the last bytecode." ^self size - BytesForSource! flags "Answer the 3-bit number that indicates the number of arguments the receiver takes and whether it is associated with a primitive." ^(self header bitShift: -12) bitAnd: 7! frameSize | small | "Answer the size of temporary frame needed to run the receiver." small _ self header noMask: 64. small ifTrue: [^SmallFrame] ifFalse: [^LargeFrame]! initialPC "Answer the program counter for the receiver's first bytecode." ^self numLiterals * BytesPerLiteral + BytesForHeader + 1! numArgs "Answer the number of arguments the receiver takes." | flags | (flags _ self flags) <= 4 ifTrue: [^flags]. flags < 7 ifTrue: [^0]. ^((self literalAt: self numLiterals - 1) bitShift: -8) bitAnd: 31! numLiterals "Answer the number of literals used by the receiver." | header | self isQuick ifTrue: [^0]. header _ self header. ^(header bitAnd: 63) == 63 ifTrue: [(header bitShift: -15) bitAnd: 255] ifFalse: [header bitAnd: 63]! numStack "Answer the size of the available stack." self isQuick ifTrue: [^0] "The method was simply a return of self or instance variable." ifFalse: [^self frameSize - self numTemps]! numTemps "Answer the number of temporary variables used by the receiver." self isQuick ifTrue: [^0] ifFalse: [^self numTempsField]! numTempsField "Answer the 5-bit number that indicates the number of temporary variables the receiver uses." ^self header // 128 bitAnd: 31! primitive "Answer the primitive index associated with the receiver. Zero indicates that there is either no primitive or just a quick primitive." | header prim | self flags < 7 ifTrue: [^0] ifFalse: [header _self literalAt: self numLiterals - 1. prim _ header bitAnd: 255. ^(header bitAnd: 16r2000) == 0 ifTrue: [prim] ifFalse: [0 - prim]]! returnField "Answer the index of the instance variable returned by a quick return method." self flags ~= 6 ifTrue: [self error: 'only meaningful for quick-return'] ifFalse: [^self numTempsField]! ! !CompiledMethod methodsFor: 'testing'! isQuick "Answer whether the receiver is a quick return (of self or of an instance variable)." ^self flags between: 5 and: 6! isReturnField "Answer whether the receiver is a quick return of an instance variable." ^self flags = 6! isReturnSelf "Answer whether the receiver is a quick return of self." ^self flags = 5! needsLargeFrame ^self header allMask: 64! ! !CompiledMethod methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." "Overrides method inherited from the byte arrayed collection" aStream nextPutAll: 'a CompiledMethod'! storeOn: aStream "Append to the argument aStream a description of a CompiledMethod like that of the receiver. The general format is ((class-name) newMethod: aSize header: aHeader) sequence-of-elements-in-the-form-at:put:; literalAt: index put: element; yourself) " | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' newMethod: '. aStream store: self size - self initialPC + 1. aStream nextPutAll: ' header: '. aStream store: self header. aStream nextPut: $). noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream. 1 to: self numLiterals do: [:index | noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' literalAt: '. aStream store: index. aStream nextPutAll: ' put: '. aStream store: (self literalAt: index)]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! symbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each." | aStream | self isQuick ifTrue: [self isReturnSelf ifTrue: [^'Quick return self']. ^'Quick return field ' , self returnField printString , ' (0-based)']. aStream _ WriteStream on: (String new: 1000). self primitive > 0 ifTrue: [aStream nextPutAll: '. aStream cr]. (InstructionPrinter on: self) printInstructionsOn: aStream. ^aStream contents! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." Smalltalk allBehaviorsDo: [:class | class selectors do: [:sel | (class compiledMethodAt: sel) == self ifTrue: [^Array with: class with: sel]]]! ! !CompiledMethod methodsFor: 'literals'! header "Answer the word containing the information about the form of the receiver and the form of the context needed to run the receiver." ^self objectAt: 1! literalAt: index "Answer the literal indexed by the argument." ^self objectAt: index + 1! literalAt: index put: value "Replace the literal indexed by the first argument with the second argument." ^self objectAt: index + 1 put: value! literals "Answer with an array of the literals referenced by the receiver." | literals numberLiterals index | literals _ Array new: (numberLiterals _ self numLiterals). index _ 0. [(index _ index + 1) <= numberLiterals] whileTrue: [literals at: index put: (self objectAt: index + 1)]. ^literals! objectAt: index "Answer with the method header (if index=1) or a literal (if index >1) from the receiver. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! objectAt: index put: value "Store the value argument into a literal in the receiver. An index of 2 corresponds to the first literal. Fails if the index is less than 2 or greater than the number of literals. Answer with the value as the result. Normally only the compiler sends this message, because only the compiler stores values in CompiledMethods. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! refersToLiteral: literal "Answer whether the receiver references the argument, literal. The last literal, if used for super, will not cause a true answer" | flags header numLiteralsPlus1 index | "numLiteralsPlus1 _ self numLiterals + 1. -- expanded for speed" header _ self objectAt: 1. flags _ (header bitShift: -12) bitAnd: 7. (flags = 6 or: [flags = 5]) ifTrue: [^ false]. (numLiteralsPlus1 _ (header bitAnd: 63) + 1) == 64 ifTrue: [ numLiteralsPlus1 _ ((header bitShift: -15) bitAnd: 255) + 1]. index _ 1. [(index _ index + 1) <= numLiteralsPlus1] whileTrue: [literal == (self objectAt: index) ifTrue: [index < numLiteralsPlus1 ifTrue: [^ true]. "slow check for last literal which might just be super" ^ (literal isMemberOf: Association) not or: [(self readsRef: literal) or: [self writesRef: literal]]]]. ^ false! ! !CompiledMethod methodsFor: 'scanning'! fieldsTouched "Answer a Set of fields touched by this method." | scanner aSet | self isReturnField ifTrue: [^ Set with: self returnField + 1]. self isReturnSelf ifTrue: [^ Set new]. aSet _ Set new. scanner _ InstructionStream on: self. scanner scanFor: [:x | scanner addFieldIndexTo: aSet. false "keep scanning"]. ^aSet! messages "Answer a Set of all the message selectors sent by this method." | scanner aSet | aSet _ Set new. scanner _ InstructionStream on: self. scanner scanFor: [:x | scanner addSelectorTo: aSet. false "keep scanning"]. ^aSet! readsField: varIndex "Answer whether the receiver loads the instance variable indexed by the argument." self isReturnField ifTrue: [^self returnField + 1 = varIndex]. varIndex <= 16 ifTrue: [^self scanFor: varIndex - 1]. ^self scanLongLoad: varIndex - 1! readsRef: literalAssociation "Answer whether the receiver loads the argument." | lit | lit _ self literals indexOf: literalAssociation ifAbsent: [^false]. lit <= 32 ifTrue: [^self scanFor: 64 + lit - 1]. ^self scanLongLoad: 192 + lit - 1! scanFor: byte "Answer whether the receiver contains the argument as a bytecode." ^(InstructionStream on: self) scanFor: [:instr | instr = byte]! scanLongLoad: extension "Answer whether the receiver contains a long load whose extension is the argument." | scanner | scanner _ InstructionStream on: self. ^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! scanLongStore: extension "Answer whether the receiver contains a long store whose extension is the argument." | scanner | scanner _ InstructionStream on: self. ^scanner scanFor: [:instr | (instr between: 129 and: 130) and: [scanner followingByte = extension]]! writesField: field "Answer whether the receiver stores into the instance variable indexed by the argument." self isQuick ifTrue: [^false]. (field <= 8 and: [self scanFor: 96 + field - 1]) ifTrue: [^true] ifFalse: [^self scanLongStore: field - 1]! writesRef: ref "Answer whether the receiver stores the argument." | lit | lit _ self literals indexOf: ref ifAbsent: [^false]. ^self scanLongStore: 192 + lit - 1! ! !CompiledMethod methodsFor: 'source code management'! cacheTempNames: names TempNameCache _ Association key: self value: names! fileIndex "Answer 1 if the source code of the receiver is on the *.sources file and 2 if it is on the *.changes file." (self last between: 120 and: 124) ifTrue: [self error: 'Somehow a method does not have a file index.']. ^self last // 64 + 1! getSource "Answer the source code for the receiver. Answer nil if there are no source files specified in the global SourceFiles." | end highByte position source rs | SourceFiles == nil ifTrue: [^nil]. Cursor read showWhile: [rs _ self getSourceRemoteString. rs position = 0 ifTrue: [source _ nil] ifFalse: [source _ rs string]]. ^source! getSourcePosition | end position index | end _ self size. index _ 0. position _ (self at: end) bitAnd: 63. [(index _ index + 1) < BytesForSource] whileTrue: [position _ position * 256 + (self at: end - index)]. ^position! getSourceRemoteString "Answer a RemoteString pointing to the source code for the receiver." | end highByte position source | end _ self size. highByte _ self at: end. position _ self getSourcePosition. ^RemoteString newFileNumber: (highByte bitShift: -6) + 1 position: position! putSource: sourceStr class: class category: catName inFile: fileIndex "Print an expression that is a message to the argument, class, asking the class to accept the source code, sourceStr, as a method in category, catName. This is part of the format for writing descriptions of methods on files. If no sources are specified, i.e., SourceFile is nil, then do nothing. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes." | file remoteString | SourceFiles == nil ifTrue: [^self]. file _ SourceFiles at: fileIndex. file setToEnd; readWriteShorten. class printCategoryChunk: catName on: file. file cr. remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. file nextChunkPut: ' '; readOnly. self setSourcePosition: remoteString position inFile: fileIndex! putSource: sourceStr inFile: fileIndex "Store the source code for the receiver on an external file. If no sources are specified, i.e., SourceFile is nil, then do nothing. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes." | file remoteString | SourceFiles == nil ifTrue: [^self]. file _ SourceFiles at: fileIndex. file setToEnd; readWriteShorten. file cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr. remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. file nextChunkPut: ' '; readOnly. self setSourcePosition: remoteString position inFile: fileIndex! setSourcePosition: aRemoteString ^self setSourcePosition: aRemoteString position inFile: aRemoteString sourceFileNumber! setSourcePosition: position inFile: fileIndex "Store the location of the source code for the receiver in the receiver. The location consists of which source file (*.sources or *.changes) and the position in that file." | index hiByte restOfPosition | "set last BytesForSource bytes to be position in file (1-4)" fileIndex > 4 ifTrue: [^self error: 'invalid file number']. hiByte _ position bitShift: 8 - (BytesForSource*8). "get himost byte of the position" hiByte > 62 ifTrue: [Transcript show: 'Source file is getting full!!!!'; cr]. self at: self size put: (fileIndex - 1 * 64 + hiByte). "last byte is hi byte with file index on top" restOfPosition _ position. BytesForSource - 1 to: 1 by: -1 do: [:i | self at: self size - i put: (restOfPosition bitAnd: 255). restOfPosition _ restOfPosition bitShift: -8]! setTempNamesIfCached: aBlock TempNameCache == nil ifTrue: [^self]. TempNameCache key == self ifTrue: [aBlock value: TempNameCache value]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompiledMethod class instanceVariableNames: ''! !CompiledMethod class methodsFor: 'class initialization'! initialize "Initialize class variables specifying the size of the temporary frame needed to run instances of me, and the size of my instances' header and literals (which may be system-dependent.)" "CompiledMethod initialize." SmallFrame _ 12. "Context range for temps+stack" LargeFrame _ 32. BytesForHeader _ (self newMethod: 0 header: 0) size. "Just a header, no literals" BytesPerLiteral _ (self newMethod: 0 header: 1) size - BytesForHeader. "1 literal" BytesForSource _ 4. "Number of bytes to store source pointer"! ! !CompiledMethod class methodsFor: 'instance creation'! newBytes: numberOfBytes flags: flags nTemps: numberTemps nStack: stackSpace nLits: numberLiterals "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." | numLiterals largeLiterals | numberLiterals >= 63 ifTrue: [largeLiterals _ numberLiterals. numLiterals _ 63] ifFalse: [largeLiterals _ 0. numLiterals _ numberLiterals]. ^self newMethod: numberOfBytes header: (largeLiterals bitShift: 15) + (flags bitShift: 12) + (numberTemps bitShift: 7) + (numberTemps + stackSpace > SmallFrame ifTrue: [64] ifFalse: [0]) + numLiterals! newMethod: numberOfBytes header: headerWord "Answer with an instance of the receiver. The number of literals (and other information) is specified by the headerWord. The first argument specifies the number of fields for bytecodes in the method. Fail if either argument is not a SmallInteger or if numberOfBytes is negative. Once the header of a method is set by this primitive, it cannot be changed in any way. Essential. See Object documentation whatIsAPrimitive." ^self primitiveFailed! toReturnField: field "Answer an instance of me that is a quick return of the instance variable indexed by the argument, field." ^self newBytes: BytesForSource flags: 6 nTemps: field nStack: 0 nLits: 0! toReturnSelf "Answer an instance of me that is a quick return of the instance (^self)." ^self newBytes: BytesForSource flags: 5 nTemps: 0 nStack: 0 nLits: 0! ! !CompiledMethod class methodsFor: 'constants'! bytesForSource ^BytesForSource! bytesPerLiteral ^BytesPerLiteral! ! CompiledMethod initialize! Object subclass: #Compiler instanceVariableNames: 'sourceStream requestor class context ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! Compiler comment: 'The compiler accepts Smalltalk source code from sourceStream, and compiles it in the context of a given class. The debugger supplies a context as well, so that temporary variables are accessible. If there is an error, the requestor (usually a CodeController) is sent the message notify:at:in:. If not, then the result of compilation is a parse tree (made up of subinstances of ParseNode) whose root is a MethodNode. The parse tree can then generate code in a CompiledMethod (for compile or evaluate), or prettyPrint the code (for format), or produce a map from object code back to source code (used by debugger pc selection). See also Parser, Encoder, ParseNode.'! !Compiler methodsFor: 'error handling'! editor ^ requestor! notify: aString at: position Cursor normal show. requestor == nil ifTrue: [^SyntaxError errorInClass: class withCode: (sourceStream contents copyReplaceFrom: position to: position - 1 with: aString) errorString: aString] ifFalse: [^ requestor insertAndSelect: aString at: (position max: 1)]! ! !Compiler methodsFor: 'public access'! compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock "Answer with a parse tree whose root is a MethodNode. This can then be told to generate code as is done in the calls from Behavior" self from: textOrStream class: aClass context: nil notifying: aRequestor. ^self translate: sourceStream noPattern: false ifFail: failBlock! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock "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 | Cursor execute show. 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. context == nil ifTrue: [class addSelector: #DoIt withMethod: method. value _ receiver DoIt. class removeSelectorSimply: #DoIt. Cursor normal show. ^value] ifFalse: [class addSelector: #DoItIn: withMethod: method. value _ receiver DoItIn: context. class removeSelectorSimply: #DoItIn:. Cursor normal show. ^value]! format: textOrStream in: aClass notifying: aRequestor "Compile a parse tree from the incoming text, and then print the parse tree to yield the answer, a string containing the original code in standard format." | aNode | self from: textOrStream class: aClass context: nil notifying: aRequestor. aNode _ self format: sourceStream noPattern: false ifFail: [^nil]. ^aNode decompileString! parse: textOrStream in: aClass notifying: req "Compile the incoming text and answer with the resulting parse tree." self from: textOrStream class: aClass context: nil notifying: req. ^self translate: sourceStream noPattern: false ifFail: []! ! !Compiler methodsFor: 'private'! format: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ class parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: self ifFail: [^failBlock value]. ^tree! from: textOrStream class: aClass context: aContext notifying: req (textOrStream isKindOf: PositionableStream) ifTrue: [sourceStream _ textOrStream] ifFalse: [sourceStream _ ReadStream on: textOrStream asString]. class _ aClass. context _ aContext. requestor _ req! translate: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ class parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: self ifFail: [^failBlock value]. ^tree! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Compiler class instanceVariableNames: ''! !Compiler class methodsFor: 'evaluating'! evaluate: textOrString ^self evaluate: textOrString for: nil logged: false! evaluate: textOrString for: anObject logged: logFlag ^ self evaluate: textOrString for: anObject notifying: nil logged: logFlag! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the supplied text (see message to instance for details). If both were successful then, if logFlag is true, log (write) the text onto the changes file so that it can be replayed if necessary." | val | val _ self new evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil]. logFlag ifTrue: [Smalltalk logChange: textOrString]. ^val! evaluate: textOrString logged: logFlag ^self evaluate: textOrString for: nil logged: logFlag! evaluate: textOrString notifying: aController logged: logFlag ^self evaluate: textOrString for: nil notifying: aController logged: logFlag! ! !Compiler class methodsFor: 'accessing'! preferredParserClass "Return a parser class which is appropriate for parsing methods compilable by this compiler class. Should be overwritten by subclasses." ^Parser! ! CharacterScanner subclass: #CompositionScanner instanceVariableNames: 'spaceX spaceIndex ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! CompositionScanner comment: 'Instances of class CompositionScanner hold the state of CharacterScanner in addition to the following required only for composition. CompositionScanners are used to measure text and determine where line breaks and space padding should occur. Instance Variables: spaceX Left edge of last space scanned. When line overflows this value is substracted from the rightMargin to determine how much padding is available for justification, centering, etc. spaceIndex Character index of last space scanned in line. Installed as stop in the TextLineInterval for the line being composed. '! !CompositionScanner methodsFor: 'initialize-release'! in: aParagraph "Initialize the paragraph to be scanned as the argument, aParagraph. Set the composition frame for the paragraph." super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle! ! !CompositionScanner methodsFor: 'accessing'! rightX "Meaningful only when a line has just been composed -- refers to the line most recently composed." "This is a trick to allow for easy resizing of a composition rectangle to the width of the maximum line. Useful only when there is only one line in the form or when each line is terminated by a carriage return. Handy for sizing menus and lists." ^spaceX! ! !CompositionScanner methodsFor: 'scanning'! composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | lastIndex _ startIndex. "scanning sets last index" self setStopConditions. "also sets font" spaceX _ destX _ leftMargin _ (aParagraph leftMarginForCompositionForLine: lineIndex). rightMargin _ aParagraph rightMarginForComposition. leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose']. runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ TextLineInterval start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions displaying: false. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [^line]]! ! !CompositionScanner methodsFor: 'stop conditions'! cr "Answer true. Sets up values for the text line interval currently being composed." line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - destX. ^true! crossedX "There is a word that has fallen across the right edge of the composition rectangle. This signals the need for wrapping which is done to the last space that was encountered, as recorded by the space stop condition." line stop: spaceIndex. spaceCount > 1 ifTrue: ["The common case. First back off the space at which we wrap." spaceCount _ spaceCount - 1. spaceIndex _ spaceIndex - 1. ["Check to see if any spaces preceding the one at which we wrap. Double space after a period, most likely." (spaceCount > 1 and: [(text at: spaceIndex) = Space])] whileTrue: [spaceCount _ spaceCount - 1. spaceIndex _ spaceIndex - 1. "Account for backing over a run which might change width of space." font _ self resetFont. spaceX _ spaceX - (font widthOf: Space)]. line paddingWidth: rightMargin - spaceX. line internalSpaces: spaceCount] ifFalse: [spaceCount = 1 ifTrue: ["wrap at space, but no internal spaces" line internalSpaces: 0. line paddingWidth: rightMargin - spaceX] ifFalse: ["Neither internal nor trailing spaces, almost never happen, she says confidently." lastIndex _ lastIndex - 1. [destX <= rightMargin] whileFalse: [destX _ destX - (font widthOf: (text at: lastIndex)). "bug --doesn't account for backing over run and changing actual width of characters. Also doesn't account for backing over a tab. Happens only when no spaces in line, presumably rare." lastIndex _ lastIndex - 1]. spaceX _ destX. line paddingWidth: rightMargin - destX. lastIndex < line first ifTrue: [line stop: line first] ifFalse: [line stop: lastIndex]]]. ^true! endOfRun "Answer true if scanning has reached the end of the paragraph. Otherwise set stop conditions (mostly install potential new font) and answer false." | runLength | lastIndex = text size ifTrue: [line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - destX. ^true] ifFalse: [runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). runStopIndex _ lastIndex + (runLength - 1). self setStopConditions. ^false]! onePixelBackspace "Decrement destX by 1. " destX _ (destX - 1) max: leftMargin. lastIndex _ lastIndex + 1. ^false! onePixelSpace "Increment destX by 1. " destX _ destX+1. lastIndex _ lastIndex + 1. destX > rightMargin ifTrue: [^self crossedX]. ^false! setStopConditions "Set the font and the stop conditions for the current run." font _ textStyle fontAt: (text emphasisAt: lastIndex). super setStopConditions.! space "Note that the left x and character index of the space character just encountered. Used for wrap-around. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." spaceX _ destX. destX _ spaceX + spaceWidth. lastIndex _ (spaceIndex _ lastIndex) + 1. spaceCount _ spaceCount + 1. destX > rightMargin ifTrue: [^self crossedX]. ^false! tab "Advance destination x according to tab settings in the paragraph's textStyle. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph. Scale allows use of same code for display and printing composition." destX _ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. destX > rightMargin ifTrue: [^self crossedX]. lastIndex _ lastIndex + 1. ^false! ! !CompositionScanner methodsFor: 'private'! resetFont "Mainly to allow the stop condition crossedX to be shared by display and printer media." ^ textStyle fontAt: (text emphasisAt: spaceIndex)! ! Inspector subclass: #ContextInspector instanceVariableNames: 'tempNames ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Inspector'! ContextInspector comment: 'I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context. Instance Variables: contextCode the method whose activation is being inspected tempNames of Strings, each the name of a temporary variable. '! !ContextInspector methodsFor: 'field list'! fieldIndex ^ tempNames indexOf: field! fieldList object == nil ifTrue: [^nil]. ^(tempNames _ object tempNames)! fieldMenu field == nil ifTrue: [^ nil]. ^ActionMenu labels: 'inspect' selectors: #(inspectField)! fieldValue field = 'self' ifTrue: [^ object receiver]. ^ object tempAt: self fieldIndex! ! !ContextInspector methodsFor: 'doIt/accept'! acceptText: aText from: aController | val | (field == nil) | (field = 'self') ifTrue: [^ false]. val _ self evaluateText: aText string from: aController ifFail: [^ false]. object tempAt: self fieldIndex put: val. self changed: #text. ^ true! doItContext ^object! doItReceiver ^object receiver! ! !ContextInspector methodsFor: 'initialization'! inspect: anObject object _ anObject. self changed: #field! ! InstructionStream subclass: #ContextPart instanceVariableNames: 'stackp ' classVariableNames: 'TryPrimitiveMethods ' poolDictionaries: '' category: 'Kernel-Methods'! ContextPart comment: 'To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in my subclasses indexable fields, which store temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "simulator", which exactly parallels the operation of the Smalltalk machine itself. Instance Variable: stackp indicating the offset of the top of my temporary value stack Class Variable: TryPrimitiveMethods of methods. The methods (from class Object) that are cached in tryPrimitiveMethods are used by the simulator to catch failures when simulating primitives. '! !ContextPart methodsFor: 'accessing'! home "Answer the context in which the receiver was defined." self subclassResponsibility! method self subclassResponsibility! receiver "Answer the receiver of the message that created this context." self subclassResponsibility! sourceCode "Answer the source form of the receiver's method." | mclass selector method | method _ self method. selector _ self receiver class selectorAtMethod: method setClass: [:mc | mclass _ mc]. ^ mclass sourceCodeForMethod: method at: selector! ! !ContextPart methodsFor: 'temporaries'! tempAt: index "Answer the value of the temporary variable whose index is the argument, index." self subclassResponsibility! tempAt: index put: value "Store the argument, value, as the temporary variable whose index is the argument, index." self subclassResponsibility! tempNames "Answer an OrderedCollection of the names of the receiver's temporary variables, which are strings." | names | self method setTempNamesIfCached: [:cachedNames | ^cachedNames]. names _ (self mclass compilerClass new parse: self sourceCode in: self mclass notifying: nil) tempNames. self method cacheTempNames: names. ^names! ! !ContextPart methodsFor: 'instruction decoding'! doDup "Simulates the action of a 'duplicate top of stack' bytecode." self push: self top! doPop "Simulates the action of a 'remove top of stack' bytecode." self pop! jump: distance "Simulates the action of a 'unconditional jump' bytecode whose offset is the argument, distance." pc _ pc + distance! jump: distance if: condition "Simulates the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." (self pop eqv: condition) ifTrue: [self jump: distance]! methodReturnConstant: value "Simulates the action of a 'return constant' bytecode whose value is the argument, value. This corresponds to a source expression like '^0'." ^self return: value to: self home sender! methodReturnReceiver "Simulates the action of a 'return receiver' bytecode. This corresponds to the source expression '^self'." ^self return: self receiver to: self home sender! methodReturnTop "Simulates the action of a 'return top of stack' bytecode. This corresponds to source expressions like '^something'." ^self return: self pop to: self home sender! popIntoLiteralVariable: value "Simulates the action of bytecode that removes the top of the stack and stores it into a literal variable of my method." value value: self pop! popIntoReceiverVariable: offset "Simulates the action of bytecode that removes the top of the stack and stores it into an instance variable of my receiver." self receiver instVarAt: offset + 1 put: self pop! popIntoTemporaryVariable: offset "Simulates the action of bytecode that removes the top of the stack and stores it into one of my temporary variables." self home at: offset + 1 put: self pop! pushActiveContext "Simulates the action of bytecode that pushes the the active context on the top of its own stack." self push: self! pushConstant: value "Simulates the action of bytecode that pushes the constant, value, on the top of the stack." self push: value! pushLiteralVariable: value "Simulates the action of bytecode that pushes the contents of the literal variable whose index is the argument, index, on the top of the stack." self push: value value! pushReceiver "Simulates the action of bytecode that pushes the the active context's receiver on the top of the stack." self push: self receiver! pushReceiverVariable: offset "Simulates the action of bytecode that pushes the contents of the receiver's instance variable whose index is the argument, index, on the top of the stack." self push: (self receiver instVarAt: offset + 1)! pushTemporaryVariable: offset "Simulates the action of bytecode that pushes the contents of the temporary variable whose index is the argument, index, on the top of the stack." self push: (self home at: offset + 1)! send: selector super: superFlag numArgs: numArgs "Simulates the action of bytecodes that send a message with selector, selector. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method. The arguments of the message are found in the top numArgs locations on the stack and the receiver just below them." | receiver arguments | arguments _ OrderedCollection new. numArgs timesRepeat: [arguments addFirst: self pop]. receiver _ self pop. (selector == #halt or: [selector == #halt:]) ifTrue: [self error: 'Cant simulate halt. Proceed to bypass it.'. self push: nil. ^self]. ^self send: selector to: receiver with: arguments super: superFlag! storeIntoLiteralVariable: value "Simulates the action of bytecode that stores the top of the stack into a literal variable of my method." value value: self top! storeIntoReceiverVariable: offset "Simulates the action of bytecode that stores the top of the stack into an instance variable of my receiver." self receiver instVarAt: offset + 1 put: self top! storeIntoTemporaryVariable: offset "Simulates the action of bytecode that stores the top of the stack into one of my temporary variables." self home at: offset + 1 put: self top! ! !ContextPart methodsFor: 'debugger access'! depthBelow: aContext "Answer how many calls between this and aContext." | this depth | this _ self. depth _ 0. [this == aContext or: [this == nil]] whileFalse: [this _ this sender. depth _ depth + 1]. ^depth! hasSender: context "Answer true if the receiver is strictly above context on the stack." | s | self == context ifTrue: [^false]. s _ sender. [s == nil] whileFalse: [s == context ifTrue: [^true]. s _ s sender]. ^false! mclass "Answer the class in which the receiver's method was found." | mclass | self receiver class selectorAtMethod: self method setClass: [:mc | mclass _ mc]. ^mclass! pc "Answer the index of the next bytecode to be executed." ^pc! release "Remove information from the receiver and all of the contexts on its sender chain in order to break circularities." self releaseTo: nil! releaseTo: caller "Remove information from the receiver and the contexts on its sender chain up to caller in order to break circularities." | c s | c _ self. [c == nil or: [c == caller]] whileFalse: [s _ c sender. c singleRelease. c _ s]! selector "Answer the selector of the method that created the receiver." ^self receiver class selectorAtMethod: self method setClass: [:ignored]! sender "Answer the context that sent the message that created the receiver." ^sender! shortStack "Answer a string showing the top five contexts on my sender chain." | shortStackStream | shortStackStream _ WriteStream on: (String new: 400). (self stackOfSize: 5) do: [:item | shortStackStream print: item; cr]. ^shortStackStream contents! singleRelease "Remove information from the receiver in order to break circularities." stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. sender _ nil! stack "Answer an array of the contexts on the receiver's sender chain." ^self stackOfSize: 9999! stackOfSize: limit "Answer an array of the top 'limit' contexts on the receiver's sender chain." | a stack | stack _ OrderedCollection new: 100. stack addLast: (a _ self). [(a _ a sender) ~~ nil and: [stack size < limit]] whileTrue: [stack addLast: a]. ^ stack! swapSender: coroutine "Replace the receiver's sender with coroutine and answer the receiver's previous sender. For use in coroutining." | oldSender | oldSender _ sender. sender _ coroutine. ^oldSender! ! !ContextPart methodsFor: 'controlling'! activateMethod: newMethod withArgs: args receiver: rcvr class: class "Answer a new context initialized with the arguments." ^MethodContext sender: self receiver: rcvr method: newMethod arguments: args! blockCopy: numArgs "Distinguish a block of code from its enclosing method by creating a new BlockContext for that block. The compiler inserts into all methods that contain blocks the bytecodes to send the message blockCopy:. Do not use blockCopy: in code that you write!! Only the compiler can decide to send the message blockCopy:. Fail if numArgs is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^(BlockContext new: self size) home: self home startpc: pc + 2 nargs: numArgs! pop "Answer the top of the receiver's stack and remove the top of the stack." | val | val _ self at: stackp. self at: stackp put: nil. stackp _ stackp - 1. ^val! push: val "Push val on the receiver's stack." self at: (stackp _ stackp + 1) put: val! return: value to: sendr "Simulate the return of value to sendr." self releaseTo: sendr. ^sendr push: value! send: selector to: rcvr with: args super: superFlag "Simulates the action of sending a message with selector, selector, and arguments, args, to receiver. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method." | class meth val | class _ superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [rcvr class]. [class == nil] whileFalse: [(class includesSelector: selector) ifTrue: [meth _ class compiledMethodAt: selector. val _ self tryPrimitiveFor: meth receiver: rcvr args: args. val == #primitiveFail ifFalse: [^val]. ^self activateMethod: meth withArgs: args receiver: rcvr class: class]. class _ class superclass]. self error: 'Simulated message ' , selector , ' not understood'! top "Answer the top of the receiver's stack." ^self at: stackp! ! !ContextPart methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." | mclass selector class | selector _ (class _ self receiver class) selectorAtMethod: self method setClass: [:mc | mclass _ mc]. selector == #? ifTrue: [aStream nextPut: $?; print: self method who. ^self]. aStream nextPutAll: class name. mclass == class ifFalse: [aStream nextPut: $(. aStream nextPutAll: mclass name. aStream nextPut: $)]. aStream nextPutAll: '>>'. aStream nextPutAll: selector! ! !ContextPart methodsFor: 'system simulation'! completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | ctxt current | self class initPrimitives. ctxt _ aContext. current _ nil. [ctxt == current or: [ctxt hasSender: self]] whileTrue: [current _ ctxt. ctxt _ ctxt step]. self stepToSendOrReturn! runSimulated: aBlock contextAtEachStep: block2 "Simulate the execution of aBlock until it ends. aBlock MUST NOT contain an ^. Evaluate block2 with current context prior each instruction executed. Answer with the simulated value of aBlock." | current | aBlock hasMethodReturn ifTrue: [self error: 'simulation of blocks with ^ can run loose']. self class initPrimitives. current _ aBlock. current pushArgs: Array new from: self. [current == self] whileFalse: [block2 value: current. current _ current step]. ^self pop! step "Simulate the execution of the receiver's next bytecode. Answer the context that would be the active context after this bytecode." ^self interpretNextInstructionFor: self! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." [self willSend | self willReturn] whileFalse: [self step]! ! !ContextPart methodsFor: 'private'! doPrimitive: primitiveIndex receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message." | numberArguments primitiveMethod value header | "If successful, push result and return resuming context, else ^#primitiveFail" (primitiveIndex = 80 and: [receiver isKindOf: ContextPart]) ifTrue: [^self push: ((BlockContext new: receiver size) home: receiver home startpc: pc + 2 nargs: arguments first)]. (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext]) ifTrue: [^receiver pushArgs: arguments from: self]. primitiveIndex = 83 ifTrue: [^self send: arguments first to: receiver with: (arguments copyFrom: 2 to: arguments size) super: false]. numberArguments _ arguments size. numberArguments > 4 ifTrue: [^#primitiveFail]. "currently fails text primitive" primitiveMethod _ TryPrimitiveMethods at: numberArguments + 1. primitiveMethod literalAt: 2 put: ((primitiveMethod literalAt: 2) bitAnd: -256) + primitiveIndex abs. header _ primitiveMethod literalAt: 2. primitiveIndex < 0 ifTrue: [ header _ header bitOr: 16r2000 ] ifFalse: [ header _ header bitAnd: 16r2000 bitInvert ]. primitiveMethod literalAt: 2 put: header. "Instead of 100 such messages in Object" Class flushCache. "in case interp caches primitive #" numberArguments = 0 ifTrue: [value _ receiver tryPrimitive0]. numberArguments = 1 ifTrue: [value _ receiver tryPrimitive1: (arguments at: 1)]. numberArguments = 2 ifTrue: [value _ receiver tryPrimitive2: (arguments at: 1) with: (arguments at: 2)]. numberArguments = 3 ifTrue: [value _ receiver tryPrimitive3: (arguments at: 1) with: (arguments at: 2) with: (arguments at: 3)]. numberArguments = 4 ifTrue: [value _ receiver tryPrimitive4: (arguments at: 1) with: (arguments at: 2) with: (arguments at: 3) with: (arguments at: 4)]. numberArguments > 4 ifTrue: [self error: 'too many arguments to this primitive']. value == #primitiveFail ifTrue: [^value] ifFalse: [^self push: value]! tryPrimitiveFor: method receiver: receiver args: arguments "Simulate a primitive method, method for the receiver and arguments given as arguments to this message. Answer resuming the context if successful, else answer the symbol, #primitiveFail." | flag primIndex | (flag _ method flags) < 5 ifTrue: [^#primitiveFail]. flag = 5 ifTrue: [^self push: receiver]. flag = 6 ifTrue: [^self push: (receiver instVarAt: method numTempsField + 1)]. flag = 7 ifTrue: [(primIndex _ method primitive) = 0 ifTrue: [^#primitiveFail]. ^self doPrimitive: primIndex receiver: receiver args: arguments]! ! !ContextPart methodsFor: 'errors'! cannotReturn self error: 'Context cannot return.'. ^nil! unusedBytecode self error: 'Unused Bytecode'. ^nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ContextPart class instanceVariableNames: ''! !ContextPart class methodsFor: 'class initialization'! initPrimitives "The methods (from class Object) that are cached in tryPrimitiveMethods are used by the simulator to catch failures when simulating primitives" | method | TryPrimitiveMethods _ #(tryPrimitive0 tryPrimitive1: tryPrimitive2:with: tryPrimitive3:with:with: tryPrimitive4:with:with:with: ) collect: [:sel | method _ Object compiledMethodAt: sel. method numLiterals = 3 ifFalse: [self error: 'doPrimitive assumes 3']. method]! ! !ContextPart class methodsFor: 'examples'! runSimulated: aBlock "The simulator is a group of methods in class ContextPart which do what the Smalltalk interpreter does. They execute Smalltalk bytecodes. By adding code to the simulator, you could take statistics on the running of Smalltalk methods. See also trace: callStatistics: and instructionStatistics: for sample uses." "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]" ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:ignored]! tallyInstructions: aBlock "This method uses the simulator to count the number of occurrences of each of the Smalltalk instructions executed during evaluation of aBlock. Results appear in order of the byteCode set." "ContextPart tallyInstructions: [3.14159 printString]." | tallies | tallies _ Bag new. thisContext sender runSimulated: aBlock contextAtEachStep: [:current | tallies add: current nextByte]. ^tallies sortedElements! tallyMethods: aBlock "This method uses the simulator to count the number of calls on each method invoked in evaluating aBlock. Results are given in order of decreasing counts." "ContextPart tallyMethods: [3.14159 printString]." | prev tallies | tallies _ Bag new. prev _ aBlock. thisContext sender runSimulated: aBlock contextAtEachStep: [:current | current == prev ifFalse: "call or return" [prev sender == nil ifFalse: "call only" [tallies add: current printString]. prev _ current]]. ^tallies sortedCounts! trace: aBlock "This method uses the simulator to print calls and returned values in the Transcript." "ContextPart trace: [3 factorial]" | prev | prev _ aBlock. ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:current | current == prev ifFalse: [prev sender == nil ifTrue: "returning" [Transcript space; nextPut: $^; print: current top]. Transcript cr; nextPutAll: (String new: (current depthBelow: aBlock) withAll: $ ); print: current receiver; space; nextPutAll: current selector; endEntry. prev _ current]]! ! Object subclass: #Controller instanceVariableNames: 'model view sensor ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Framework'! Controller comment: 'A Controller coordinates a view, its model, and user actions. Instance Variables: model view sensor '! !Controller methodsFor: 'initialize-release'! initialize "Initializes the state of the receiver. Subclasses should include 'super initialize' when redefining this message to insure proper initialization." sensor _ InputSensor default! release "Breaks the cycle between the receiver and its view. It is usually not necessary to send release provided the receiver's view has been properly released independently." super release. view ~= nil ifTrue: [view controller: nil. view _ nil]! ! !Controller methodsFor: 'model access'! model "Answer the receiver's model which is the same as the model of the receiver's view." ^model! model: aModel "Controller|model: and Controller|view: are sent by View|controller: in order to coordinate the links between the model, view, and controller. In ordinary usage, the receiver is created and passed as the parameter to View|controller: so that the receiver's model and view links can be set up by the view." model _ aModel! ! !Controller methodsFor: 'view access'! view "Answer the receiver's view." ^view! view: aView "Controller|view: and Controller|model: are sent by View|controller: in order to coordinate the links between the model, view, and controller. In ordinary usage, the receiver is created and passed as the parameter to View|controller: and the receiver's model and view links are set up automatically by the view." view _ aView! ! !Controller methodsFor: 'sensor access'! sensor "Answer the receiver's sensor. Subclasses may use other objects that are not instances of Sensor or its subclasses if more general kinds of input/output functions are required." ^sensor! sensor: aSensor "Set the receiver's sensor to aSensor." sensor _ aSensor! ! !Controller methodsFor: 'basic control sequence'! controlInitialize "Sent by Controller|startUp as part of the standard control sequence. It provides a place in the standard control sequence for initializing the receiver (taking into account the current state of its model and view). It should be redefined in subclasses to perform some specific action." ^self! controlLoop "Sent by Controller|startUp as part of the standard control sequence. Controller|controlLoop sends the message Controller|isControlActive to test for loop termination. As long as true is returned, the loop continues. When false is returned, the loop ends. Each time through the loop, the message Controller|controlActivity is sent." [self isControlActive] whileTrue: [Processor yield. self controlActivity]! controlTerminate "Provide a place in the standard control sequence for terminating the receiver (taking into account the current state of its model and view). It should be redefined in subclasses to perform some specific action." ^self! startUp "Give control to the receiver. The default control sequence is to initialize (see Controller|controlInitialize), to loop (see Controller|controlLoop), and then to terminate (see Controller|controlTerminate). After this sequence, control is returned to the sender of Control|startUp. The receiver's control sequence is used to coordinate the interaction of its view and model. In general, this consists of polling the sensor for user input, testing the input with respect to the current display of the view, and updating the model to reflect intended changes." self controlInitialize. self controlLoop. self controlTerminate! ! !Controller methodsFor: 'control defaults'! controlActivity "Pass control to the next control level (that is, to the Controller of a subView of the receiver's view) if possible. It is sent by Controller|controlLoop each time through the main control loop. It should be redefined in a subclass if some other action is needed." self controlToNextLevel! controlToNextLevel "Pass control to the next control level, that is, to the Controller of a subView of the receiver's view if possible. The receiver finds the subView (if any) whose controller wants control and sends that controller the message startUp." | aView | aView _ view subViewWantingControl. aView ~~ nil ifTrue: [aView controller startUp]! isControlActive "Answer whether the receiver wants control. The default is to take control if the cursor is inside the view and the blue button is not pressed. Pressing blue button a default to explicitly give up control without moving the cursor. It is sent by Controller|controlLoop in order to determine when the receiver's control loop should terminate, and should be redefined in a subclass if some other condition for terminating the main control loop is needed." ^(view containsPoint: sensor cursorPoint) & sensor blueButtonPressed not! isControlWanted "Answer true if the cursor is inside the inset display box (see View|insetDisplayBox) of the receiver's view, and answer false, otherwise. It is sent by Controller|controlNextLevel in order to determine whether or not control should be passed to this receiver from the Controller of the superView of this receiver's view." ^self viewHasCursor! ! !Controller methodsFor: 'cursor'! centerCursorInView "Position sensor's mousePoint (which is assumed to be connected to the cursor) to the center of its view's inset display box (see Sensor|mousePoint: and View|insetDisplayBox)." ^sensor cursorPoint: view insetDisplayBox center! viewHasCursor "Answer true if the cursor point of the receiver's sensor lies within the inset display box of the receiver's view (see View|insetDisplayBox), and answer false, otherwise. Controller|viewHasCursor is normally used in internal methods." ^view containsPoint: sensor cursorPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Controller class instanceVariableNames: ''! !Controller class methodsFor: 'instance creation'! new ^super new initialize! ! Object subclass: #ControlManager instanceVariableNames: 'scheduledControllers activeController activeControllerProcess screenController ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Framework'! ControlManager comment: 'Class ControlManager represents the top level control over scheduling which controller of a view on the screen the user is actively using. ScheduledControllers is the global reference to an instance of ControlManager, the one attached to the Project currently being used. Instance Variables: scheduledControllers of Controllers, usually ScheduledControllers activeController usually a ScheduledController activeControllerProcess screenController also appears in ScheduledControllers '! !ControlManager methodsFor: 'initialize-release'! initialize "Initialize the receiver to refer to only the background controller." | screenView | screenController _ ScreenController new. screenView _ FormView new. screenView model: (InfiniteForm with: Form gray) controller: screenController. screenView window: Display boundingBox. scheduledControllers _ OrderedCollection with: screenController! release scheduledControllers == nil ifFalse: [scheduledControllers do: [:controller | (controller isKindOf: Controller) ifTrue: [controller view release] ifFalse: [controller release]]. scheduledControllers _ nil]! ! !ControlManager methodsFor: 'accessing'! activeController "Answer the currently active controller." ^activeController! activeController: aController "Set aController to be the currently active controller. Give the user control in it." activeController _ aController. self promote: activeController. activeControllerProcess _ [activeController startUp. self searchForActiveController] newProcess. activeControllerProcess priority: Processor userSchedulingPriority. activeControllerProcess resume! activeController: aController andProcess: aProcess "Set aController to be the currently active controller and aProcess to be the the process that is handles controller scheduling activities in the system." self inActiveControllerProcess ifTrue: [aController~~nil ifTrue: [(scheduledControllers includes: aController) ifTrue: [self promote: aController] ifFalse: [self error: 'Old controller not scheduled']]. activeController controlTerminate. activeController _ aController. activeController == nil ifFalse: [activeController controlInitialize]. activeControllerProcess _ aProcess. activeControllerProcess resume] ifFalse: [self error: 'New active controller process must be set from old one']! activeControllerNoTerminate: aController andProcess: aProcess "Set aController to be the currently active controller and aProcess to be the the process that handles controller scheduling activities in the system. This message differs from activeController:andProcess: in that it does not send controlTerminate to the currently active controller." self inActiveControllerProcess ifTrue: [aController~~nil ifTrue: [(scheduledControllers includes: aController) ifTrue: [self promote: aController] ifFalse: [self error: 'Old controller not scheduled']]. activeController _ aController. activeController == nil ifFalse: [activeController controlInitialize]. activeControllerProcess _ aProcess. activeControllerProcess resume] ifFalse: [self error: 'New active controller process must be set from old one']! activeControllerProcess "Answer the process that is currently handling controller scheduling activities in the system." ^activeControllerProcess! adjustForNewDisplayExtent "Modify the background window so that it occupies the whole host window, even if Display has not yet been resized" screenController view window: (0@0 extent: DisplayScreen screenExtent)! hasNewDisplayExtent "Determine whether the host window has been resized" ^DisplayScreen screenExtent ~= Display extent! isScheduled: aController ^scheduledControllers includes: aController! scheduledControllers "Answer a copy of the ordered collection of scheduled controllers." ^scheduledControllers copy! ! !ControlManager methodsFor: 'scheduling'! inActiveControllerProcess "Answer whether the active scheduling process is the actual active process in the system." ^activeControllerProcess == Processor activeProcess! interruptName: title "Create a Notifier on the active scheduling process whose label is title Make the Notifier the active controller." | newActiveController suspendingList | suspendingList _ activeControllerProcess suspendingList. suspendingList isNil ifTrue: [activeControllerProcess==Processor activeProcess ifTrue: [activeControllerProcess suspend]] ifFalse: [suspendingList remove: activeControllerProcess. activeControllerProcess offList]. ScrollController haltScrollBar. activeController ~~ nil ifTrue: [activeController controlTerminate]. newActiveController _ (NotifierView openInterrupt: title onProcess: activeControllerProcess) controller. newActiveController centerCursorInView. self activeController: newActiveController! promote: aController "Make aController be the first scheduled controller in the ordered collection." scheduledControllers remove: aController. scheduledControllers addFirst: aController! promoteToSecond: aController "Make aController be the first scheduled controller in the ordered collection." scheduledControllers remove: aController. scheduledControllers add: aController after: scheduledControllers first! pullBottomToTop "Make the last scheduled view which wants control be the first one. Used for implementing the message under to a scheduled controller." scheduledControllers reverseDo: [:controller | (controller isControlWanted and: [controller ~~ screenController]) ifTrue: [^scheduledControllers addFirst: (scheduledControllers remove: controller)]]! scheduleActive: aController "Make aController be scheduled as the active controller. Presumably the active scheduling process asked to schedule this controller and that a new process associated this controller takes control. So this is the last act of the active scheduling process." Cursor normal show. self scheduleActiveNoTerminate: aController. Processor terminateActive! scheduleActiveNoTerminate: aController "Make aController be the active controller. Presumably the process that requested the new active controller wants to keep control to do more activites before the new controller can take control. Therefore, do not terminate the currently active process." self schedulePassive: aController. self scheduled: aController from: Processor activeProcess! scheduleOnBottom: aController "Make aController be scheduled as a scheduled controller, but not the active one. Put it at the end of the ordered collection of controllers." scheduledControllers addLast: aController! schedulePassive: aController "Make aController be scheduled as a scheduled controller, but not the active one. Put it at the beginning of the ordered collection of controllers." scheduledControllers addFirst: aController! searchForActiveController "Find a scheduled controller that wants control and give control to it. If none wants control, then see if the System Menu has been requested." | newController | activeController _ nil. activeControllerProcess _ Processor activeProcess. [Processor yield. newController _ scheduledControllers detect: [:aController | aController isControlWanted and: [aController ~~ screenController]] ifNone: [screenController isControlWanted ifTrue: [screenController] ifFalse: [nil]]. newController isNil] whileTrue. self activeController: newController. Processor terminateActive! unschedule: aController "Remove the view, aController, from the collection of scheduled controllers." scheduledControllers remove: aController ifAbsent: []! ! !ControlManager methodsFor: 'displaying'! displaySafe: aBlock forController: aController | intersects | (scheduledControllers includes: aController) ifFalse: [^nil]. activeController == aController ifTrue: [^aBlock value]. activeController == nil ifTrue: [aController showOnDisplay. aBlock value. aController saveDisplayBits. ^self promote: aController]. (intersects _ activeController intersectsDisplayBoxOf: aController) ifTrue: [activeController saveDisplayBits]. aController showOnDisplay. aBlock value. aController saveDisplayBits. intersects ifTrue: [activeController showOnDisplay; flushDisplayBits]. self promoteToSecond: aController! restore "Redisplay all windows, resizing the Display if the window size has changed" | ns | self hasNewDisplayExtent ifTrue: [DisplayScreen resetExtent]. self redraw! ! !ControlManager methodsFor: 'restoring'! backgroundFormFor: aRectangle "this should return the background bits for aRectangle no matter what the background is" |backgroundBits background| backgroundBits _ Form extent: aRectangle extent. background _ screenController model. background class == InfiniteForm ifTrue: [background displayOn: backgroundBits at: 0 @ 0 clippingBox: backgroundBits boundingBox rule: Form over mask: Form black] ifFalse: [(background isKindOf: Form) ifTrue: [backgroundBits copyBits: aRectangle from: background at: 0 @ 0 clippingBox: backgroundBits boundingBox rule: Form over mask: nil] ifFalse: [backgroundBits gray]]. ^backgroundBits! restoreOn: aRegion for: aView | controller controllers regions indx hisRegion bits reg cache pt background| "Force to a display boundary that won't leave a white line." background _ screenController model. background class == InfiniteForm ifTrue: [pt _ background form extent. reg _ Rectangle origin: (aRegion origin - (pt - (1@1)) grid: pt) corner: aRegion corner] ifFalse: [reg _ aRegion]. "get the controllers that have views that intersect the view being erased" controllers _ OrderedCollection new: scheduledControllers size. regions _ OrderedCollection new: scheduledControllers size. indx _ 1. [indx <= scheduledControllers size] whileTrue: [controller _ scheduledControllers at: indx. ((controller ~= screenController and: [controller view ~= aView]) and: [(hisRegion _ controller view displayRegion) intersects: reg]) ifTrue: [controllers add: controller. regions add: hisRegion]. indx _ indx + 1]. "put the cached bits from intersecting views on the display with double buffering" bits _ self backgroundFormFor: reg. (controllers size to: 1 by: -1) do: [:i | controller _ controllers at: i. (cache _ controller labelForm) == nil ifFalse: [cache displayOn: bits at: controller view labelDisplayBox origin - reg origin]. (cache _ controller viewForm) == nil ifFalse: [cache displayOn: bits at: controller view displayBox origin - reg origin]]. "bits displayOn: Display at: reg origin" bits displayOn: Display at: reg origin clippingBox: aRegion rule: Form over mask: nil! saveActiveViewsBits activeController ~= nil ifTrue: [activeController saveDisplayBits]! ! !ControlManager methodsFor: 'backgrounds'! background: color "Set the background color." "ScheduledControllers background: Form lightGray." self backgroundForm: (InfiniteForm with: color)! backgroundForm: aDisplayObject "Set the background form by changing the screenController's model." "Display white. Pen new spiral: 1000 angle: 89; home; spiral: 1000 angle: -89. ScheduledControllers backgroundForm: (Form fromDisplay: Display boundingBox)." screenController view model: aDisplayObject. self restore! ! !ControlManager methodsFor: 'private'! deactivate self flushDisplayBits. activeController _ nil. activeControllerProcess _ nil! flushDisplayBits scheduledControllers do: [:aController | aController flushDisplayBits]! redraw "Redisplay all windows" | aPoint | aPoint _ 0@0. self unschedule: screenController. self scheduleOnBottom: screenController. screenController view window: Display boundingBox. scheduledControllers reverseDo: [:aController | aController view display; deEmphasize. (aController view viewport intersects: Display boundingBox) ifFalse: [(Display boundingBox containsPoint: (aPoint _ aPoint + (10@10))) ifFalse: [aPoint _ 10@10]. aController view moveTo: aPoint]. aController saveDisplayBits]. Cursor normal show! scheduled: aController from: aProcess activeControllerProcess==aProcess ifTrue: [activeController ~~ nil ifTrue: [activeController controlTerminate]. aController centerCursorInView. self activeController: aController] ifFalse: [aController view display]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ControlManager class instanceVariableNames: ''! !ControlManager class methodsFor: 'instance creation'! new ^super new initialize! ! !ControlManager class methodsFor: 'exchange'! newScheduler: controlManager "When switching projects, the control scheduler has to be exchanged. The active one is the one associated with the current project." ScheduledControllers deactivate. Smalltalk at: #ScheduledControllers put: controlManager. ScheduledControllers restore. controlManager searchForActiveController! ! FillInTheBlankController subclass: #CRFillInTheBlankController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Prompt/Confirm'! CRFillInTheBlankController comment: 'I am a FillInTheBlankController that causes termination on a carriage return.'! !CRFillInTheBlankController methodsFor: 'basic control sequence'! controlInitialize startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. self initializeSelection. beginTypeInBlock _ nil! ! !CRFillInTheBlankController methodsFor: 'stop conditions'! cr: characterStream key: aChar "The carriage return was typed by the user. This designates that the receiver should give up control." characterStream isEmpty ifFalse: [self replaceSelectionWith: (Text string: characterStream contents emphasis: emphasisHere)]. self accept. ^true! ! ExternalPort subclass: #CShellPort instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Terminal'! CShellPort comment: 'I am an external connection to the CShell.'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CShellPort class instanceVariableNames: ''! !CShellPort class methodsFor: 'instance creation'! open "Open a CShellPort" | port aCshNumber | port _ nil. aCshNumber _ 1. [port isNil] whileTrue: [port _ CShellPort open: aCshNumber. aCshNumber _ aCshNumber + 1. aCshNumber > 8 ifTrue: [^self error: 'Unable to open CShell port.']]. ^port! open: aCshNumber | newPort max | max _ self SerialMaxPortNumber. newPort _ self new setPortNumber: (max - aCshNumber) + 1. (newPort readStatus: 2) = 0 ifFalse: [^nil]. newPort open. ^newPort! ! Form subclass: #Cursor instanceVariableNames: 'name ' classVariableNames: 'BlankCursor BottomLeftCursor BullCursor CaretCursor CornerCursor CrossHairCursor CurrentCursor DownCursor GarbageCursor HandCursor MarkerCursor NormalCursor OriginCursor ReadCursor ScrollCursor SquareCursor ThumbsDownCursor ThumbsUpCursor TopRightCursor UpCursor WaitCursor WriteCursor XeqCursor ' poolDictionaries: '' category: 'Graphics-Display Objects'! Cursor comment: 'Instances of class Cursor are each represented as a 16 x 16 dot matrix suitable for use as the current cursor. Instance Variable: name providing a label for the cursor Class Variables: CurrentCursor the cursor that is currently being displayed on the screen The following are all the names of instances of class Cursor that are predefined in the system. They are accessible with messages to the class. BlankCursor BottomLeftCursor BullCursor CaretCursor CornerCursor CrossHairCursor DownCursor GarbageCursor HandCursor MarkerCursor NormalCursor OriginCursor ReadCursor ScrollCursor SquareCursor ThumbsDownCursor ThumbsUpCursor TopRightCursor UpCursor WaitCursor WriteCursor XeqCursor '! !Cursor methodsFor: 'updating'! changed: aParameter "Receiver changed. The change is denoted by the argument anAspectSymbol. Usually the argument is a Symbol that is part of the dependent's change protocol, that is, some aspect of the object's behavior. Inform all of the dependents." self == CurrentCursor ifTrue: [self beCursor]. super changed: aParameter! ! !Cursor methodsFor: 'displaying'! beCursor "Tell the interpreter to use the receiver as the current cursor image. Fail if the receiver does not match the size expected by the hardware. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! show "Make the current cursor shape be the receiver." Sensor currentCursor: self! showGridded: gridPoint "Make the current cursor shape be the receiver, forcing the location of cursor to the point nearest the point gridPoint." Sensor primCursorLocPut: ((Sensor cursorPoint grid: gridPoint) + self offset). Sensor currentCursor: self! showWhile: aBlock "While evaluating the argument, aBlock, make the receiver be the cursor shape." | oldcursor value | oldcursor _ Sensor currentCursor. self show. value _ aBlock value. oldcursor show. ^value! ! !Cursor methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." self storeOn: aStream base: 2! ! !Cursor methodsFor: 'name'! name "Answer the string labelling the receiver." ^name! name: aString "Make the argument aString, be the label for the receiver." name _ aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Cursor class instanceVariableNames: ''! !Cursor class methodsFor: 'class initialization'! initialize "Create all the standard cursors." "Cursor initialize." BlankCursor _ Cursor new. self initNormal. self initXeq. self initRead. self initWrite. self initUp. self initDown. self initMarker. self initScroll. self initOrigin. self initCorner. self initTopRight. self initBottomLeft. self initCrossHair. self initCaret. self initWait. self initGarbage. self initThumbsUp. self initThumbsDown. self initTopRight. self initBottomLeft. self initBull. self initHand.! ! !Cursor class methodsFor: 'instance creation'! extent: extentPoint fromArray: anArray offset: offsetPoint "Answer a new instance of the receiver with width and height specified by extentPoint, offset by offsetPoint, and bits from anArray. Provide an error notification if the extentPoint is not 16@16." extentPoint = (16 @ 16) ifTrue: [^super extent: extentPoint fromArray: anArray offset: offsetPoint] ifFalse: [self error: 'cursors must be 16@16']! extent: extentPoint fromArray: anArray offset: offsetPoint name: aString "Answer a new instance of the receiver with width and height specified by extentPoint, offset by offsetPoint, and bits from anArray. Provide an error notification if the extentPoint is not 16@16." extentPoint = (16 @ 16) ifTrue: [^(super extent: extentPoint fromArray: anArray offset: offsetPoint) name: aString] ifFalse: [self error: 'cursors must be 16@16']! new "Answer a new instance of the receiver that is a blank image." "Cursor new bitEdit." ^self extent: 16 @ 16 fromArray: Array new offset: 0 @ 0! ! !Cursor class methodsFor: 'current cursor'! currentCursor "Answer the instance of the receiver that is the one currently displayed." ^CurrentCursor! currentCursor: aCursor "Make the instance of Cursor, aCursor, be the current cursor. Display it. Provide an error notificaton if the argument is not a Cursor." aCursor class == self ifTrue: [CurrentCursor _ aCursor. aCursor beCursor] ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! cursorLink: boolean "Cause the cursor to track the pointing device location if the argument is true. Decouple the cursor from the pointing device if the argument is false. Essential. See Object documentation whatIsAPrimitive." ^self primitiveFailed! ! !Cursor class methodsFor: 'constants'! blank "Answer the instance of the receiver that is all white." ^BlankCursor! bottomLeft "Answer the instance of the receiver that is a bottom left corner." ^BottomLeftCursor! bull "Answer the instance of the receiver that is a bull's-eye." ^BullCursor! caret "Answer the instance of the receiver that is a caret." ^CaretCursor! corner "Answer the instance of the receiver that is the shape of the bottom right corner of a rectangle." ^CornerCursor! crossHair "Answer the instance of the receiver that is the shape of a cross." ^CrossHairCursor! down "Answer the instance of the receiver that is the shape of an arrow facing downward." ^DownCursor! execute "Answer the instance of the receiver that is the shape of an arrow slanted left with a star next to it." ^XeqCursor! garbage "Answer the instance of the receiver that is the shape of a garbage can with open lid." ^GarbageCursor! hand "Answer the instance of the receiver that is the shape of a hand." ^HandCursor! marker "Answer the instance of the receiver that is displayed when thumb-scrolling." ^MarkerCursor! normal "Answer the instance of the receiver that is the shape of an arrow slanted left." ^NormalCursor! origin "Answer the instance of the receiver that is the shape of the top left corner of a rectangle." ^OriginCursor! read "Answer the instance of the receiver that is the shape of eyeglasses." ^ReadCursor! scroll "Answer the instance of the receiver that is up and down arrows." ^ScrollCursor! square "Answer the instance of the receiver that is the shape of a square." ^SquareCursor! thumbsDown "Answer the instance of the receiver that is a thumbs down." ^ThumbsDownCursor! thumbsUp "Answer the instance of the receiver that is thumbs up." ^ThumbsUpCursor! topRight "Answer the instance of the receiver that is a top right corner." ^TopRightCursor! up "Answer the instance of the receiver that is the shape of an arrow facing upward." ^UpCursor! wait "Answer the instance of the receiver that is the shape of an hour glass." ^WaitCursor! write "Answer the instance of the receiver that is the shape of a pen writing." ^WriteCursor! ! !Cursor class methodsFor: 'constant initialization'! initBottomLeft BottomLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1111111111111111 2r1111111111111111) offset: -2@-2 name: 'bottomLeft')! initBull BullCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000011111000000 2r0001100100110000 2r0010000100001000 2r0100000100000100 2r0100000100000100 2r1000000100000010 2r1000000100000010 2r1111111111111110 2r1000000100000010 2r1000000100000010 2r0100000100000100 2r0100000100000100 2r0010000100001000 2r0001100100110010 2r0000011111000000) offset: -8@-9 name: 'bull').! initCaret CaretCursor _ (Cursor extent: 16@16 fromArray: #( 2r110000000 2r110000000 2r1111000000 2r11111100000 2r11001100000 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: -8@0 name: 'caret').! initCorner CornerCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r1111111111111111 2r1111111111111111) offset: -14@-14 name: 'corner')! initCrossHair CrossHairCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r1111111111111110 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0) offset: -7@-7 name: 'crossHair')! initDown DownCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r1111110000000000 2r0111110000000000 2r0011110000000000 2r0001110000000000 2r0000110000000000 2r0000010000000000) offset: -5@-7 name: 'down')! initGarbage GarbageCursor _ (Cursor extent: 16@16 fromArray: #( 2r111111100000 2r1000000011000 2r1000000000100 2r111111100100 2r1111111111000 2r1011111101000 2r1000000001000 2r1001001001000 2r1001001001000 2r1001001001000 2r1001001001000 2r1001001001000 2r1001001001000 2r1001001001000 2r100000010000 2r11111100000) offset: 0@0 name: 'garbage')! initHand HandCursor _ (Cursor extent: 16 @ 16 fromArray: #( 2r110000000 2r1101001110000 2r10011001001000 2r10011001001010 2r1001001001101 2r1001001001001 2r110100000001001 2r1001100000000001 2r1000100000000010 2r100000000000010 2r10000000000010 2r1000000000100 2r1000000000100 2r100000001000 2r10000001000 2r10000001000) offset: 0 @ 0 name: 'hand').! initMarker MarkerCursor _ (Cursor extent: 16@16 fromArray: #( 2r0 2r0 2r0 2r0000001000000000 2r0000001110000000 2r0000001111100000 2r1111111111111000 2r1111111111111110 2r1111111111111000 2r0000001111100000 2r0000001110000000 2r0000001000000000 2r0 2r0 2r0 2r0) offset: -7@-7 name: 'mark')! initNormal NormalCursor _ (Cursor extent: 16@16 fromArray: #( 2r1000000000000000 2r1100000000000000 2r1110000000000000 2r1111000000000000 2r1111100000000000 2r1111110000000000 2r1111111000000000 2r1111100000000000 2r1111100000000000 2r1001100000000000 2r0000110000000000 2r0000110000000000 2r0000011000000000 2r0000011000000000 2r0000001100000000 2r0000001100000000) offset: 0@0 name: 'normal')! initOrigin OriginCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: -2@-2 name: 'origin')! initRead ReadCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000110000000110 2r0001001000001001 2r0001001000001001 2r0010000000010000 2r0100000000100000 2r1111101111100000 2r1000010000100000 2r1000010000100000 2r1011010110100000 2r0111101111000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0 name: 'read')! initScroll ScrollCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000100000000000 2r0000110000000000 2r0000111000000000 2r0000111100000000 2r0000111110000000 2r0000111111000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r0000110000000000 2r1111110000000000 2r0111110000000000 2r0011110000000000 2r0001110000000000 2r0000110000000000 2r0000010000000000) offset: -5@-7 name: 'scroll')! initThumbsDown ThumbsDownCursor _ (Cursor extent: 16@16 fromArray: #( 2r111111110000 2r100000001000 2r1111100000111 2r10000000000000 2r11111100000000 2r10000000000000 2r11111100000000 2r10000000000000 2r1000010000011 2r111110001100 2r10001000 2r10001000 2r1111000 2r1001000 2r1101000 2r10000) offset: 0@0 name: 'thumbsDown').! initThumbsUp ThumbsUpCursor _ (Cursor extent: 16@16 fromArray: #( 2r10000 2r1101000 2r1001000 2r1111000 2r10001000 2r10001000 2r111110001100 2r1000010000011 2r10000000000000 2r11111100000000 2r10000000000000 2r11111100000000 2r10000000000000 2r1111100000111 2r100000001000 2r111111110000) offset: -15@0 name: 'thumbsUp').! initTopRight TopRightCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011) offset: -14@-14 name: 'topRight')! initUp UpCursor _ (Cursor extent: 16@16 fromArray: #( 2r1000000000000000 2r1100000000000000 2r1110000000000000 2r1111000000000000 2r1111100000000000 2r1111110000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: 0@-7 name: 'up')! initWait WaitCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1000000000000001 2r0100000000000010 2r0010000000000100 2r0001110000111000 2r0000111101110000 2r0000011011100000 2r0000001111000000 2r0000001111000000 2r0000010110100000 2r0000100010010000 2r0001000110001000 2r0010001101000100 2r0100111111110010 2r1011111111111101 2r1111111111111111) offset: 0@0 name: 'wait')! initWrite WriteCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000110 2r0000000000001111 2r0000000000010110 2r0000000000100100 2r0000000001001000 2r0000000010010000 2r0000000100100000 2r0000001001000011 2r0000010010000010 2r0000100100000110 2r0001001000001000 2r0010010000001000 2r0111100001001000 2r0101000010111000 2r0110000110000000 2r1111111100000000) offset: 0@0 name: 'write')! initXeq XeqCursor _ (Cursor extent: 16@16 fromArray: #( 2r1000000000010000 2r1100000000010000 2r1110000000111000 2r1111000111111111 2r1111100011000110 2r1111110001000100 2r1111111001111100 2r1111100001101100 2r1111100011000110 2r1001100010000010 2r0000110000000000 2r0000110000000000 2r0000011000000000 2r0000011000000000 2r0000001100000000 2r0000001100000000) offset: 0@0 name: 'xeq')! ! Cursor initialize! Path subclass: #Curve instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! Curve comment: 'Class Curve is a subclass of Path that is a conic section determined by: three points p1,p2 and p3 that interpolates p1 and p3 and is tangent to p1,p2 and p3,p2 at p1 and p3 respectively.'! !Curve methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Display the receiver on the display medium aDisplayMedium positioned at aDisplayPoint within the rectangle clipRectangle and with the rule, ruleInteger, and mask, aForm. " | pa pb k s p1 p2 p3 line | line _ Line new. line form: self form. collectionOfPoints size < 3 ifTrue: [self error: 'Curve must have three points']. p1 _ self firstPoint. p2 _ self secondPoint. p3 _ self thirdPoint. s _ Path new. s add: p1. pa _ p2 - p1. pb _ p3 - p2. k _ 5 max: pa x abs + pa y abs + pb x abs + pb y abs // 20. "k is a guess as to how many line segments to use to approximate the curve." 1 to: k do: [:i | s add: pa * i // k + p1 * (k - i) + (pb * (i - 1) // k + p2 * (i - 1)) // (k - 1)]. s add: p3. 1 to: s size - 1 do: [:i | line beginPoint: (s at: i). line endPoint: (s at: i + 1). line displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Curve class instanceVariableNames: ''! !Curve class methodsFor: 'instance creation'! new "Answer a new instance of the receiver that is essentially a single point at the upper left corner of the screen." | newSelf | newSelf _ super new: 3. newSelf add: 0@0. newSelf add: 0@0. newSelf add: 0@0. ^newSelf! ! !Curve class methodsFor: 'examples'! sampleCurve "Designate three locations on the screen by clicking any button. The curve determined by the points will be displayed with a long black form." "Curve sampleCurve." | aCurve aForm | aForm _ Form new extent: 1@30. "make a long thin Form for display " aForm black. "turn it black" aCurve _ Curve new. aCurve form: aForm. "set the form for display" "collect three Points and show them on the dispaly" aCurve firstPoint: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: aCurve firstPoint. aCurve secondPoint: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: aCurve secondPoint. aCurve thirdPoint: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: aCurve thirdPoint. aCurve displayOn: Display "display the Curve"! ! Magnitude subclass: #Date instanceVariableNames: 'day year ' classVariableNames: 'DaysInMonth FirstDayOfMonth MonthNames SecondsInDay WeekDayNames ' poolDictionaries: '' category: 'Numeric-Magnitudes'! Date comment: 'An instance of class Date represents a specific day since the start of the Julian calendar; a day exists in a particular month and year. Protocol provided for the object Date supports inquiries about dates in general as well as about a specific date. Instance Variables: day from 1 to 31 year typically after the year 1900 Class Variables: DaysInMonth of Integers of the number of days in each month FirstDayOfMonth of Integers of the day of the year that is the first day of each month MonthNames of Symbols representing the names of the 12 months SecondsInDay total number of seconds in a day WeekDayNames of Symbols representing the names of the 7 days in a week'! !Date methodsFor: 'comparing'! < aDate "Answer whether the argument, aDate, precedes the date of the receiver. " year = aDate year ifTrue: [^day < aDate day] ifFalse: [^year < aDate year]! = aDate "Answer whether the argument, aDate, is the same day as the receiver. " self species = aDate species ifTrue: [^day = aDate day & (year = aDate year)] ifFalse: [^false]! hash "Answer a SmallInteger unique to the receiver." ^(year hash bitShift: 3) bitXor: day! ! !Date methodsFor: 'accessing'! day "Answer the day of the year represented by the receiver." ^day! leap "Answer whether the receiver's year is a leap year." ^Date leapYear: year! monthIndex "Answer the index of the month in which the receiver falls." | leap firstDay | leap _ self leap. 12 to: 1 by: -1 do: [ :monthIndex | firstDay _ (FirstDayOfMonth at: monthIndex) + (monthIndex > 2 ifTrue: [leap] ifFalse: [0]). firstDay<= day ifTrue: [^monthIndex]]. self error: 'illegal month'! monthName "Answer the name of the month in which the receiver falls." ^MonthNames at: self monthIndex! weekday "Answer the name of the day of the week on which the receiver falls." ^WeekDayNames at: self weekdayIndex! year "Answer the year in which the receiver falls." ^year! ! !Date methodsFor: 'arithmetic'! addDays: dayCount "Answer a new Date that is dayCount more days than the receiver." ^Date newDay: day + dayCount year: year! subtractDate: aDate "Answer the number of days between the receiver and aDate." year = aDate year ifTrue: [^day - aDate day "take a shortcut"] ifFalse: [^self asDays - aDate asDays]! subtractDays: dayCount "Answer a new Date that is dayCount days before the receiver." ^Date newDay: day - dayCount year: year! ! !Date methodsFor: 'inquiries'! dayOfMonth "Answer which day of the month is represented by the receiver." ^day - (self firstDayOfMonthIndex: self monthIndex) + 1! daysInMonth "Answer the number of days in the month represented by the receiver." ^(DaysInMonth at: self monthIndex) + (self monthIndex = 2 ifTrue: [self leap] ifFalse: [0])! daysInYear "Answer the number of days in the year represented by the receiver." ^Date daysInYear: self year! daysLeftInYear "Answer the number of days in the year after the date of the receiver." ^self daysInYear - self day! firstDayOfMonth "Answer the index of the day of the year that is the first day of the receiver's month." ^self firstDayOfMonthIndex: self monthIndex! previous: dayName "Answer the previous date whose weekday name is dayName." ^self subtractDays: 7 + self weekdayIndex - (Date dayOfWeek: dayName) \\ 7! ! !Date methodsFor: 'converting'! asDays "Answer the number of days between January 1, 1901 and the receiver's day." | yearIndex | yearIndex _ year - 1901. ^yearIndex * 365 "elapsed years" + (yearIndex // 4) "ordinary leap years" + ((yearIndex + 300) // 400) "leap centuries, first one is 2000, i.e. yearIndex = 99" - (yearIndex // 100) "non-leap centuries" + day - 1! asSeconds "Answer the seconds between the time that 1901 began and the same time in the receiver's day." ^SecondsInDay * self asDays! ! !Date methodsFor: 'printing'! printFormat: formatArray "Answer a string description of the receiver. The argument formatArray is the print format, where 1-3 positions to print day, month, year respectively 4 character separator 5 month format (1 month #, 2 first 3 characters, 3 entire name) 6 year format (1 year #, 2 year # \\ 100) For example, the formatArray #(2 1 3 32 3 1 ) means print first the month, then the day, then the year; use a space as the separator (Ascii code 32); print entire name of the month; full year identification. Try Date today printFormat: #(2 1 3 32 3 1) Date today printFormat: #(1 2 3 45 2 2)" | aStream | aStream _ WriteStream on: (String new: 16). self printOn: aStream format: formatArray. ^aStream contents! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." self printOn: aStream format: #(1 2 3 32 3 1 )! printOn: aStream format: formatArray "Print a description of the receiver on aStream. The argument formatArray is the print format, where 1-3 positions to print day, month, year respectively 4 character separator 5 month format (1 month #, 2 first 3 chars, 3 entire name) 6 year format (1 year #, 2 year # \\ 100) See also the comment for printFormat:" | monthIndex element monthFormat | monthIndex _ self monthIndex. 1 to: 3 do: [:elementIndex | element _ formatArray at: elementIndex. element = 1 ifTrue: [day - self firstDayOfMonth + 1 printOn: aStream]. element = 2 ifTrue: [monthFormat _ formatArray at: 5. monthFormat = 1 ifTrue: [monthIndex printOn: aStream]. monthFormat = 2 ifTrue: [aStream nextPutAll: ((MonthNames at: monthIndex) copyFrom: 1 to: 3)]. monthFormat = 3 ifTrue: [aStream nextPutAll: (MonthNames at: monthIndex)]]. element = 3 ifTrue: [(formatArray at: 6) = 1 ifTrue: [year printOn: aStream] ifFalse: [(year \\ 100) printOn: aStream]]. elementIndex < 3 ifTrue: [(formatArray at: 4) ~= 0 ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]]! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a Date similar to the receiver. The form is ( class-name readFromString: datePrintString)" aStream nextPutAll: '(', self class name, ' readFromString: '; print: self printString; nextPut: $)! ! !Date methodsFor: 'private'! day: dayInteger year: yearInteger "Initialize the instance variables." day _ dayInteger. year _ yearInteger! firstDayOfMonthIndex: monthIndex "Answer the day of the year (an Integer) that is the first day of the receiver's month." ^(FirstDayOfMonth at: monthIndex) + (monthIndex > 2 ifTrue: [self leap] ifFalse: [0])! weekdayIndex "Sunday=1, ... , Saturday=7" ^(self asDays + 1) \\ 7 + 1 "1 January 1901 was a Monday"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Date class instanceVariableNames: ''! !Date class methodsFor: 'class initialization'! initialize "Initialize class variables representing the names of the months and days and the number of seconds, days in each month, and first day of each month. " "Date initialize." MonthNames _ #(January February March April May June July August September October November December ). SecondsInDay _ 24 * 60 * 60. DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31 ). FirstDayOfMonth _ #(1 32 60 91 121 152 182 213 244 274 305 335 ). WeekDayNames _ #(Monday Tuesday Wednesday Thursday Friday Saturday Sunday )! ! !Date class methodsFor: 'instance creation'! fromDays: dayCount "Answer with an instance of Date that is dayCount days since1901 began." | aDate correction | aDate _ self newDay: 1 + (dayCount truncated rem: 1461) "There are 1461 days in a 4-year cycle. This doesn't handle leap-centuries quite right: we fix this up below." year: 1901 + ((dayCount truncated quo: 1461) * 4). "Now correct for leap-centuries." correction _ dayCount - aDate asDays. ^correction = 0 ifTrue: [aDate] ifFalse: [aDate addDays: correction]! newDay: day month: monthName year: year "Answer with an instance of Date which is the day'th day of the month named monthName in the year'th year. The year may be specified as the actual number of years since the beginning of the Roman calendar or the number of years since the beginning of the century." | monthIndex daysInMonth firstDayOfMonth | year < 100 ifTrue: [^self newDay: day month: monthName year: 1900 + year]. monthIndex _ self indexOfMonth: monthName. monthIndex = 2 ifTrue: [daysInMonth _ (DaysInMonth at: monthIndex) + (self leapYear: year)] ifFalse: [daysInMonth _ DaysInMonth at: monthIndex]. monthIndex > 2 ifTrue: [firstDayOfMonth _ (FirstDayOfMonth at: monthIndex) + (self leapYear: year)] ifFalse: [firstDayOfMonth _ FirstDayOfMonth at: monthIndex]. (day < 1 or: [day > daysInMonth]) ifTrue: [self error: 'illegal day in month'] ifFalse: [^self new day: day - 1 + firstDayOfMonth year: year]! newDay: dayCount year: referenceYear "Answer with a Date which is dayCount days after the beginning of the year referenceYear." | day year daysInYear | day _ dayCount. year _ referenceYear. [day > (daysInYear _ self daysInYear: year)] whileTrue: [year _ year + 1. day _ day - daysInYear]. [day <= 0] whileTrue: [year _ year - 1. day _ day + (self daysInYear: year)]. ^self new day: day year: year! readFrom: aStream "Answer a Date read from the argument aStream in any of the forms: (5 April 1982; 5-APR-82) (April 5, 1982) (4/5/82)" "Date readFrom: (ReadStream on: '5APR82')" | day month | aStream peek isDigit ifTrue: [day _ Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: "number/name... or name..." [month _ WriteStream on: (String new: 10). [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. month _ month contents. day isNil ifTrue: "name/number..." [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. day _ Integer readFrom: aStream]] ifFalse: "number/number..." [month _ Date nameOfMonth: day. day _ Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. ^self newDay: day month: month year: (Integer readFrom: aStream)! today "Answer the Date representing the day and year right now." ^self dateAndTimeNow at: 1! ! !Date class methodsFor: 'general inquiries'! dateAndTimeNow "Answer an Array with first element Date today and second element Time now." ^Time dateAndTimeNow! dayOfWeek: dayName "Answer the index in a week, 1 - 7, of the day named dayName. Provide an error notification if no such day exists." 1 to: 7 do: [:index | (WeekDayNames at: index) = dayName ifTrue: [^index \\ 7]]. self error: dayName asString , ' is not a day of the week'! daysInMonth: monthName forYear: yearInteger "Answer the number of days in the month named monthName in the year yearInteger." ^(self newDay: 1 month: monthName year: yearInteger) daysInMonth! daysInYear: yearInteger "Answer the number of days in the year, yearInteger." ^365 + (self leapYear: yearInteger)! indexOfMonth: monthName "Answer the index, 1 - 12, of the month monthName. Three letters as well as full month names are accepted; upper or lower case okay. Provide an error notification if no such month exists." "Examples are Date indexOfMonth: #May Date indexOfMonth: #aug " 1 to: 12 do: [ :index | (monthName , '*' match: (MonthNames at: index)) ifTrue: [^index]]. 1 to: 12 do: [ :index | (monthName , '*' match: ((MonthNames at: index) copyFrom: 1 to: 3)) ifTrue: [^index]]. self error: monthName , ' is not a recognized month name'! leapYear: yearInteger "Answer 1 if the year yearInteger is a leap year; answer 0 if it is not. " (yearInteger \\ 4 ~= 0 or: [yearInteger \\ 100 = 0 and: [yearInteger \\ 400 ~= 0]]) ifTrue: [^0] ifFalse: [^1]! nameOfDay: dayIndex "Answer a symbol representing the name of the day indexed by dayIndex, 1 - 7." ^WeekDayNames at: dayIndex! nameOfMonth: monthIndex "Answer a symbol representing the name of the month indexed by monthIndex, 1 - 12." ^MonthNames at: monthIndex! ! Date initialize! Browser subclass: #Debugger instanceVariableNames: 'context receiverInspector contextInspector shortStack sourceMap sourceCode processHandle ' classVariableNames: 'ContextMenu HighlightPC ' poolDictionaries: '' category: 'Interface-Debugger'! Debugger comment: 'The debugger allows browsing among the stack of contexts of a suspended process. In addition to viewing the source code at each level, the debugger supports inspection (and change) of temporary and instance variables in each context. Instance Variables: context the currently viewed context receiverInspector on instance variables in the current context contextInspector on temporary variables in the current context shortStack true if only a short portion of the stack is being shown sourceMap of associations (pc -> range) tempNames , cached names of the temporary variables processHandle holding onto the observed process'! !Debugger methodsFor: 'initialize-release'! process: aProcess context: aContext interrupted: aBoolean sourceCode _ nil. shortStack _ true. processHandle _ ProcessHandle on: aProcess at: aContext interrupted: aBoolean! release processHandle terminate. context _ nil. receiverInspector _ nil. contextInspector _ nil. super release! ! !Debugger methodsFor: 'accessing'! interruptedContext "Answer the suspended context of the interrupted process." ^processHandle topContext! selectedClass ^ context == nil ifTrue: [nil] ifFalse: [context mclass]! ! !Debugger methodsFor: 'menu messages'! correct: aNotifierController "Attempt to correct the spelling of the not-understood message and resend." | oldSelector oldFirst oldArgs selectors guess score bestScore | processHandle topContext selector == #doesNotUnderstand: ifFalse: [^ aNotifierController view flash]. oldSelector _ (processHandle topContext tempAt: 1) selector. oldFirst _ oldSelector first. oldArgs _ oldSelector numArgs. selectors _ processHandle topContext receiver class allSelectors select: [:sel | sel first = oldFirst and: [sel numArgs = oldArgs]]. bestScore _ 0. selectors do: [:sel | (score _ sel spellAgainst: oldSelector) > bestScore ifTrue: [bestScore _ score. guess _ sel]]. (self confirm: 'retry with selector: ', guess) ifFalse: [^ aNotifierController view flash]. processHandle topContext tempAt: 1 put: (Message selector: guess arguments: (processHandle topContext tempAt: 1) arguments). ^ self proceed! fullStack "Expand the stack to include all contexts, rather than the first few." shortStack _ false. self changed: #context! proceed "Proceed from the interrupted state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." self checkContextSelection. (context ~= processHandle topContext) | (processHandle interrupted not) ifTrue: [context push: processHandle proceedValue]. self resumeProcess! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." self checkContextSelection. self revertBlock ifFalse: [^self]. context restart. self resumeProcess! spawnEdits: aText from: aController "Open a method browser with aController for the code controller." | newController | context == nil ifTrue: [aController view flash "cant spawn changes when deselected"] ifFalse: [newController _ aController copy. "Copy gets the changes" aController cancel; controlTerminate. "Cancel changes in spawning browser" BrowserView openMethodBrowserOn: self copy withController: newController]! ! !Debugger methodsFor: 'pc selection'! computeSourceMap "Compute the sourceMap for PC selection in the current code." | methodNode | methodNode _ self selectedClass compilerClass new parse: sourceCode in: self selectedClass notifying: nil. sourceMap _ methodNode sourceMap. context method cacheTempNames: methodNode tempNames! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i pc end | (HighlightPC and: [context ~~ nil]) ifFalse: [^1 to: 0]. (sourceMap == nil or: [sourceMap size = 0]) ifTrue: [^1 to: 0]. pc_ context pc - ((context == processHandle topContext and: [processHandle interrupted]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'inspectors'! contextInspector ^contextInspector! openInspectors "Further initialization when opening notify view to debug view" receiverInspector _ Inspector inspect: nil. contextInspector _ ContextInspector inspect: nil. self changed: #contextList! receiverInspector ^receiverInspector! updateInspectors receiverInspector update. contextInspector update! ! !Debugger methodsFor: 'doIt/accept/explain'! acceptText: aText from: aController "Recompile the method of the selected context." | newSelector classOfMethod newMethod | context == nil ifTrue: [^ false]. self revertBlock ifFalse: [^ false]. classOfMethod _ context mclass. newSelector _ classOfMethod parserClass new parseSelector: aText. newSelector ~~ selector ifTrue: [self notify: 'selector must not change']. Cursor execute showWhile: [newSelector _ classOfMethod compile: aText classified: ClassOrganizer defaultProtocol notifying: aController]. newSelector == nil ifTrue: [^ false]. Cursor execute showWhile: ["**have to handle newMethod needing big stack!!" newMethod _ classOfMethod compiledMethodAt: newSelector. sourceCode _ aText string. newMethod isQuick ifTrue: "If compiled quick, we need a non-quick version to put in the context." [newMethod _ (classOfMethod compilerClass new parse: sourceCode in: classOfMethod notifying: nil) generateNoQuick]. newMethod frameSize > context size ifTrue: "This could be handled by allocating another bigger context, but you would have to inform processHandle of change in stack." [self notify: 'The new method requires more frame space than the old. You MUST not restart or proceed in this context. Other debugging, and restarting other methods is OK. You may proceed from this notification']. context restartWith: newMethod. self computeSourceMap. "Should get cached in CompiledMethod-class like tempNames" self resetContext: context]. ^ true! doItContext "Answer the context in which a text selection can be evaluated." ^ context! doItReceiver "Answer the receiver in which to evaluate code pane doIts." context == nil ifTrue: [^ nil]. ^ context receiver! doItValue: anObject "Set the value to be returned when the interrupted process proceeds." processHandle proceedValue: anObject! ! !Debugger methodsFor: 'stack manipulation'! checkContextSelection context == nil ifTrue: [context _ processHandle topContext]! resetContext: aContext "Used when a new context becomes top-of-stack, for instance when the method of the selected context is re-compiled, or the simulator steps or returns to a new method." processHandle topContext: aContext. self changed: #context. context == aContext ifFalse: "old ctxt not in new stack" [self context: aContext. self changed: #context]! resumeProcess processHandle topContext: context. processHandle resumeProcess! revertBlock "If the selected context is a block, then revert to its home." (context isKindOf: MethodContext) ifFalse: [(self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self context: context home. ^ true] ifFalse: [^ false]]. ^ true! send "The top context on the stack must be selected. This being so, either some message is about to be sent in that context, or that context is about to return. Send is only effective in the former case. It will cause the next message to be sent. The send is actually simulated, so that the debugger will regain control at the beginning of the method which is invokedi (unless it is a primitive). In this way, you can step your way deeper into a computation" self checkContextSelection. processHandle interrupted ifFalse: [processHandle topContext push: processHandle proceedValue]. processHandle interrupted: true. "simulation leaves same state as interrupting" context stepToSendOrReturn. (context ~~ processHandle topContext) | context willReturn ifFalse: [self resetContext: context step. context stepToSendOrReturn]! step "Some context is selected (force top if none). When this is so, either some message is about to be sent in that context, or that context is about to return. Step will cause the next message to be sent or the return to be executed. In either case, the debugger regains control so that you can step your way down through a method, and out to the caller when it returns. Note that the execution invoked by step is actually simulated, so it will run much slower than normal" | currentContext | self checkContextSelection. processHandle interrupted ifFalse: [processHandle topContext push: processHandle proceedValue]. processHandle interrupted: true. "simulation leaves same state as interrupting" context == processHandle topContext ifTrue: [currentContext _ context. currentContext stepToSendOrReturn. currentContext willReturn ifTrue: [currentContext _ currentContext step. currentContext stepToSendOrReturn. self resetContext: currentContext] ifFalse: [currentContext completeCallee: currentContext step. self changed: #pc. self updateInspectors]] ifFalse: ["Have to complete any stuff called from here" context completeCallee: processHandle topContext. self resetContext: context]! ! !Debugger methodsFor: 'contextList'! context ^ context! context: aContext | oldContext class | oldContext _ context. context _ aContext. context == nil ifTrue: [contextInspector inspect: nil. receiverInspector inspect: nil. self changed: #text. ^ self]. class _ context receiver class. meta _ class isMeta. meta ifTrue: [className _ class soleInstance name] ifFalse: [className _ class name]. selector _ context selector. (oldContext == nil or: [oldContext method ~~ context method]) ifTrue: [sourceCode _ context sourceCode. self computeSourceMap. "will compute tempNames" self changed: #text]. receiverInspector inspect: context receiver. contextInspector inspect: context. self changed: #pc! contextList shortStack ifTrue: [^ processHandle topContext stackOfSize: 9] ifFalse: [^ processHandle topContext stack]! contextMenu "Debugger flushMenus" context == nil ifTrue: [^ ActionMenu labels: 'full stack\proceed' withCRs selectors: #(fullStack proceed)]. ContextMenu == nil ifTrue: [ContextMenu _ ActionMenu labels: 'full stack\proceed\restart\senders\implementors\messages\step\send' withCRs lines: #(3 6) selectors: #(fullStack proceed restart browseSenders browseImplementors browseMessages step send)]. ^ ContextMenu! ! !Debugger methodsFor: 'text'! text context == nil ifTrue: [^ Text new]. ^ sourceCode asText makeSelectorBoldIn: self selectedClass! ! !Debugger methodsFor: 'dependents access'! removeDependent: aDependent super removeDependent: aDependent. self dependents isEmpty ifTrue: [self release]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Debugger class instanceVariableNames: ''! !Debugger class methodsFor: 'instance creation'! context: aContext "Answer an instance of me that models the current state of the system. The active process has determined that a debugger should be set up (often by the user issuing the command debug)." | aDebugger | aDebugger _ self new. aDebugger process: Processor activeProcess context: aContext interrupted: false. ^aDebugger! interruptProcess: interruptedProcess "Answer an instance of me that models the current state of the system. The active process has decided to provide a debugger on an interrupted process. This message is called if the user types the ctrl c interrupt, or a low space notification occurs." | debugger | debugger _ self new. debugger process: interruptedProcess context: interruptedProcess suspendedContext interrupted: true. ^debugger! openFullViewOn: aDebugger label: aString "Answer an instance of me on the model, aDebugger. The label is aString. Do not terminate the current active process." | topView | aDebugger openInspectors. topView _ BrowserView model: aDebugger label: aString minimumSize: 300@230. topView addSubView: (SelectionInListView on: aDebugger printItems: true oneItem: false aspect: #context change: #context: list: #contextList menu: #contextMenu initialSelection: #context) in: (0@0 extent: 1@0.2) borderWidth: 1. topView addSubView: (CodeView on: aDebugger aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil) in: (0@0.2 extent: 1@0.6) borderWidth: 1. InspectorView view: aDebugger receiverInspector in: (0@0.8 extent: 0.5@0.2) of: topView. InspectorView view: aDebugger contextInspector in: (0.5@0.8 extent: 0.5@0.2) of: topView. topView controller openNoTerminate. ^topView! ! !Debugger class methodsFor: 'class initialization'! flushMenus "Debugger flushMenus." ContextMenu _ nil! initialize "Debugger initialize." HighlightPC _ true! ! Debugger initialize! InstructionStream subclass: #Decompiler instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit lastJumpPc lastReturnPc limit hasValue ' classVariableNames: 'ArgumentFlag CascadeFlag ' poolDictionaries: '' category: 'System-Compiler'! Decompiler comment: 'I translate CompiledMethods into source code.'! !Decompiler methodsFor: 'initialize-release'! initSymbols: aClass | nTemps | constructor method: method class: aClass literals: method literals. constTable _ constructor codeConstants. instVars _ Array new: aClass instSize. "parse the header" nTemps _ method numTemps. tempVars _ Array new: nTemps. 1 to: nTemps do: [:i | tempVars at: i put: (constructor codeTemp: i - 1)]! ! !Decompiler methodsFor: 'control'! blockTo: end | exprs block | "Decompile a range of code as in statementsTo:, but return a block node" exprs _ self statementsTo: end. block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc. lastReturnPc _ -1. "So as not to mislead outer calls" ^block! checkForBlock: receiver "We just saw a blockCopy: message. Check for a following block." | savePc jump args argPos block | receiver == constructor codeThisContext ifFalse: [^false]. savePc _ pc. (jump _ self interpretJump) notNil ifFalse: [pc _ savePc. ^nil]. "Definitely a block" jump _ jump + pc. argPos _ statements size. [self willStorePop] whileTrue: [stack addLast: ArgumentFlag. "Flag for doStore:" self interpretNextInstructionFor: self]. args _ Array new: statements size - argPos. 1 to: args size do: [:i | args at: i put: statements removeLast]. "Retrieve args" block _ self blockTo: jump. stack addLast: (constructor codeArguments: args block: block). ^true! statementsTo: end | blockPos stackPos | "Decompile the method from pc up to end and return an array of expressions. If at run time this block will leave a value on the stack, set hasValue to true. If the block ends with a jump or return, set exit to the destination of the jump, or the end of the method; otherwise, set exit = end. Leave pc = end." blockPos _ statements size. stackPos _ stack size. [pc < end] whileTrue: [lastPc _ pc. limit _ end. "for performs" self interpretNextInstructionFor: self]. "If there is an additional item on the stack, it will be the value of this block." (hasValue _ stack size > stackPos) ifTrue: [statements addLast: stack removeLast]. lastJumpPc = lastPc ifFalse: [exit _ pc]. ^self popTo: blockPos! ! !Decompiler methodsFor: 'instruction decoding'! blockReturnTop "No action needed"! doDup stack last == CascadeFlag ifFalse: ["Save position and mark cascade" stack addLast: statements size. stack addLast: CascadeFlag]. stack addLast: CascadeFlag! doPop statements addLast: stack removeLast! doStore: stackOrBlock "Only called internally, not from InstructionStream. StackOrBlock is stack for store, statements for storePop." | var expr | var _ stack removeLast. expr _ stack removeLast. stackOrBlock addLast: (expr == ArgumentFlag ifTrue: [var] ifFalse: [constructor codeAssignTo: var value: expr])! jump: dist exit _ pc + dist. lastJumpPc _ lastPc! jump: dist if: condition | savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump elseJump condHasValue b | elsePc _ lastPc. elseStart _ pc + dist. end _ limit. "Check for bfp-jmp to invert condition. Don't be fooled by a loop with a null body." sign _ condition. savePc _ pc. ((elseDist _ self interpretJump) notNil and: [elseDist >= 0 and: [elseStart = pc]]) ifTrue: [sign _ sign not. elseStart _ pc + elseDist] ifFalse: [pc _ savePc]. ifExpr _ stack removeLast. thenBlock _ self blockTo: elseStart. condHasValue _ hasValue. "ensure jump is within block (in case thenExpr returns)" thenJump _ exit <= end ifTrue: [exit] ifFalse: [elseStart]. "if jump goes back, then it's a loop" thenJump < elseStart ifTrue: ["thenJump will jump to the beginning of the while expr. In the case of while's with a block in the condition, the while expr should include more than just the last expression: find all the statements needed by re-decompiling." pc _ thenJump. b _ self statementsTo: elsePc. "discard unwanted statements from block" b size - 1 timesRepeat: [statements removeLast]. statements addLast: (constructor codeMessage: (constructor codeBlock: b returns: false) selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro) arguments: (Array with: thenBlock)). pc _ elseStart] ifFalse: [elseBlock _ self blockTo: thenJump. elseJump _ exit. "if elseJump is backwards, it is not part of the elseExpr" elseJump < elsePc ifTrue: [pc _ lastPc]. cond _ constructor codeMessage: ifExpr selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro) arguments: (sign ifTrue: [Array with: elseBlock with: thenBlock] ifFalse: [Array with: thenBlock with: elseBlock]). condHasValue ifTrue: [stack addLast: cond] ifFalse: [statements addLast: cond]]! methodReturnConstant: value self pushConstant: value; methodReturnTop! methodReturnReceiver self pushReceiver; methodReturnTop! methodReturnTop exit _ method size + 1. lastJumpPc _ lastReturnPc _ lastPc. statements addLast: stack removeLast! popIntoLiteralVariable: value self pushLiteralVariable: value; doStore: statements! popIntoReceiverVariable: offset self pushReceiverVariable: offset; doStore: statements! popIntoTemporaryVariable: offset self pushTemporaryVariable: offset; doStore: statements! pushActiveContext stack addLast: constructor codeThisContext! pushConstant: value | node | node _ value == true ifTrue: [constTable at: 2] ifFalse: [value == false ifTrue: [constTable at: 3] ifFalse: [value == nil ifTrue: [constTable at: 4] ifFalse: [constructor codeAnyLiteral: value]]]. stack addLast: node! pushLiteralVariable: assoc stack addLast: (constructor codeAnyLitInd: assoc)! pushReceiver stack addLast: (constTable at: 1)! pushReceiverVariable: offset | var | (var _ instVars at: offset + 1) == nil ifTrue: ["Not set up yet" instVars at: offset + 1 put: (var _ constructor codeInst: offset)]. stack addLast: var! pushTemporaryVariable: offset stack addLast: (tempVars at: offset + 1)! send: selector super: superFlag numArgs: numArgs | args rcvr selNode msgNode messages | args _ Array new: numArgs. (numArgs to: 1 by: -1) do: [:i | args at: i put: stack removeLast]. rcvr _ stack removeLast. superFlag ifTrue: [rcvr _ constructor codeSuper]. (selector == #blockCopy: and: [self checkForBlock: rcvr]) ifFalse: [selNode _ constructor codeAnySelector: selector. rcvr == CascadeFlag ifTrue: [msgNode _ constructor codeCascadedMessage: selNode arguments: args. stack last == CascadeFlag ifFalse: ["Last message of a cascade" statements addLast: msgNode. messages _ self popTo: stack removeLast. "Depth saved by first dup" msgNode _ constructor codeCascade: stack removeLast messages: messages]] ifFalse: [msgNode _ constructor codeMessage: rcvr selector: selNode arguments: args]. stack addLast: msgNode]! storeIntoLiteralVariable: assoc self pushLiteralVariable: assoc; doStore: stack! storeIntoReceiverVariable: offset self pushReceiverVariable: offset; doStore: stack! storeIntoTemporaryVariable: offset self pushTemporaryVariable: offset; doStore: stack! ! !Decompiler methodsFor: 'public access'! decompile: aSelector in: aClass ^self decompile: aSelector in: aClass method: (aClass compiledMethodAt: aSelector)! decompile: aSelector in: aClass method: aMethod "answer with a parse tree (root is a MethodNode) for this method" ^self decompile: aSelector in: aClass method: aMethod using: DecompilerConstructor new! ! !Decompiler methodsFor: 'private'! decompile: aSelector in: aClass method: aMethod using: aConstructor | block | constructor _ aConstructor. method _ aMethod. self initSymbols: aClass. "create symbol tables" method isQuick ifTrue: [block _ self quickMethod] ifFalse: [stack _ OrderedCollection new: method frameSize. statements _ OrderedCollection new: 20. super method: method pc: method initialPC. block _ self blockTo: method endPC + 1. stack isEmpty ifFalse: [self error: 'stack not empty']]. ^constructor codeMethod: aSelector block: block tempVars: tempVars primitive: method primitive class: aClass! popTo: oldPos | t | t _ Array new: statements size - oldPos. (t size to: 1 by: -1) do: [:i | t at: i put: statements removeLast]. ^t! quickMethod ^method isReturnSelf ifTrue: [constructor codeBlock: (Array with: (constTable at: 1 "self")) returns: true] ifFalse: [method isReturnField ifTrue: [constructor codeBlock: (Array with: (constructor codeInst: method returnField)) returns: true] ifFalse: [self error: 'improper short method']]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Decompiler class instanceVariableNames: ''! !Decompiler class methodsFor: 'class initialization'! initialize "Decompiler initialize" CascadeFlag _ 'cascade'. "A unique object" ArgumentFlag _ 'argument'. "Ditto"! ! Decompiler initialize! ParseNode subclass: #DecompilerConstructor instanceVariableNames: 'method instVars nArgs literalValues tempVars ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! DecompilerConstructor comment: 'I am used by the decompiler to construct parse tree nodes and other appropriate items corresponding to each unit identified by the decompiler. This factoring allows the decompiler, in principle, to use other constructors for other purposes. '! !DecompilerConstructor methodsFor: 'initialize-release'! method: aMethod class: aClass literals: literals method _ aMethod. instVars _ aClass allInstVarNames. nArgs _ method numArgs. literalValues _ literals! ! !DecompilerConstructor methodsFor: 'constructor'! codeAnyLiteral: value ^LiteralNode new key: value index: 0 type: LdLitType! codeAnyLitInd: association ^VariableNode new name: association key key: association index: 0 type: LdLitIndType! codeAnySelector: selector ^SelectorNode new key: selector index: 0 type: SendType! codeArguments: args block: block ^block arguments: args! codeAssignTo: variable value: expression ^AssignmentNode new variable: variable value: expression! codeBlock: statements returns: returns ^BlockNode new statements: statements returns: returns! codeCascade: receiver messages: messages ^CascadeNode new receiver: receiver messages: messages! codeCascadedMessage: selector arguments: arguments ^self codeMessage: nil selector: selector arguments: arguments! codeConstants "Answer with an array of the objects representing self, true, false, nil, -1, 0, 1, 2" ^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil) , ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! codeEmptyBlock ^BlockNode new default! codeInst: index ^VariableNode new name: (instVars at: index + 1) index: index type: LdInstType! codeMessage: receiver selector: selector arguments: arguments | symbol | symbol _ selector key. ^MessageNode new receiver: receiver selector: selector arguments: arguments precedence: (symbol isInfix ifTrue: [2] ifFalse: [symbol isKeyword ifTrue: [3] ifFalse: [1]])! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node precedence | node _ self codeSelector: selector code: nil. precedence _ selector isInfix ifTrue: [2] ifFalse: [selector isKeyword ifTrue: [3] ifFalse: [1]]. tempVars _ vars. ^MethodNode new selector: node arguments: (tempVars copyFrom: 1 to: nArgs) precedence: precedence temporaries: (tempVars copyFrom: nArgs + 1 to: tempVars size) block: block encoder: (Encoder new initScopeAndLiteralTables nTemps: tempVars size literals: literalValues class: class) primitive: primitive! codeSelector: sel code: code ^SelectorNode new key: sel code: code! codeSuper ^NodeSuper! codeTemp: index ^VariableNode new name: 't' , (index + 1) printString index: index type: LdTempType! codeThisContext ^NodeThisContext! ! Object subclass: #Delay instanceVariableNames: 'delayDuration resumptionTime delaySemaphore delayInProgress ' classVariableNames: 'AccessProtect ActiveDelay SuspendedDelays TimingSemaphore ' poolDictionaries: '' category: 'Kernel-Processes'! Delay comment: 'Class Delay represents a real time delay in the execution of a Process. An instance of Delay will respond to the message #wait by suspending the active process for a certain amount of time. The time for resumption of the active process is specified when the Delay is created. The resumption time can be specified relative to the current time with the messages {Delay forMilliseconds: anInteger} and {Delay forSeconds: anInteger}. Delays created in this way can be sent the message #wait again after they have finished a previous delay. The resumption time can also be specified at an absolute time with respect to the system''s millisecond clock with the message {Delay untilMillisecond: anInteger}. Delays created in this way cannot be sent the message #wait repeatedly. Instance Variables: delayDuration number of milliseconds to delay process resumptionTime value of millisecond clock at which to resume delaySemaphore on which to delay process delayInProgress true if delaying now Class Variables: AccessProtect ActiveDelay SuspendedDelays of Delays TimingSemaphore '! !Delay methodsFor: 'accessing'! resumptionTime "Answer the value of the system's millisecondClock at which the receiver's suspended Process will resume." ^resumptionTime! ! !Delay methodsFor: 'process delay'! disable AccessProtect wait. delayInProgress ifTrue: [ActiveDelay == self ifTrue: [SuspendedDelays isEmpty ifTrue: [Processor signal: nil atTime: 0. ActiveDelay _ nil] ifFalse: [SuspendedDelays removeFirst activate]] ifFalse: [SuspendedDelays remove: self]. delaySemaphore terminateProcess. delayInProgress _ false]. AccessProtect signal! wait "Suspend the active process for an amount of time specified when the receiver was initialized." "(ActiveDelay == nil or: [ActiveDelay resumptionTime > Time millisecondClockValue]) ifFalse: [TimingSemaphore signal]." AccessProtect wait. self setResumption. ActiveDelay == nil ifTrue: [self activate] ifFalse: [resumptionTime < ActiveDelay resumptionTime ifTrue: [SuspendedDelays add: ActiveDelay. self activate] ifFalse: [SuspendedDelays add: self]]. AccessProtect signal. delaySemaphore wait! ! !Delay methodsFor: 'private'! activate "For the moment, the receiver will be the next Delay to resume the reciever's suspended process." ActiveDelay _ self. TimingSemaphore initSignals. Processor signal: TimingSemaphore atTime: resumptionTime! delay: millisecondCount delayDuration _ millisecondCount. delayInProgress _ false. delaySemaphore _ Semaphore new! delayInProgress: aBoolean delayInProgress _ aBoolean! postSnapshot | pendingDelay | delayInProgress ifTrue: [resumptionTime == nil ifTrue: [self error: 'uninitialized Delay'] ifFalse: ["convert from milliseconds since Jan. 1 1901 to local millisecond clock" pendingDelay _ resumptionTime - (Time totalSeconds * 1000). pendingDelay _ pendingDelay max: 0. resumptionTime _ Time millisecondClockValue + pendingDelay]] "if false then this delay must be ready and waiting (on AccessProtect) to resume"! preSnapshot | pendingDelay | delayInProgress ifTrue: [resumptionTime == nil ifTrue: [self error: 'uninitialized Delay'] ifFalse: ["convert from local millisecond clock to milliseconds since Jan. 1 1901" pendingDelay _ resumptionTime - Time millisecondClockValue. resumptionTime _ Time totalSeconds * 1000 + pendingDelay]] ifFalse: [self error: 'This Delay is not waiting']! reactivate "Make sure the timer is armed to go off for this delay." delayInProgress ifTrue: [TimingSemaphore initSignals. Processor signal: TimingSemaphore atTime: resumptionTime] "if false then the timer has already fired for this delay and it is waiting (on AccessProtect) to resume"! resume "The receiver's delay duration has expired, the process the receiver suspended will resume now. " Processor signal: nil atTime: 0. delayInProgress _ false. delaySemaphore signal! resumption: millisecondCount delayDuration _ nil. resumptionTime _ millisecondCount. delayInProgress _ false. delaySemaphore _ Semaphore new! setResumption delayInProgress ifTrue: [self error: 'This Delay is already waiting'] ifFalse: [delayDuration == nil ifTrue: [resumptionTime == nil ifTrue: [self error: 'uninitialized Delay']] ifFalse: [resumptionTime _ Time millisecondClockValue + delayDuration]. delayInProgress _ true]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Delay class instanceVariableNames: ''! !Delay class methodsFor: 'class initialization'! initialize "Initialize class variables that keep track of active Delays." "Delay initialize." TimingSemaphore _ Semaphore new. AccessProtect _ Semaphore forMutualExclusion. SuspendedDelays _ SortedCollection sortBlock: [:oldDelay :addedDelay | oldDelay resumptionTime <= addedDelay resumptionTime]. ActiveDelay _ nil. self initializeTimingProcess! initializeTimingProcess [[true] whileTrue: [TimingSemaphore wait. ActiveDelay delayInProgress: false. AccessProtect wait. ActiveDelay resume. SuspendedDelays isEmpty ifTrue: [ActiveDelay _ nil] ifFalse: [SuspendedDelays removeFirst activate]. AccessProtect signal]] forkAt: Processor timingPriority! ! !Delay class methodsFor: 'instance creation'! forMilliseconds: millisecondCount "Answer a new instance that will delay the active process for millisecondCount milliseconds when sent the message wait." ^self new delay: millisecondCount! forSeconds: secondCount "Answer a new instance that will delay the active process for secondCount seconds when sent the message wait." ^self new delay: (secondCount * 1000) rounded! untilMilliseconds: millisecondCount "Answer a new instance that will delay the active process until the system's millisecond clock value is millisecondCount when sent the message wait." ^self new resumption: millisecondCount! ! !Delay class methodsFor: 'testing'! testAbsoluteDelayOf: delay for: testCount label: label | time | time _ Delay millisecondClockValue. [1 to: testCount do: [:index | (Delay untilMilliseconds: time + (index * delay)) wait. Transcript show: label. Transcript show: index printString. Transcript space]] forkAt: Processor userInterruptPriority "Transcript cr. Delay testAbsoluteDelayOf: 1000 for: 10 label: 'A'. Delay testAbsoluteDelayOf: 1500 for: 10 label: 'B'. "! testRelativeDelayOf: delay for: testCount label: label | myDelay | myDelay _ Delay forMilliseconds: delay. [1 to: testCount do: [:index | myDelay wait. Transcript show: label. Transcript show: index printString. Transcript space]] forkAt: Processor userInterruptPriority "Transcript cr. Delay testRelativeDelayOf: 1000 for: 10 label: 'A'. Delay testRelativeDelayOf: 1500 for: 10 label: 'B'. "! ! !Delay class methodsFor: 'general inquiries'! millisecondClockValue "Answer the current value of the system's millisecond clock." ^Time millisecondClockValue! ! !Delay class methodsFor: 'snapshots'! postSnapshot ActiveDelay~~nil ifTrue: [ActiveDelay postSnapshot. SuspendedDelays do: [ :delay | delay postSnapshot]. ActiveDelay reactivate]. AccessProtect signal! preSnapshot AccessProtect wait. ActiveDelay~~nil ifTrue: [ActiveDelay preSnapshot]. SuspendedDelays do: [ :delay | delay preSnapshot]! ! !Delay class methodsFor: 'documentation'! ! Delay initialize! Set variableSubclass: #Dictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! Dictionary comment: 'A Dictionary is a set of associations. Several special kinds of Dictionaries exist in the system. They are IdentityDictionary do lookup using == rather than = MethodDictionary like IdentityDictionary except removal is implemented as an atomic operation LiteralDictionary check for equality and class of keys; used by the compiler SystemDictionary contains information about the system Instance Variables: *indexed* tally Number of elements in the Dictionary'! !Dictionary methodsFor: 'accessing'! associationAt: key "Answer the association at key. If key is not found, provide an error notification." ^self associationAt: key ifAbsent: [self errorKeyNotFound]! associationAt: key ifAbsent: aBlock "Answer the association at key. If key is not found, answer the result of evaluating aBlock." | index | index _ self findKey: key ifAbsent: [^aBlock value]. ^self basicAt: index! associations "Answer an OrderedCollection containing the receiver's associations in an arbitrary order." | aCollection | aCollection _ OrderedCollection new: self size. self associationsDo: [:key | aCollection add: key]. ^aCollection! at: key "Answer the value at key. If key is not found, provide an error notification. " ^self at: key ifAbsent: [self errorKeyNotFound]! at: key ifAbsent: aBlock "Answer the value at key. If key is not found, answer the result of evaluating aBlock." | index | index _ self findKey: key ifAbsent: [^aBlock value]. ^(self basicAt: index) value! at: key put: anObject "Set the value at key to be anObject. If key is not found, create a new entry for key and set is value to anObject. Answer anObject." | index element | index _ self findKeyOrNil: key. element _ self basicAt: index. element == nil ifTrue: [self atNewIndex: index put: (Association key: key value: anObject)] ifFalse: [element value: anObject]. ^anObject! keyAtValue: value "Answer the key whose value equals the argument, value. If there is none, provide an error notification." ^self keyAtValue: value ifAbsent: [self errorValueNotFound]! keyAtValue: value ifAbsent: exceptionBlock "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." self associationsDo: [:association | value == association value ifTrue: [^association key]]. ^exceptionBlock value! keys "Answer a set containing the receiver's keys." | aSet | aSet _ Set new: self size. self keysDo: [:key | aSet add: key]. ^aSet! values "Answer a Bag containing the receiver's values." | aBag | aBag _ Bag new. self do: [:value | aBag add: value]. ^aBag! ! !Dictionary methodsFor: 'testing'! includes: anObject "Answer whether anObject is one of the receiver's elements." self do: [:each | anObject = each ifTrue: [^true]]. ^false! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." | count | count _ 0. self do: [:each | anObject = each ifTrue: [count _ count + 1]]. ^count! ! !Dictionary methodsFor: 'adding'! add: anAssociation "Include newObject as one of the receiver's elements. Answer newObject." | index element | index _ self findKeyOrNil: anAssociation key. element _ self basicAt: index. element == nil ifTrue: [self atNewIndex: index put: anAssociation] ifFalse: [element value: anAssociation value]. ^anAssociation! declare: key from: aDictionary "Add key to the receiver. If key already exists, do nothing. If aDictionary includes key, then remove it from aDictionary and use its association as the entry to the receiver." (self includesKey: key) ifTrue: [^self]. (aDictionary includesKey: key) ifTrue: [self add: (aDictionary associationAt: key). aDictionary removeKey: key] ifFalse: [self at: key put: nil]! grow "Increase the number of elements of the collection." | newSelf | newSelf _ self species new: self basicSize + self growSize. self associationsDo: [:each | newSelf noCheckAdd: each]. self become: newSelf! ! !Dictionary methodsFor: 'removing'! remove: anObject "Provide an error notification that removing an element from a Dictionary is not allowed." self shouldNotImplement! remove: anObject ifAbsent: exceptionBlock "Provide an error notification that Dictionaries can not respond to remove: messages." self shouldNotImplement! ! !Dictionary methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of the values of the receiver as the argument. Collect the resulting values into a collection that is like the receiver. Answer the new collection." | newCollection | newCollection _ Bag new. self do: [:each | newCollection add: (aBlock value: each)]. ^newCollection! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. " super do: [:assoc | aBlock value: assoc value]! select: aBlock "Evaluate aBlock with each of the values of the receiver as the argument. Collect into a new dictionary, only those associations for which aBlock evaluates to true. " | newCollection | newCollection _ self species new. self associationsDo: [:each | (aBlock value: each value) ifTrue: [newCollection add: each]]. ^newCollection! ! !Dictionary methodsFor: 'converting'! asSortedCollection "Answer a new instance of SortedCollection whose elements are the elements of the receiver. The sort order is the default less than or equal ordering." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. self associationsDo: [:association | aSortedCollection add: association]. ^aSortedCollection! ! !Dictionary methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." | tooMany | tooMany _ aStream position + self maxPrint. aStream nextPutAll: self class name, ' ('. self associationsDo: [:element | aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self]. element printOn: aStream. aStream space]. aStream nextPut: $)! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an collection similar to the receiver. The general format for a Dictionary is ((class-name new) add: association; add: association; ... ; yourself)" | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new)'. noneYet _ true. self associationsDo: [:each | noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' add: '. aStream store: each]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !Dictionary methodsFor: 'dictionary testing'! includesAssociation: anAssociation "Answer whether the receiver has an element (association between a key and a value) that is equal to the argument, anAssociation." ^super includes: anAssociation! includesKey: key "Answer whether the receiver has a key equal to the argument, key." | index | index _ self findKeyOrNil: key. ^(self basicAt: index) ~~ nil! ! !Dictionary methodsFor: 'dictionary removing'! removeAssociation: anAssociation "Remove the key and value association, anAssociation, from the receiver. Answer anAssociation. If the key is not in the receiver, then provide an error notification that it was not found." ^self removeAssociation: anAssociation ifAbsent: [self errorNotFound]! removeAssociation: anAssociation ifAbsent: anExceptionBlock "Remove the key and value association, anAssociation, from the receiver. If not found, answer the result of evaluating anExceptionBlock, otherwise answer anAssociation." ^super remove: anAssociation ifAbsent: anExceptionBlock! removeKey: key "Remove key from the receiver. If key is not in the receiver, provide an error notification. Otherwise, answer the value associated with key." ^self removeKey: key ifAbsent: [self errorKeyNotFound]! removeKey: key ifAbsent: aBlock "Remove key from the receiver. If key is not in the receiver, answer the result of evaluating aBlock. Otherwise, answer the value associated with key." | index element | index _ self findKey: key ifAbsent: [^aBlock value]. element _ self basicAt: index. self basicAt: index put: nil. tally _ tally - 1. self fixCollisionsFrom: index. ^element! ! !Dictionary methodsFor: 'dictionary enumerating'! associationsDo: aBlock "Evaluate aBlock for each of the receiver's key/value associations." super do: aBlock! keysDo: aBlock "Evaluate aBlock for each of the receiver's keys." self associationsDo: [:association | aBlock value: association key]! ! !Dictionary methodsFor: 'user interface'! inspect "Create and schedule a DictionaryInspector in which the user can examine the receiver's variables." Cursor wait showWhile: [InspectorView open: (DictionaryInspector inspect: self)]! ! !Dictionary methodsFor: 'private'! errorKeyNotFound "Provide an error notification that the key was not found." self error: 'key not found'! errorValueNotFound "Provide an error notification that the value was not found." self error: 'value not found'! findKey: key ifAbsent: aBlock "Look for the key in the receiver. If it is found, answer the index of the association containting the key, otherwise answer the result of evaluating aBlock." | index | index _ self findKeyOrNil: key. (self basicAt: index) == nil ifTrue: [^aBlock value]. ^index! findKeyOrNil: key "Look for the key in the receiver. If it is found, answer the index of the association containting the key, otherwise answer nil." | location length probe pass | length _ self basicSize. pass _ 1. location _ key hash \\ length + 1. [(probe _ self basicAt: location) == nil or: [probe key = key]] whileFalse: [(location _ location + 1) > length ifTrue: [location _ 1. pass _ pass + 1. pass > 2 ifTrue: [^self grow findKeyOrNil: key]]]. ^location! rehash "Recompute the hash numbers for the elements of the receiver." "Smalltalk rehash." | newSelf | newSelf _ self species new: self basicSize. self associationsDo: [:each | newSelf noCheckAdd: each]. self become: newSelf! ! Inspector subclass: #DictionaryInspector instanceVariableNames: 'ok ' classVariableNames: 'DictListMenu ' poolDictionaries: '' category: 'Interface-Inspector'! DictionaryInspector comment: 'Note that the "field" instance variable of DictionaryInspectors contains the actual current dictionary key object, not a field name string.'! !DictionaryInspector methodsFor: 'field list'! acceptText: aText from: aController | val | field == nil ifTrue: [^ false]. val _ self evaluateText: aText string from: aController ifFail: [^ false]. object at: field put: val. self changed: #text. ^ true! fieldList "Answer a collection of the keys of the inspected dictionary." | keys | keys _ object keys. keys detect: [:key | (key class == Symbol) not] ifNone: [^keys asSortedCollection]. "sort dictionaries with Symbol keys" ^keys asOrderedCollection! fieldMenu "DictionaryInspector flushMenus" field == nil ifTrue: [^ActionMenu labels: 'add field' withCRs selectors: #(addField)]. DictListMenu == nil ifTrue: [DictListMenu _ ActionMenu labels: 'inspect\references\add field\remove' withCRs lines: #(2) selectors: #(inspectField browseReferences addField removeField)]. ^DictListMenu! fieldValue ^object at: field! printItems "Answer whether the elements of the fieldList need to be converted to strings" ^true! ! !DictionaryInspector methodsFor: 'menu commands'! addField | aString key | aString _ FillInTheBlank request: 'Enter key as a Smalltalk constant'. aString isEmpty ifTrue: [^self]. ok _ true. key _ Compiler evaluate: aString for: nil notifying: self logged: false. ok ifFalse: [^nil]. object add: (Association key: key value: nil). field _ key. self changed: #field! browseReferences Smalltalk browseAllCallsOn: (object associationAt: field)! removeField (self confirm: 'Confirm removal of ', field printString) ifFalse: [^self]. object removeKey: field. field _ nil. self changed: #field! ! !DictionaryInspector methodsFor: 'compiler interface'! insertAndSelect: aString at: ignoredIndex ok _ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DictionaryInspector class instanceVariableNames: ''! !DictionaryInspector class methodsFor: 'examples'! inspectExample "Create and schedule an Inspector in which the user can examine the receiver's variables." "DictionaryInspector inspectExample." | dictionary | dictionary _ Dictionary new. dictionary at: 'A' put: $A. dictionary at: 'Two' put: 2. dictionary at: 'Three' put: 3. InspectorView open: (DictionaryInspector inspect: dictionary)! ! !DictionaryInspector class methodsFor: 'initialization'! flushMenus DictListMenu _ nil! ! WordArray variableWordSubclass: #DisplayBitmap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Support'! DisplayBitmap comment: 'Class DisplayBitmap is a subclass of Bitmap that is used to indicate the particular bitmap which is being displayed, so that various implementations can treat it specially. It adds no protocol. Instance Variables: *word indexed*'! DisplayObject subclass: #DisplayMedium instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! DisplayMedium comment: 'The abstract class DisplayMedium represents a display object which can both paint itself on a medium (such as Display) and can act as a medium itself. Its chief subclass is Form. Subclasses must implement methods for coloring fill:rule:mask: displaying copyBits:from:at:clippingBox:rule:mask: drawLine:from:to:clippingBox:rule:mask:'! !DisplayMedium methodsFor: 'coloring'! black "Set all bits in the receiver to black (ones)." self fill: self boundingBox mask: Form black! black: aRectangle "Set all bits in the receiver's area defined by aRectangle to black (ones)." self fill: aRectangle rule: Form over mask: Form black! darkGray "Set all bits in the receiver to darkGray." self fill: self boundingBox mask: Form darkGray! darkGray: aRectangle "Set all bits in the receiver's area defined by aRectangle to the darkGray mask." self fill: aRectangle rule: Form over mask: Form darkGray! fill: aRectangle "Fill aRectangle with the default background, Form gray." self fill: aRectangle rule: Form over mask: Form gray! fill: aRectangle mask: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule over." self fill: aRectangle rule: Form over mask: aForm! fill: aRectangle rule: anInteger mask: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule anInteger." self subclassResponsibility! gray "Set all bits in the receiver to gray." self fill: self boundingBox mask: Form gray! gray: aRectangle "Set all bits in the receiver's area defined by aRectangle to the gray mask." self fill: aRectangle rule: Form over mask: Form gray! lightGray "Set all bits in the receiver to lightGray." self fill: self boundingBox mask: Form lightGray! lightGray: aRectangle "Set all bits in the receiver's area defined by aRectangle to the lightGray mask." self fill: aRectangle rule: Form over mask: Form lightGray! reverse "Change all the bits in the receiver that are white to black, and the ones that are black to white." self fill: self boundingBox rule: Form reverse mask: Form black! reverse: aRectangle "Change all the bits in the receiver's area that intersects with aRectangle that are white to black, and the ones that are black to white." self fill: aRectangle rule: Form reverse mask: Form black! reverse: aRectangle mask: aMask "Change all the bits in the receiver's area that intersect with aRectangle according to the mask. Black does not necessarily turn to white, rather it changes with respect to the rule and the bit in a corresponding mask location. Bound to give a surprise." self fill: aRectangle rule: Form reverse mask: aMask! veryLightGray "Set all bits in the receiver to veryLightGray." self fill: self boundingBox mask: Form veryLightGray! veryLightGray: aRectangle "Set all bits in the receiver's area defined by aRectangle to the veryLightGray mask." self fill: aRectangle rule: Form over mask: Form veryLightGray! white "Set all bits in the form to white (i.e., to zeros)." self fill: self boundingBox mask: Form white! white: aRectangle "Set all bits in the receiver's area defined by aRectangle to white (i.e., to zeros)." self fill: aRectangle rule: Form over mask: Form white! ! !DisplayMedium methodsFor: 'bordering'! border: aRectangle width: borderWidth "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses Form black for drawing the border." self border: aRectangle width: borderWidth mask: Form black! border: aRectangle width: borderWidth mask: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border." self border: aRectangle widthRectangle: (Rectangle left: borderWidth right: borderWidth top: borderWidth bottom: borderWidth) mask: aHalfTone! border: aRectangle width: borderWidth rule: aRule mask: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border." self border: aRectangle widthRectangle: (Rectangle left: borderWidth right: borderWidth top: borderWidth bottom: borderWidth) rule: aRule mask: aHalfTone! border: aRectangle widthRectangle: insets mask: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of each edge of the border is determined by the four coordinates of insets. Uses aHalfTone for drawing the border." (aRectangle areasOutside: (aRectangle insetBy: insets)) do: [:edgeStrip | self fill: edgeStrip mask: aHalfTone]! border: aRectangle widthRectangle: insets mask: aHalfTone clippingBox: clipRect "Paint a border whose rectangular area is defined by aRectangle. The width of each edge of the border is determined by the four coordinates of insets. Uses aHalfTone for drawing the border." (aRectangle areasOutside: (aRectangle insetBy: insets)) do: [:edgeStrip | self fill: (edgeStrip intersect: clipRect) mask: aHalfTone]! border: aRectangle widthRectangle: insets rule: aRule mask: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of each edge of the border is determined by the four coordinates of insets. Uses aHalfTone for drawing the border." (aRectangle areasOutside: (aRectangle insetBy: insets)) do: [:edgeStrip | self fill: edgeStrip rule: aRule mask: aHalfTone]! ! !DisplayMedium methodsFor: 'displaying'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule mask: aForm "Copy into the rectangle sourceRect within the receiver those pits from the form sourceForm starting at position destOrigin according to the mixing rule rule and with aForm as the mask. Clip the receiver's destination rectangle with respect to clipRect." self subclassResponsibility! drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger mask: aForm self subclassResponsibility! ! Object subclass: #DisplayObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! DisplayObject comment: 'The abstract class DisplayObject provides the protocol for most display primitives that are used by Views for presenting information on the screen. Its subclasses are DisplayMedium, DisplayText, InfiniteForm, OpaqueForm, and Path. Subclasses must implement methods for display box access computeBoundingBox displaying displayOn:at:clippingBox:rule:mask:'! !DisplayObject methodsFor: 'accessing'! extent "Answer the point that represents the width and height of the receiver's bounding box." ^self boundingBox extent! height "Answer the number that represents the height of the receiver's bounding box." ^self boundingBox height! offset "Answer the amount by which the receiver should be offset when it is displayed or its position is tested." self subclassResponsibility! offset: aPoint "Set the amount by which the receiver's position is offset." ^self! relativeRectangle "Answer a Rectangle whose top left corner is the receiver's offset position and whose width and height are the same as the receiver." ^Rectangle origin: self offset extent: self extent! width "Answer the number that represents the width of the receiver's bounding box." ^self boundingBox width! ! !DisplayObject methodsFor: 'truncation and round off'! rounded "Convert the offset of the receiver to integer coordinates." self offset: self offset rounded! ! !DisplayObject methodsFor: 'display box access'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^self computeBoundingBox! computeBoundingBox "Answer the rectangular area that represents the boundaries of the receiver's area for displaying information. This is the primitive for computing the area if it is not already known." self subclassResponsibility! ! !DisplayObject methodsFor: 'displaying'! display "Show the receiver on the display screen. Defaults to showing the receiver in the upper left corner of the screen." self displayOn: Display! displayAt: aDisplayPoint "Display the receiver located at aDisplayPoint with default settings for the displayMedium, rule and halftone." self displayOn: Display at: aDisplayPoint clippingBox: Display boundingBox rule: Form over mask: Form black! displayOn: aDisplayMedium "Simple default display in order to see the receiver in the upper left corner of screen." self displayOn: aDisplayMedium at: 0 @ 0! displayOn: aDisplayMedium at: aDisplayPoint "Display the receiver located at aDisplayPoint with default settings for rule and halftone." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: aDisplayMedium boundingBox rule: Form over mask: Form black! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle "Display the receiver located at aDisplayPoint with default settings for rule and halftone. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: Form over mask: Form black! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "This is the basic display primitive for graphic display objects. Display the receiver located at aDisplayPoint with rule, rule ruleInteger, and mask, aForm. Information to be displayed must be confined to the area that intersects with clipRectangle." self subclassResponsibility! displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger "Display the receiver located at aPoint with default setting for the halftone and clippingBox." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: aDisplayMedium boundingBox rule: ruleInteger mask: Form black! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle "Display primitive for the receiver where a DisplayTransformation is provided as an argument. Alignment is defaulted to the receiver's rectangle. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: self relativeRectangle center with: self relativeRectangle center rule: Form over mask: Form black! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint "Display primitive where a DisplayTransformation is provided as an argument, rule is over and mask is Form black. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: Form over mask: Form black! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger mask: aForm "Display the receiver where a DisplayTransformation is provided as an argument, rule is ruleInteger and mask is aForm. Translate by relativePoint-alignmentPoint. Information to be displayed must be confined to the area that intersects with clipRectangle." | absolutePoint | absolutePoint _ displayTransformation applyTo: relativePoint. self displayOn: aDisplayMedium at: (absolutePoint - alignmentPoint) clippingBox: clipRectangle rule: ruleInteger mask: aForm! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle fixedPoint: aPoint "Display the receiver where a DisplayTransformation is provided as an argument, rule is over and mask is Form black. No translation. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: aPoint with: aPoint rule: Form over mask: Form black! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger mask: aForm "Display the receiver where a DisplayTransformation is provided as an argument, rule is ruleInteger and mask is aForm. No translation. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: self relativeRectangle origin with: self relativeRectangle origin rule: ruleInteger mask: aForm! ! !DisplayObject methodsFor: 'transforming'! align: alignmentPoint with: relativePoint "Translate the receiver's offset such that alignmentPoint aligns with relativePoint." self offset: (self offset translateBy: relativePoint - alignmentPoint)! scaleBy: aPoint "Scale the receiver's offset by the amount of the argument, aPoint." self offset: (self offset scaleBy: aPoint)! translateBy: aPoint "Translate the receiver's offset by the amount of the argument, aPoint." self offset: (self offset translateBy: aPoint)! ! !DisplayObject methodsFor: 'screen'! backgroundAt: location "Answer a Form containing the contents of the Display which will be altered if I am displayed at location. The Form remembers location in its offset" ^ (Form fromDisplay: (location extent: self extent)) offset: location! follow: locationBlock while: durationBlock "This method moves an image around on the Display. It restores the background continuously without causing flashing. LocationBlock supplies each new location, and durationBlock supplies true to continue, and then false to stop." "See (or run) OpaqueForm starCursor." | location background | location _ locationBlock value. background _ self backgroundAt: location. self displayAt: location. [durationBlock value] whileTrue: [self moveTo: locationBlock value restoring: background]. background display! moveTo: newLoc restoring: background "Move an image to a new location on the Display, restoring the background without causing flashing. Background must be a Form containing the bits to be restored at the previous location (its offset), and this method will update its bits and offset appropriately" | location saveAll rect1 rect2 bothRects | "This method should be rewritten to use the offset in background directly" (location _ background offset) = newLoc ifTrue: [^background]. background offset: 0@0. rect1 _ location extent: self extent. rect2 _ newLoc extent: self extent. bothRects _ rect1 merge: rect2. (rect1 intersects: rect2) ifTrue: "When overlap, buffer background for both rectangles" [saveAll _ Form fromDisplay: bothRects. background displayOn: saveAll at: rect1 origin - bothRects origin. "now saveAll is clean background; get new bits for background" background copy: (0@0 extent: self extent) from: rect2 origin - bothRects origin in: saveAll rule: Form over. self displayOn: saveAll at: rect2 origin - bothRects origin. saveAll displayOn: Display at: bothRects origin] ifFalse: "If no overlap, do the simple thing (bothrects might be too big)" [background displayOn: Display at: location. background fromDisplay: rect2. self displayOn: Display at: newLoc]. ^ background offset: newLoc! ! CharacterScanner subclass: #DisplayScanner instanceVariableNames: 'lineY runX ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! DisplayScanner comment: 'Instances of class DisplayScanner hold the state of CharacterScanner in addition to the following required only for displaying or printing. They are used to scan text and display it on the screen or in a hidden form. Instance Variables lineY Top of line currently being displayed or scanned. The textStyle lineGrid is added or subtracted to discover the top of the next line. May differ from destY when fonts of differing height fall on the same line. runX Left of first character in the current run -- allows for creating underlining or similar emphasis.'! !DisplayScanner methodsFor: 'scanning'! displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle "The central display routine. The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to the StopConditions array passed to the primitive at which time the code to handle the stopCondition is run and the call on the primitive continued until a stopCondition returns true which means the line has terminated. " | runLength done lineGrid lineIndex stopCondition displaying| self initializeFromParagraph: aParagraph clippedBy: visibleRectangle. rightMargin _ aParagraph rightMarginForDisplay. lineGrid _ textStyle lineGrid. "assume outputMedium Display" lineY _ destY _ aParagraph topAtLineIndex: linesInterval first. displaying _ self doesDisplaying. linesInterval do: [:index | lineIndex _ index. runX _ destX _ leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex. line _ aParagraph lineAt: lineIndex. text _ aParagraph textAt: lineIndex. lastIndex _ line first. self setStopConditions. "also sets the font" destY _ lineY + self fontAscentDelta. "fontAscent delta" runLength _ text runLengthFor: line first. (runStopIndex _ lastIndex + (runLength - 1)) > line last ifTrue: [runStopIndex _ line last]. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions displaying: displaying. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. "Y origin upper left -- increases as moving down page." lineY _ lineY + lineGrid]. ^lineIndex! ! !DisplayScanner methodsFor: 'stop conditions'! cr "When a carriage return is encountered, simply increment the pointer into the paragraph." "When displaying line stopped in endOfRun, primitive hasn't incremented lastIndex when cr stop occurs, hence, " lastIndex_ lastIndex + 1. ^false! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." "This condition will sometimes be reached 'legally' during printing, when, for instance the space that caused the line to wrap actually extends over the right boundary. This character is allowed to print, even though it is technically outside or straddling the clippingRectangle since it is in the normal case not visible and is in any case appropriately clipped by the scanner." self checkEmphasis. ^true! endOfRun "The end of a run in the display case either means that there is actually a change in the style (run code) to be associated with the string or the end of this line has been reached. A check for any emphasis (underlining, for example) that may run the length of the run is done here before returning to displayLines: to do the next line" | runLength | lastIndex = line last ifTrue: [ "just displaying and at end of line" self checkEmphasis. ^true]. self checkEmphasis. runLength _ text runLengthFor: (lastIndex _ lastIndex + 1). self setStopConditions. runX _ destX. destY _ lineY + self fontAscentDelta. "fontAscent delta" (runStopIndex _ lastIndex + (runLength - 1)) > line last ifTrue: [runStopIndex _ line last]. ^false! onePixelBackspace "Increment destX by 1" destX _ (destX - 1) max: runX. lastIndex _ lastIndex + 1. ^false! onePixelSpace "Increment destX by 1" destX _ destX + 1. lastIndex _ lastIndex + 1. ^false! paddedSpace "Each space is a stop condition when the alignment = justified. Padding must be added to the base width of the space according to which space in the line this space is and according to the amount of space that remained at the end of the line when it was composed." spaceCount _ spaceCount + 1. destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount). lastIndex _ lastIndex + 1. ^false! setStopConditions "Set the font and the stop conditions for the current run." font _ textStyle fontAt: (text emphasisAt: lastIndex). super setStopConditions. stopConditions at: Space asInteger + 1 put: (textStyle alignment = Justified ifTrue: [#paddedSpace] ifFalse: [nil])! tab "This attempts to handle leading and internal tabs in a justified line. Leading tabs are considered legal and should be reflected on the display gracefully." | index| textStyle alignment = Justified ifTrue: [index _ line first. [index <= lastIndex] whileTrue: [(text at: index) == Space ifTrue: [destX _ destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX. lastIndex _ lastIndex + 1. ^false]. index _ index + 1]]. destX _ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. lastIndex _ lastIndex + 1. ^false! ! !DisplayScanner methodsFor: 'private'! checkEmphasis | emphasis sourceRect italicY lineSegment displayDestX displayRunX | (emphasis _ (font emphasis bitAnd: 7)) = 0 ifTrue: [^self]. displayDestX _ destX. displayRunX _ runX. emphasis >= 8 "overstrike" ifTrue: [destForm fill: ((displayRunX @ (lineY + textStyle baseline-3)) extent: (displayDestX - displayRunX) @ 1) rule: combinationRule mask: halftoneForm. emphasis _ emphasis - 8]. emphasis >= 4 "underlined" ifTrue: [lineSegment _ ((displayRunX @ (lineY + textStyle baseline + 1)) extent: (displayDestX - displayRunX) @ 1). lineSegment bottom <= (clipY+clipHeight) ifTrue: [destForm fill: lineSegment rule: combinationRule mask: halftoneForm]. emphasis _ emphasis - 4]. emphasis >= 2 "italic" ifTrue: [italicY _ lineY + textStyle lineGrid - 4. [italicY > lineY] whileTrue: [sourceRect _ displayRunX @ lineY extent: (displayDestX - displayRunX + 2) @ (italicY - lineY). destForm copyBits: sourceRect from: destForm at: (displayRunX+1) @ lineY clippingBox: sourceRect rule: Form over mask: nil. italicY _ italicY - 4]. emphasis _ emphasis - 2]. emphasis >= 1 "bold face" ifTrue: [sourceRect _ displayRunX @ lineY extent: (displayDestX - displayRunX + 1) @ textStyle lineGrid. destForm copyBits: sourceRect from: destForm at: (displayRunX+1) @ lineY clippingBox: sourceRect rule: Form under mask: nil]! doesDisplaying ^true! fontAscentDelta (font emphasis bitAnd: Subscripted + Superscripted) = 0 ifTrue: [^ textStyle baseline - font ascent]. ((font emphasis bitAt: SubscriptedBit) = 1) ifTrue: [^textStyle baseline - 2]. "Its Superscripted then" ^textStyle baseline - (textStyle fontAt: (text emphasisAt: ((lastIndex - 1) max: 1))) ascent! initializeFromParagraph: aParagraph clippedBy: clippingRectangle super initializeFromParagraph: aParagraph clippedBy: clippingRectangle! ! Form subclass: #DisplayScreen instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! DisplayScreen comment: 'There is only one instance of of the class DisplayScreen, Display. It is a global used to handle general user requests to deal with the whole display screen. The instance name provides a way to distinguish this special instance from all other Forms.'! !DisplayScreen methodsFor: 'displaying'! beDisplay "Tell the interpreter to use the receiver as the current display image. Fail if the form is too wide to fit on the physical display. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! flash: aRectangle "Complement twice the area of the screen defined by the argument, aRectangle." 2 timesRepeat: [self fill: aRectangle rule: Form reverse mask: Form black. (Delay forMilliseconds: 60) wait]! ! !DisplayScreen methodsFor: 'zooming'! slink: startRect to: stopRect "Display an evolving rectangle dynamically." "Display slink: (100@100 extent: 300@100) to: (600@600 extent: 10@10)." ^self slink: startRect to: stopRect speed: 4000! slink: startRect to: stopRect duration: milliseconds "Display an evolving rectangle dynamically. Show each intermediate rectangle such that the entire animation takes the desired amount of time." "Display slink: (100@100 extent: 300@100) to: (600@600 extent: 10@10) duration: 2000. Display slink: (600@600 extent: 10@10) to: (100@100 extent: 300@100) duration: 200." | originDelta cornerDelta pixels | originDelta _ stopRect origin - startRect origin. cornerDelta _ stopRect corner - startRect corner. "maximum number of positions for the fastest edge" pixels _ (originDelta x abs max: originDelta y abs) max: (cornerDelta x abs max: cornerDelta y abs). ^self slink: startRect to: stopRect speed: pixels*1000//milliseconds! slink: startRect to: stopRect speed: pixelsPerSecond "Display an evolving rectangle dynamically. Show each intermediate rectangle such that the fastest edge moves at a constant desired speed. In practice, it may be necessary to skip some rectangles in order to keep up. When finished. slink the rectangles back in." "Display slink: (100@100 extent: 300@100) to: (600@600 extent: 10@10) speed: 500." | originDelta cornerDelta nSteps period currentOrigin currentCorner step nextTime overtime samples stepRate rects | originDelta _ stopRect origin - startRect origin. cornerDelta _ stopRect corner - startRect corner. stepRate _ pixelsPerSecond//1000 max: 1. "minimum pixels/sample" period _ stepRate*1000//pixelsPerSecond max: 1. "msec per sample" "maximum number of positions for the fastest edge" nSteps _ ((originDelta x abs max: originDelta y abs) max: (cornerDelta x abs max: cornerDelta y abs)) // stepRate. nSteps _ nSteps max: 1. "position increment for each corner" originDelta _ originDelta / nSteps asFloat. cornerDelta _ cornerDelta / nSteps asFloat. currentOrigin _ startRect origin. currentCorner _ startRect corner. rects _ OrderedCollection new. step _ 0. nextTime _ Time millisecondClockValue. [[(overtime _ Time millisecondClockValue - nextTime) < 0] whileTrue: [(Delay untilMilliseconds: nextTime) wait]. samples _ (overtime // period) + 1. currentOrigin _ currentOrigin + (originDelta * samples). currentCorner _ currentCorner + (cornerDelta * samples). nextTime _ nextTime + (period * samples). (step _ step + samples) <= nSteps] whileTrue: [rects add: (currentOrigin corner: currentCorner). Display border: (currentOrigin corner: currentCorner) width: 2 rule: Form reverse mask: Form gray]. "now reel those rectangles back in" rects do: [:r | Display border: r width: 2 rule: Form reverse mask: Form gray]! zoom: startRect to: stopRect "Display an evolving rectangle dynamically." "Display zoom: (100@100 extent: 300@100) to: (600@600 extent: 10@10)." ^self zoom: startRect to: stopRect speed: 2000! zoom: startRect to: stopRect duration: milliseconds "Display an evolving rectangle dynamically. Show each intermediate rectangle such that the entire animation takes the desired amount of time. " "Display zoom: (100@100 extent: 300@100) to: (600@600 extent: 10@10) duration: 2000. Display zoom: (600@600 extent: 10@10) to: (100@100 extent: 300@100) duration: 200." | originDelta cornerDelta pixels | originDelta _ stopRect origin - startRect origin. cornerDelta _ stopRect corner - startRect corner. "maximum number of positions for the fastest edge" pixels _ (originDelta x abs max: originDelta y abs) max: (cornerDelta x abs max: cornerDelta y abs). ^self zoom: startRect to: stopRect speed: pixels * 1000 // milliseconds! zoom: startRect to: stopRect speed: pixelsPerSecond "Display an evolving rectangle dynamically. Show each intermediate rectangle such that the fastest edge moves at a constant desired speed. In practice, it may be necessary to skip some rectangles in order to keep up." "Display zoom: (100@100 extent: 300@100) to: (600@600 extent:10@10) speed: 500." | originDelta cornerDelta nSteps period currentOrigin currentCorner step nextTime overtime samples stepRate | originDelta _ stopRect origin - startRect origin. cornerDelta _ stopRect corner - startRect corner. stepRate _ pixelsPerSecond//1000 max: 1. "minimum pixels/sample" period _ stepRate*1000//pixelsPerSecond max: 1. "msec per sample" "maximum number of positions for the fastest edge" nSteps _ ((originDelta x abs max: originDelta y abs) max: (cornerDelta x abs max: cornerDelta y abs)) // stepRate. nSteps _ nSteps max: 1. "position increment for each corner" originDelta _ originDelta / nSteps asFloat. cornerDelta _ cornerDelta / nSteps asFloat. currentOrigin _ startRect origin. currentCorner _ startRect corner. step _ 0. nextTime _ Time millisecondClockValue. self outline: [currentOrigin corner: currentCorner] while: [[(overtime _ Time millisecondClockValue - nextTime) < 0] whileTrue: [(Delay untilMilliseconds: nextTime) wait]. samples _ (overtime // period) + 1. currentOrigin _ currentOrigin + (originDelta * samples). currentCorner _ currentCorner + (cornerDelta * samples). nextTime _ nextTime + (period * samples). (step _ step + samples) <= nSteps] width: 2 halftone: Form gray! ! !DisplayScreen methodsFor: 'outlining'! outline: rectBlock do: effectBlock while: durationBlock width: borderWidth halftone: halftone "Display an evolving rectangle dynamically. effectBlock supplies a rectangle, durationBlock supplies true, then false to terminate." | oldRect edges rect | oldRect _ rectBlock value rounded. edges _ oldRect areasOutside: (oldRect insetBy: borderWidth). edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. [durationBlock value] whileTrue: [rect _ rectBlock value rounded. rect = oldRect ifFalse: [edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. effectBlock value. edges _ rect areasOutside: (rect insetBy: borderWidth). edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. oldRect _ rect]]. edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. ^ oldRect! outline: rectBlock while: durationBlock width: borderWidth halftone: halftone "Display an evolving rectangle dynamically. rectBlock supplies a rectangle, durationBlock supplies true, then false to terminate." | oldRect edges rect | oldRect _ rectBlock value rounded. edges _ oldRect areasOutside: (oldRect insetBy: borderWidth). edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. [durationBlock value] whileTrue: [rect _ rectBlock value rounded. rect = oldRect ifFalse: [edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. edges _ rect areasOutside: (rect insetBy: borderWidth). edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. oldRect _ rect]]. edges do: [:edge | self fill: edge rule: Form reverse mask: halftone]. ^ oldRect! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayScreen class instanceVariableNames: ''! !DisplayScreen class methodsFor: 'current display'! currentDisplay: form "Make the argument, form, be the form representing the current display screen. Provide an error notification if form is not an instance of the receiver." form class == self ifTrue: [form bits class == DisplayBitmap ifTrue: [Display become: form. Display beDisplay] ifFalse: [self error: 'bitmap should be DisplayBitmap']] ifFalse: [self error: 'form should be DisplayForm']! displayExtent: extent "Make the width and height of the current display screen form be extent." | w h newDisplay | w _ extent x. h _ extent y. newDisplay _ DisplayScreen new extent: w @ h offset: 0 @ 0 bits: (DisplayBitmap new: w + 15 // 16 * h). Display displayOn: newDisplay. "copy the old display bits to the new display" DisplayScreen currentDisplay: newDisplay! displayHeight: height "Make the height of the current display screen form be the argument, height." ^self displayExtent: self boundingBox width @ height! resetExtent "Reset the Display to the new display screen size and redisplay all views." self displayExtent: self screenExtent! screenExtent "Return the extent of the hardware display screen" ^Display extent! ! !DisplayScreen class methodsFor: 'display box access'! boundingBox "Answer the bounding box for the form representing the current display screen." ^Display boundingBox! ! DisplayObject subclass: #DisplayText instanceVariableNames: 'text textStyle offset form ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Display Objects'! DisplayText comment: 'Instances of class DisplayText get used two different ways in the system. In the user interface, a DisplayText is used to hold onto some text which is viewed by some form of ParagraphEditor. Used more generally as a DisplayObject, an instance may need to display efficiently--an instance variable is used to cache the bits for that purpose. Instance Variables: text displayed by the receiver textStyle style by which the receiver displays its text. offset translation of the text position when displayed form for caching the bit representation of the receiver''s composed text. '! !DisplayText methodsFor: 'accessing'! form "Answer the form containing the composed text." form == nil ifTrue: [self composeForm]. ^form! lineGrid "Answer the relative space between lines of the receiver's text." ^textStyle lineGrid! numberOfLines "Answer the number of lines of text in the receiver." ^self height // text lineGrid! offset "Answer the offset of the receiver." ^offset! offset: aPoint "Set the offset to be the argument aPoint." offset _ aPoint! string "Answer the string of the characters displayed by the receiver." ^text string! text "Answer the text displayed by the receiver." ^text! text: aText "Set the receiver to display the argument, aText." text _ aText. form _ nil. self changed.! textStyle "Answer the style by which the receiver displays its text." ^textStyle! textStyle: aTextStyle "Set the style by which the receiver should display its text." textStyle _ aTextStyle. form _ nil. self changed.! ! !DisplayText methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Display the receiver on the display medium aDisplayMedium positioned at aDisplayPoint within the rectangle clipRectangle and with the rule, ruleInteger, and mask, aForm. " self form displayOn: aDisplayMedium at: aDisplayPoint + offset clippingBox: clipRectangle rule: ruleInteger mask: aForm! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger mask: aForm "Display the receiver where a DisplayTransformation is provided as an argument, rule is ruleInteger and mask is aForm. Translate by relativePoint-alignmentPoint. Information to be displayed must be confined to the area that intersects with clipRectangle." | absolutePoint | absolutePoint _ displayTransformation applyTo: relativePoint. absolutePoint _ absolutePoint x truncated @ absolutePoint y truncated. self displayOn: aDisplayMedium at: absolutePoint - alignmentPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm! ! !DisplayText methodsFor: 'display box access'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^self form boundingBox! computeBoundingBox "Answer the minimum enclosing rectangle around the characters in the text." | character font width carriageReturn lineWidth lineHeight | carriageReturn _ Character cr. width _ lineWidth _ 0. font _ textStyle defaultFont. lineHeight _ textStyle lineGrid. 1 to: text size do: [:i | character _ text at: i. character = carriageReturn ifTrue: [lineWidth _ lineWidth max: width. lineHeight _ lineHeight + textStyle lineGrid. width _ 0] ifFalse: [width _ width + (font widthOf: character)]]. lineWidth _ lineWidth max: width. ^offset extent: lineWidth @ lineHeight! ! !DisplayText methodsFor: 'converting'! asParagraph "Answer a Paragraph whose text and style are identical to that of the receiver." ^Paragraph withText: text style: textStyle copy! ! !DisplayText methodsFor: 'private'! composeForm "Cache the form for displaying the paragraph." form _ self asParagraph asForm! setText: aText textStyle: aTextStyle offset: aPoint "Initialize the instance variables." text _ aText. textStyle _ aTextStyle. offset _ aPoint. form _ nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayText class instanceVariableNames: ''! !DisplayText class methodsFor: 'instance creation'! text: aText "Answer an instance of me such that the text displayed is aText according to the system's default textstyle." ^self new setText: aText textStyle: DefaultTextStyle copy offset: 0 @ 0! text: aText textStyle: aTextStyle "Answer an instance of me such that the text displayed is aText according to the style specified by aTextStyle." ^self new setText: aText textStyle: aTextStyle offset: 0 @ 0! text: aText textStyle: aTextStyle offset: aPoint "Answer an instance of me such that the text displayed is aText according to the style specified by aTextStyle. The display of the information should be offset by the amount given as the argument, aPoint." ^self new setText: aText textStyle: aTextStyle offset: aPoint! ! !DisplayText class methodsFor: 'examples'! textSampler "Continually prints two lines of text wherever you point with the cursor. Terminate by pressing any mouse button." "DisplayText textSampler." | t | t _ 'this is a line of characters and this is the second line.' asDisplayText. [Sensor anyButtonPressed] whileFalse: [t displayOn: Display at: Sensor cursorPoint]! ! View subclass: #DisplayTextView instanceVariableNames: 'rule mask editParagraph centered ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Views'! DisplayTextView comment: 'Class DisplayTextView represents a view of an instance of DisplayText. Instance Variables: rule according to which character display behaves: equal over, under, and reverse. mask with which each character is combined by the display scanner before applying the rule. editParagraph the composed text ready for display centered whether the text is centered '! !DisplayTextView methodsFor: 'initialize-release'! initialize "Initialize the instance variables." super initialize. centered _ false! ! !DisplayTextView methodsFor: 'accessing'! centered "Set the receiver so that the text is displayed centered." centered _ true. self centerText! editParagraph: aParagraph "Set the text paragraph for the receiver to be aParagraph centered." editParagraph _ aParagraph. self centerText! isCentered "Answer whether the text is centered in the view." ^centered! mask "Answer an instance of class Form that is to be used as the mask when displaying the receiver's model (a DisplayText)." mask == nil ifTrue: [^self defaultMask] ifFalse: [^mask]! mask: aForm "Set aForm to be the mask used when displaying the receiver's model." mask _ aForm! rule "Answer a number from 0 to 15 that indicates which of the sixteen display rules is to be used when blting the receiver's model (a DisplayText) onto the display screen." rule == nil ifTrue: [^self defaultRule] ifFalse: [^rule]! rule: anInteger "Set anInteger to be the rule used when displaying the receiver's model." rule _ anInteger! ! !DisplayTextView methodsFor: 'controller access'! defaultController "Answer a new instance of the default controller and set its paragraph for editing to be the text of the receiver." ^self defaultControllerClass newParagraph: editParagraph! defaultControllerClass "Answer the class of the default controller." ^ParagraphEditor! ! !DisplayTextView methodsFor: 'window access'! defaultWindow "Answer the rectangle that represents the window into which the receiver's text will display." ^((0@0 extent: editParagraph extent) expandBy: self paragraphInset) expandBy: self borderWidth! window: aWindow "Set the window for display to be the argument aWindow." super window: aWindow. self centerText! ! !DisplayTextView methodsFor: 'model access'! model: aDisplayText "Set the model of the receiver to be the argument aDisplayText." super model: aDisplayText. self editParagraph: aDisplayText asParagraph.! ! !DisplayTextView methodsFor: 'displaying'! display "Show the receiver's text model on the display screen." self isUnlocked ifTrue: [self positionText]. super display! displayView "Display the receiver on the display screen within its bounding rectangle." self clearInside. (self controller isKindOf: ParagraphEditor ) ifTrue: [controller changeParagraph: editParagraph]. self isCentered ifTrue: [editParagraph displayOn: Display transformation: self displayTransformation clippingBox: self insetDisplayBox fixedPoint: editParagraph boundingBox center] ifFalse: [editParagraph displayOn: Display]! ! !DisplayTextView methodsFor: 'deEmphasizing'! deEmphasizeView "Emphasize the receiver's image on the screen." (self controller isKindOf: ParagraphEditor) ifTrue: [controller deselect]! ! !DisplayTextView methodsFor: 'private'! centerText "Make the text of the receiver center within its bounding box." self isCentered ifTrue: [editParagraph align: editParagraph boundingBox center with: self getWindow center]! defaultMask "Answer the default mask for the receiver." ^Form black! defaultRule "Answer the default combination rule for the receiver." ^Form over! paragraphInset "Answer the amount to inset the paragraph from the border." ^6@0! positionText "Compose the text so that it displays centered within the clipping box of the receiver." | box | box _ self insetDisplayBox origin + self paragraphInset extent: editParagraph boundingBox extent. editParagraph recomposeIn: box clippingBox: box. self centerText! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayTextView class instanceVariableNames: ''! !DisplayTextView class methodsFor: 'examples'! example1 "Creates a passive view of some text on the screen." "DisplayTextView example1." | view | view_ self new model: 'this is a test of one line and the second line' asDisplayText. view translateBy: 100@100. view borderWidth: 2. view insideColor: Form white. view display. view release! example2 "Creates four passive views of some text on the screen with fat borders." "DisplayTextView example2." | view | view_ self new model: 'this is a test of one line and the second line' asDisplayText. view translateBy: 100@100. view borderWidth: 5. view insideColor: Form white. view display. 3 timesRepeat: [view translateBy: 100@100. view display]. view release! ! ParseNode subclass: #Encoder instanceVariableNames: 'scopeTable nTemps supered requestor class literalStream selectorSet litIndSet litSet sourceRanges ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! Encoder comment: 'I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger. scopeTable is a dictionary of (names->nodes) nTemps is the count of temporaries used so far supered is true if super has been used in this method requestor is usually a parser class is the class in which we are compiling - used to look up class and pool variables literalStream accumulates the literals used in this method selectorSet is a dictionary of (selectors->nodes) predefined or used in this method litIndSet is a dictionary of (poolVars->nodes) used in this method litSet is a dictionary of (constants->nodes) used in this method sourceRanges is a dictionary of (node->source interval)s'! !Encoder methodsFor: 'initialize-release'! fillDict: dict with: nodeClass mapping: keys to: codeArray | codeStream | codeStream _ ReadStream on: codeArray. keys do: [:key | dict at: key put: (nodeClass new name: key key: key code: codeStream next)]! init: aClass context: aContext notifying: req | node n homeNode indexNode | requestor _ req. class _ aClass. nTemps _ 0. supered _ false. self initScopeAndLiteralTables. n _ -1. class allInstVarNames do: [:variable | node _ VariableNode new name: variable index: (n _ n + 1) type: LdInstType. scopeTable at: variable put: node]. aContext == nil ifFalse: [homeNode _ self bindTemp: 'homeContext'. "first temp = aContext passed as arg" n _ 0. aContext tempNames do: [:variable | indexNode _ self encodeLiteral: (n _ n + 1). node _ MessageNode new receiver: homeNode selector: #tempAt: arguments: (Array with: indexNode) precedence: 3 from: self. scopeTable at: variable put: node]]. sourceRanges _ Dictionary new: 32! initScopeAndLiteralTables scopeTable _ StdVariables copy. litSet _ StdLiterals copy. selectorSet _ StdSelectors copy. litIndSet _ Dictionary new: 16. literalStream _ WriteStream on: (Array new: 32)! noteSuper supered _ true! nTemps: n literals: lits class: cl "Decompile" class _ cl. nTemps _ n. literalStream _ ReadStream on: lits. literalStream position: lits size! release requestor _ nil! ! !Encoder methodsFor: 'encoding'! cantStoreInto: varName ^ StdVariables includesKey: varName! encodeLiteral: object ^self name: object key: object class: LiteralNode type: LdLitType set: litSet! encodeSelector: selector ^self name: selector key: selector class: SelectorNode type: SendType set: selectorSet! encodeVariable: name ^scopeTable at: name ifAbsent: [self lookupInPools: name ifFound: [:assoc | ^ self global: assoc name: name]. requestor editor notNil ifTrue: [self undeclared: name] ifFalse: [self declareUndeclared: name]]! litIndex: literal | p | p _ literalStream position. literalStream nextPut: literal. ^p! ! !Encoder methodsFor: 'temporaries'! autoBind: name "Declare a block argument as a temp if not already declared" | node | node _ scopeTable at: name ifAbsent: [(self lookupInPools: name ifFound: [:assoc]) ifTrue: [self notify: 'Name already used in a Pool or Global']. ^self reallyBindTemp: name]. node isTemp ifFalse: [^self notify: 'Name already used in this class']. ^node! bindTemp: name "Declare a temporary; error not if a field or class variable." (scopeTable includesKey: name) ifTrue: [^self notify: 'Name is already defined']. ^self reallyBindTemp: name! maxTemp ^nTemps! newTemp: name nTemps _ nTemps + 1. ^VariableNode new name: name index: nTemps - 1 type: LdTempType! reallyBindTemp: name "private; assumes name not in scope yet" | node | node _ self newTemp: name. scopeTable at: name put: node. ^node! ! !Encoder methodsFor: 'results'! associationFor: aClass | name | name _ Smalltalk keyAtValue: aClass ifAbsent: [^Association new value: aClass]. ^Smalltalk associationAt: name! associationForClass ^self associationFor: class! literals: primitive nArgs: nArgs primitive == 0 ifTrue: [nArgs > 4 ifTrue: [self litIndex: nArgs * 256. self litIndex: (self associationForClass)] ifFalse: [supered ifTrue: [self litIndex: (self associationForClass)]]] ifFalse: [primitive > 0 ifTrue: [self litIndex: nArgs * 256 + primitive] ifFalse: [self litIndex: 16r2000 + (nArgs * 256) - primitive]. self litIndex: (self associationForClass)]. ^literalStream contents! supered ^supered! tempNames | tempNodes | tempNodes _ (scopeTable values select: [:node | node isTemp]) asSortedCollection: [:n1 :n2 | n1 code <= n2 code]. ^