'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]. ^tempNodes collect: [:node | node key]! ! !Encoder methodsFor: 'error handling'! abort | req | requestor == nil ifFalse: [req _ requestor. self release. req abort]. ^false! notify: string | req | requestor == nil ifFalse: [req _ requestor. self release. req notify: string]. ^false! ! !Encoder methodsFor: 'source mapping'! noteSourceRange: range forNode: node sourceRanges at: node put: range! sourceMap: numLits "Answer with a sorted set of associations (pc . range). Delta is the difference between the parsed number of literals (startpc) and the generated number of literals." | delta | delta _ (numLits - literalStream position) * CompiledMethod bytesPerLiteral. ^(sourceRanges keys collect: [:key | Association key: key pc + delta value: (sourceRanges at: key)]) asSortedCollection! ! !Encoder methodsFor: 'undeclared variables'! declareClassVar: name | sym | name first isUppercase ifFalse: [self notify: 'Capitalize globals or classVars']. sym _ name asSymbol. class addClassVarName: sym. Smalltalk changes changeClass: class. ^ self global: (class classPool associationAt: sym) name: sym! declareCorrect: name "Attempt to correct the spelling of an undeclared variable." | old lc names score bestScore guess | old _ name. lc _ old first asLowercase. names _ (scopeTable keys select: [:key | key first asLowercase = lc]). names addAll: (class allVarNamesSelect: [:key | key first asLowercase = lc]). bestScore _ 0. names do: [:aName | (score _ aName spellAgainst: old) > bestScore ifTrue: [bestScore _ score. guess _ aName]]. bestScore > 50 ifFalse: [^ self notify: 'Couldn''t correct']. (self confirm: 'Confirm correction to ' , guess) ifTrue: [requestor replaceEditSelectionWith: guess. ^ self encodeVariable: guess] ifFalse: [^ self notify: 'Undeclared']! declareFailed: name self abort! declareGlobal: name | sym | name first isUppercase ifFalse: [self notify: 'Capitalize globals or classVars']. sym _ name asSymbol. Smalltalk at: sym put: nil. ^ self global: (Smalltalk associationAt: sym) name: sym! declareTemp: name requestor pasteTemp: name. ^ self reallyBindTemp: name! declareUndeclared: name | sym | sym _ name asSymbol. (Undeclared includesKey: name asSymbol) ifFalse: [Transcript show: ' (' , name , ' is Undeclared) '. Undeclared at: sym put: nil]. ^ self global: (Undeclared associationAt: sym) name: sym! undeclared: name | menu index | Cursor normal show. requestor selectVariable: name. index _ (menu _ ActionMenu labels: 'temp\class var\global\undeclared\correct it\abort' withCRs lines: #(4) selectors: #(declareTemp: declareClassVar: declareGlobal: declareUndeclared: declareCorrect: declareFailed:)) startUp: #anyButton withHeading: ' declare ' asText , (name contractTo: 20) asText allBold , ' as ' asText. index = 0 ifTrue: [^ self declareFailed: name]. ^ self perform: (menu selectorAt: index) with: name! ! !Encoder methodsFor: 'private'! global: ref name: name ^self name: name key: ref class: VariableNode type: LdLitIndType set: litIndSet! lookupInPools: name ifFound: assocBlock Symbol hasInterned: name ifTrue: [:sym | ^class scopeHas: sym ifTrue: assocBlock]. ^false! name: name key: key class: leafNodeClass type: type set: dict | node | ^dict at: key ifAbsent: [node _ leafNodeClass new name: name key: key index: nil type: type. dict at: key put: node. ^node]! ! Model subclass: #Explainer instanceVariableNames: 'class selector instance context methodText ' classVariableNames: 'NewLine ' poolDictionaries: '' category: 'Interface-Support'! Explainer comment: 'An Explainer tries to determine what a piece of text represents, usually in the context of a method. Instance Variables: class a class name or class variable name or pool variable name selector a message name instance context methodText Class Variables: NewLine '! !Explainer methodsFor: 'explaining'! class: aClass selector: aSymbol instance: anInstance context: aContext methodText: aText class _ aClass. selector _ aSymbol. instance _ anInstance. context _ aContext. methodText _ aText! explain: selection for: model "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." | string tiVars cgVars selectors delimitors numbers symbol reply | selection isEmpty ifTrue: [^ '"Please select a single token, construct, or special character."']. Cursor execute showWhile: [string _ self explainScan: selection. "Remove space, tab, cr" "Temps and Instance vars need only test strings that are all letters" (string detect: [:char | (char isLetter or: [char isDigit]) not] ifNone: []) ~~ nil ifFalse: [tiVars _ self explainTemp: string. tiVars == nil ifTrue: [tiVars _ self explainInst: string]]. (tiVars == nil) ifTrue: [tiVars _ model explainSpecial: string]. tiVars == nil ifTrue: [tiVars _ ''] ifFalse: [tiVars _ tiVars , NewLine]. "Context, Class, Pool, and Global vars, and Selectors need only test symbols" (Symbol hasInterned: string ifTrue: [:sym | symbol _ sym]) ifTrue: [cgVars _ self explainCtxt: symbol. cgVars == nil ifTrue: [cgVars _ self explainClass: symbol. cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]]. "See if it is a Selector (sent here or not)" selectors _ self explainMySel: symbol. selectors == nil ifTrue: [selectors _ self explainPartSel: string. selectors == nil ifTrue: [selectors _ self explainAnySel: symbol]]] ifFalse: [selectors _ self explainPartSel: string]. cgVars == nil ifTrue: [cgVars _ ''] ifFalse: [cgVars _ cgVars , NewLine]. selectors == nil ifTrue: [selectors _ ''] ifFalse: [selectors _ selectors , NewLine]. string size = 1 ifTrue: ["single special characters" delimitors _ self explainChar: string] ifFalse: ["matched delimitors" delimitors _ self explainDelimitor: string]. numbers _ self explainNumber: string. numbers == nil ifTrue: [numbers _ '']. delimitors == nil ifTrue: [delimitors _ '']. reply _ tiVars , cgVars , selectors , delimitors , numbers]. reply size = 0 ifTrue: [^ '"Sorry, I can''t explain that."']. ^ reply! explainAnySel: symbol "Is this any message selector?" | list reply | list _ Smalltalk allClassesImplementing: symbol. list size = 0 ifTrue: [^nil]. list size < 12 ifTrue: [reply _ ' is a message selector which is defined in these classes ' , list printString] ifFalse: [reply _ ' is a message selector which is defined in many classes']. ^'"' , symbol , reply , '."', NewLine, 'Smalltalk browseAllImplementorsOf: #' , symbol! explainChar: string "Does string start with a special character?" | char | char _ string at: 1. char = $. ifTrue: [^'"Period marks the end of a Smalltalk statement. A period in the middle of a number means a decimal point. (The number is an instance of Float). A period in the middle of a selector means a compound selector. (To the left is the superclass, to the right is the selector)."']. char = $' ifTrue: [^'"The characters between two single quotes are made into an instance of class String"']. char = $" ifTrue: [^'"Double quotes enclose a comment. Smalltalk ignores everything between double quotes."']. char = $# ifTrue: [^'"The characters following a hash mark are made into an instance of class Symbol. If parenthesis follow a hash mark, an instance of class Array is made."']. (char = $( or: [char = $)]) ifTrue: [^'"Expressions enclosed in parenthesis are evaluated first"']. (char = $[ or: [char = $]]) ifTrue: [^'"The code inside square brackets is an unevaluated block of code. It becomes an instance of BlockContext and is usually passed as an argument."']. (char = $< or: [char = $>]) ifTrue: [^'" means that this method is usually preformed directly by the virtual machine. If this method is primitive, its Smalltalk code is executed only when the primitive fails."']. char = $^ ifTrue: [^'"Uparrow means return from this method. The value returned is the expression following the ^"']. char = $| ifTrue: [^'"Vertical bars enclose the names of the temporary variables used in this method. In a block, the vertical bar separates the argument names from the rest of the code."']. char = $_ ifTrue: [^'"Left arrow means assignment. The value of the expression after the left arrow is stored into the variable before it."']. char = $; ifTrue: [^'"Semicolon means cascading. The message after the semicolon is sent to the same object which received the message before the semicolon."']. char = $: ifTrue: [^'"A colon at the end of a keyword means that an argument is expected to follow. Methods which take more than one argument have selectors with more than one keyword. (One keyword, ending with a colon, appears before each argument).', NewLine, NewLine, 'A colon before a variable name just inside a block means that the block takes an agrument. (When the block is evaluated, the argument will be assigned to the variable whose name appears after the colon)."']. char = $$ ifTrue: [^'"The single character following a dollar sign is made into an instance of class Character"']. char = $- ifTrue: [^'"A minus sign in front of a number means a negative number."']. char = $e ifTrue: [^'"An e in the middle of a number means that the exponent follows."']. char = $r ifTrue: [^'"An r in the middle of a bunch of digits is an instance of Integer expressed in a certain radix. The digits before the r denote the base and the digits after it express a number in that base."']. char = Character space ifTrue: [^'"the space Character"']. char = Character tab ifTrue: [^'"the tab Character"']. char = Character cr ifTrue: [^'"the carriage return Character"']. ^nil! explainClass: symbol "Is symbol a class variable or a pool variable?" | reply classes | class == nil ifTrue: [^nil]. "no class is selected" classes _ ((class isKindOf: Metaclass) ifTrue: [class soleInstance] ifFalse: [class]) withAllSuperclasses. "class variables" reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name] ifNone: []) ~~ nil] ifNone: []. reply == nil ifFalse: [^'"is a class variable; defined in class ' , reply printString, '"', NewLine, 'Smalltalk browseAllCallsOn: (', reply printString, ' classPool associationAt: #', symbol, ').']. "pool variables" classes do: [:each | (each sharedPools detect: [:pool | (pool includesKey: symbol) and: [reply _ pool. true]] ifNone: []) ~~ nil]. reply == nil ifTrue: [(Undeclared includesKey: symbol) ifTrue: [reply _ Undeclared]]. reply == nil ifFalse: [classes _ WriteStream on: Array new. Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes nextPut: each]]. "Perhaps not print whole list of classes if too long. (unlikely)" ^'"is a pool variable from the pool ' , (Smalltalk keyAtValue: reply), ', which is used by the following classes ' , classes contents printString , '"', NewLine, 'Smalltalk browseAllCallsOn: (', (Smalltalk keyAtValue: reply) printString, ' associationAt: #', symbol, ').']. ^nil! explainCtxt: symbol "Is symbol a context variable?" | reply classes text | symbol = #nil ifTrue: [reply _ '"is a constant. It is the only instance of class UndefinedObject. nil is the initial value of all variables."']. symbol = #true ifTrue: [reply _ '"is a constant. It is the only instance of class True and is the receiver of many control messages."']. symbol = #false ifTrue: [reply _ '"is a constant. It is the only instance of class False and is the receiver of many control messages."']. class == nil ifTrue: [^nil]. "no message selected" symbol = #self ifTrue: [classes _ class withAllSubclasses. classes size > 12 ifTrue: [text _ class printString , ' or a subclass'] ifFalse: [classes _ classes printString. text _ 'one of these classes' , (classes copyFrom: 18 to: classes size )]. reply _ '"is the receiver of this message; an instance of ' , text , '"']. symbol = #super ifTrue: [reply _ '"is just like self. Messages to super are looked up in the superclass (' , class superclass printString , ')"']. symbol = #thisContext ifTrue: [reply _ '"is a context variable. It''s value is always the MethodContext which is executing this method."']. ^reply! explainDelimitor: string "Is string enclosed in delimitors?" | str | (string at: 1) isLetter ifTrue: [^nil]. "only special chars" (string first = string last) ifTrue: [^ self explainChar: (String with: string first)] ifFalse: [(string first = $( and: [string last = $)]) ifTrue: [^ self explainChar: (String with: string first)]. (string first = $[ and: [string last = $]]) ifTrue: [^ self explainChar: (String with: string first)]. (string first = $< and: [string last = $>]) ifTrue: [^ self explainChar: (String with: string first)]. (string first = $# and: [string last = $)]) ifTrue: [^'"An instance of class Array. The Numbers, Characters, or Symbols between the parenthesis are the elements of the Array."']. string first = $# ifTrue: [^'"An instance of class Symbol."']. (string first = $$ and: [string size = 2]) ifTrue: [^'"An instance of class Character. This one is the character ', (String with: string last), '."']. (string first = $:) ifTrue: [str _ (string copyFrom: 2 to: string size). (self explainTemp: str) ~~ nil ifTrue: [^'"An argument to this block will be bound to the temporary variable ', str, '."']]]. ^ nil! explainGlobal: symbol "Is symbol a global variable?" | reply classes | reply _ Smalltalk at: symbol ifAbsent: [^nil]. (reply isKindOf: Behavior) ifTrue: [^'"is a global variable. ' , symbol , ' is a class in category ', reply category, '."', NewLine, 'Browser newOnClass: ' , symbol , '.']. symbol == #Smalltalk ifTrue: [^'"is a global. Smalltalk is the only instance of SystemDictionary and holds all global variables."']. reply class == Dictionary ifTrue: [classes _ Set new. Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes add: each]]. classes _ classes printString. ^'"is a global variable. ' , symbol , ' is a Dictionary. It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"']. ^'"is a global variable. ' , symbol , ' is ' , reply printString , '"'! explainInst: string "Is string an instance variable of this class?" | classes | class == nil ifTrue: [^nil]. "no class is selected" classes _ class withAllSuperclasses. classes _ classes detect: [:each | (each instVarNames detect: [:name | name = string] ifNone: []) ~~ nil] ifNone: [^nil]. classes _ classes printString. ^ '"is an instance variable of the receiver; defined in class ' , classes , '"', NewLine , classes , ' browseAllAccessesTo: ''' , string , '''.'! explainMySel: symbol "Is symbol the selector of this method? Is it sent by this method? If not, then explain will call (explainPartSel:) to see if it is a fragment of a selector sent here. If not, explain will call (explainAnySel:) to catch any selector. " | lits classes | selector == nil ifTrue: [^nil]. "not in a message" classes _ Smalltalk allClassesImplementing: symbol. classes size > 12 ifTrue: [classes _ 'many classes'] ifFalse: [classes _ 'these classes ' , classes printString]. selector = symbol ifTrue: [^ '"' , symbol , ' is the selector of this very method!! It is defined in ', classes , '. To see the other definitions, go to the message list subview and use yellow button to select ''implementors''."'] ifFalse: [lits _ (class compiledMethodAt: selector) messages. (lits detect: [:each | each == symbol] ifNone: []) == nil ifTrue: [^nil]. ^ '"' , symbol , ' is a message selector which is defined in ', classes , '. To see the definitions, go to the message list subview and use yellow button to select ''messages''."'].! explainNumber: string "Is string a Number?" | strm c | (c _ string at: 1) isDigit ifFalse: [(c = $- and: [string size > 1]) ifFalse: [^nil]]. strm _ ReadStream on: string. c _ Number readFrom: strm. strm atEnd ifFalse: [^nil]. c printString = string ifTrue: [^'"' , string , ' is a ' , c class name , '"'] ifFalse: [^'"' , string , ' (= ' , c printString , ') is a ' , c class name , '"']! explainPartSel: string "Is this a fragment of a multiple-argument selector sent in this method?" | lits whole reply classes s | selector == nil ifTrue: [^nil]. "not in a message" string last == $: ifFalse: [^nil]. "Name of this method" lits _ Array with: selector. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifTrue: [reply _ ', which is the selector of this very method!!'. s _ '. To see the other definitions, go to the message list subview and use yellow button to select ''implementors''."'] ifFalse: ["Selectors called from this method" lits _ (class compiledMethodAt: selector) messages. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifFalse: [string = 'primitive:' ifTrue: [^self explainChar: '<'] ifFalse: [^nil]]. reply _ '.'. s _ '. To see the definitions, go to the message list subview and use yellow button to select ''messages''."']. classes _ Smalltalk allClassesImplementing: whole. classes size > 12 ifTrue: [classes _ 'many classes'] ifFalse: [classes _ 'these classes ' , classes printString]. ^ '"' , string , ' is one part of the message selector ' , whole, reply , ' It is defined in ' , classes , s! explainScan: string "remove beginning and trailing space, tab, cr" | c beg end | beg _ 1. end _ string size. [beg = end ifTrue: [^string copyFrom: 1 to: 1]. "if all blank, tell about the first" c _ string at: beg. c = Character space or: [c = Character tab or: [c = Character cr]]] whileTrue: [beg _ beg + 1]. [c _ string at: end. c = Character space or: [c = Character tab or: [c = Character cr]]] whileTrue: [end _ end - 1]. ^string copyFrom: beg to: end "Return purely visible characters"! explainTemp: string "Is string the name of a temporary variable (or block argument variable)?" | tempNames i reply methodNode method | selector == nil ifTrue: [^nil]. "no message is selected" tempNames _ class parserClass new parseArgsAndTemps: methodText notifying: nil. method _ class compiledMethodAt: selector. (i _ tempNames findFirst: [:each | each = string]) = 0 ifTrue: [ (method numTemps > tempNames size and: [Smalltalk frills]) ifTrue: ["It must be an undeclared block argument temporary" methodNode _ class compilerClass new parse: methodText in: class notifying: nil. tempNames _ methodNode tempNames] ifFalse: [^nil]]. (i _ tempNames findFirst: [:each | each = string]) > 0 ifTrue: [i > method numArgs ifTrue: [reply _ '"is a temporary variable in this method"'] ifFalse: [reply _ '"is an argument to this method"']]. ^reply! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Explainer class instanceVariableNames: ''! !Explainer class methodsFor: 'class initialization'! initialize "Explainer initialize" NewLine _ String with: Character cr! ! Explainer initialize! Object subclass: #ExternalPort instanceVariableNames: 'portNumber receiveBuffer receiveStream receiveSemaphore sendSemaphore ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Terminal'! ExternalPort comment: 'I am a connection to an external process or device.'! !ExternalPort methodsFor: 'intialize-release'! initializePort receiveBuffer _ ByteArray new: 1024. receiveSemaphore _ Semaphore new. sendSemaphore _ Semaphore new. Smalltalk addDependent: self! release receiveSemaphore == nil ifFalse: [receiveSemaphore terminateProcess]. sendSemaphore == nil ifFalse: [sendSemaphore terminateProcess]. Smalltalk removeDependent: self! ! !ExternalPort methodsFor: 'stream access'! atEnd ^receiveStream atEnd! isOpen ^(self readStatus: 2) ~= 0! next ^receiveStream next! stream ^receiveStream! ! !ExternalPort methodsFor: 'sending'! send: aBuffer startingAt: startIndex size: size signal: aSemaphore ^self primitiveFailed! sendBuffer: aString (self readStatus: 2) = 0 ifTrue: [^nil]. "Port is not open." self send: aString startingAt: 1 size: (aString size) signal: sendSemaphore. sendSemaphore wait! ! !ExternalPort methodsFor: 'receiving'! receiveBuffer | size status | (self readStatus: 2) = 0 ifTrue: [^nil]. "Port is not open." self receivePacket: receiveBuffer startingAt: 1 signal: receiveSemaphore. receiveSemaphore wait. size _ ((receiveBuffer at: 3) bitShift: 8) + (receiveBuffer at: 4). receiveStream _ ReadWriteStream on: receiveBuffer from: 5 to: (size + 4). status _ receiveBuffer at: 1. status = 1 ifTrue: [self changed: #externalPortSignal]. status = 2 ifTrue: [self changed: #externalPortOverflow]. status = 3 ifTrue: [self changed: #externalPortError]! receivePacket: aBuffer startingAt: startIndex signal: aSemaphore ^self primitiveFailed! ! !ExternalPort methodsFor: 'access primitives'! close self isOpen ifFalse: [^nil]. self closePort! closePort ^self primitiveFailed! open self initializePort. self writeStatus: 0 with: 1. self openPort! openPort ^self primitiveFailed! readStatus: index "Reads status or statistical information from a given port. Negative indices are reserved for implementation-dependent quantities and are not documented here. The defined indices and their meaning are as follows -- information that can be altered with writeStatus: is marked with a * 0* - minimum number of input bytes before signalling the receive semaphore 1* - alterable status bits: bit 0 - DTR bit 1 - local loopback (Not Available) bit 2 - RTS bit 3 - send BREAK other bits - reserved 2* - current line speed of the port (baud) 3* - transmission mode - 0=asynchronous, (Others Not Available) 4* - data flow control - 0=none, 1=XON/XOFF, 2=DTR/DSR, 3=RTS/CTS 5-9* - reserved 10 - non-zero if a receive is pending on this port 11 - read-only status bits: bit 0 - DCD (carrier detect) bit 1 - CTS (clear to send) bit 2 - break received (Not Available) bit 3 - DSR (data set ready) bit 4 - RI (ring) other bits - reserved 12 - maximum size for a send 13 - hardware data flow control status bit 0 - Receive data stoped bit 1 - Transmit data stoped 14-19 - reserved 20 - total number of bytes received through this port 21 - total number of bytes sent through this port 22 - total number of frames received (synchronous operation) 23 - total number of frames sent (synchronous operation) 24 - total number of received bytes discarded for lack of buffer space" ^self primitiveFailed! reset ^self primitiveFailed! writeStatus: index with: value "Write status with 'value' on a given port. Negative indices are reserved for implementation-dependent quantities and are not documented here. The defined indices and their meaning are as follows -- full documentation may be found un readStatus: 0 - minimum number of input bytes before signalling the receive semaphore 1 - alterable status bits: bit 0 - DTR bit 1 - local loopback (Not Available) bit 2 - RTS bit 3 - send BREAK other bits - reserved 2 - current line speed of the port (baud) 3 - transmission mode - 0=asynchronous, (Others Not Available) 4 - data flow control - 0=none, 1=XON/XOFF, 2=DTR/DSR, 3=RTS/CTS 5-9 - reserved" ^self primitiveFailed! ! !ExternalPort methodsFor: 'updating'! update: parameter "We might need to close down for a while or open back up" (parameter == #aboutToSnapshot or: [parameter == #aboutToSnapshotAndQuit or: [parameter == #aboutToSuspend or: [parameter == #aboutToQuit]]]) ifTrue: [self close. ^self changed: #closeBeforeSnapshot]. (parameter == #returnFromSnapshot or: [parameter == #returnFromSnapshotAndQuit or: [parameter == #returnFromSuspend or: [parameter == #finishedSnapshot]]]) ifTrue: [self reopen. ^self changed: #openAfterSnapshot].! ! !ExternalPort methodsFor: 'private'! reopen "used in dependency update" receiveBuffer _ ByteArray new: 1024. receiveSemaphore _ Semaphore new. sendSemaphore _ Semaphore new. self writeStatus: 0 with: 1. self openPort! setPortNumber: aPortNumber portNumber _ aPortNumber! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExternalPort class instanceVariableNames: ''! !ExternalPort class methodsFor: 'instance creation'! open: aNumber self subclassResponsibility! ! !ExternalPort class methodsFor: 'inquiries'! SerialHasShell "Return true if the system supports a shell co-process." ^false! SerialMaxPortNumber "Returns the maximum hardware port number." ^self primitiveFailed! ! ReadWriteStream subclass: #ExternalStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Files-Streams'! ExternalStream comment: 'Class ExternalStream represents an accessor for a sequence of objects that communicate to the outside world. The instances of subclasses can contain non-homogenous elements. Implementation of the class methods assumes streaming on a collection of binary, byte-sized elements; methods assume that a "word" consists of two-bytes. Its primary subclass is FileStream. Subclasses must implement nonhomogeneous positioning padTo: padTo:put: '! !ExternalStream methodsFor: 'accessing'! next: anInteger "Answer the next anInteger elements of the receiver's collection." "Must override the superclass's method because it uses self contents species, which might involve a large collection." | newArray | newArray _ collection species new: anInteger. 1 to: anInteger do: [:index | newArray at: index put: self next]. ^newArray! ! !ExternalStream methodsFor: 'nonhomogeneous positioning'! padTo: bsize "Pad (skip) to next boundary of bsize characters, and answer how many characters were skipped." self subclassResponsibility! padTo: bsize put: aCharacter "Pad using the argument, aCharacter, to the next boundary of bsize characters, and answer how many characters were written." self subclassResponsibility! padToNextWord "Make position even (on word boundary), answering the padding character if any." position even ifTrue: [^false] ifFalse: [^self next]! padToNextWordPut: char "Make position even on word boundary, writing the padding character, char, if necessary. Answer nil if already on a word boundary." position even ifTrue: [^nil] ifFalse: [^self nextPut: char]! skipWords: nWords "Position after nWords number of words." self skip: 2 * nWords! wordPosition "Answer the current position in words." ^self position / 2! wordPosition: wp "Set current position in words to be wp." self position: 2 * wp! ! !ExternalStream methodsFor: 'nonhomogeneous accessing'! nextLong "Read a 32-bit quantity from the input stream." | m1 m2 m3 m4 | m1 _ self next. m1 == nil ifTrue: [ ^false ]. m2 _ self next. m2 == nil ifTrue: [ ^false ]. m3 _ self next. m3 == nil ifTrue: [ ^false ]. m4 _ self next. m4 == nil ifTrue: [ ^false ]. ^(((m1 asInteger bitShift: 24) + (m2 asInteger bitShift: 16)) + (m3 asInteger bitShift: 8)) + m4 asInteger! nextLongPut: a32BitW "Write out a 32-bit integer as 32 bits." self nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF). self nextPut: ((a32BitW bitAnd: 16rFF0000) bitShift: -16). self nextPut: ((a32BitW bitAnd: 16rFF00) bitShift: -8). self nextPut: (a32BitW bitAnd: 16rFF). ^a32BitW! nextNumber: n "Answer the next n bytes as a positive Integer or LargePositiveInteger." | s | n <= 2 ifTrue: [s _ 0. n timesRepeat: [s _ s * 256 + self next]. ^s]. s _ LargePositiveInteger new: n. 1 to: n do: [:i | s at: n + 1 - i put: self next]. "reverse order of significance" ^s truncated! nextNumber: n put: v "Append to the receiver the argument, v, which is a positive SmallInteger or a LargePositiveInteger, as the next n bytes. Possibly pad with leading zeros." | vlen | vlen _ v digitLength. n < vlen ifTrue: [self error: 'number too big'] ifFalse: [n > vlen ifTrue: [self next: n - vlen put: 0]]. "pad beginning with 0's" vlen = 1 ifTrue: [self nextPut: v] ifFalse: [(vlen = 2 and: [v isMemberOf: SmallInteger]) ifTrue: [self nextWordPut: v] ifFalse: ["LargeInteger (assume pos, no negative convention)" 1 to: vlen do: [:i | self nextPut: (v at: vlen + 1 - i)]]]! nextSignedInteger "Answer the next two bytes from the receiver as a signed Integer." | returnValue | self atEnd ifTrue: [^false]. returnValue _ self next asInteger. self atEnd ifTrue: [^false]. (returnValue _ returnValue * 256 + self next asInteger) highBit = 16 ifTrue: [^returnValue - 65536 "16-bit negative 0"] ifFalse: [^returnValue].! nextString "Answer a new String read from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first two bytes encode the length. " | aString length | length _ self next. "first byte." length >= 192 ifTrue: [length _ length - 192 * 256 + self next]. aString _ String new: length. 1 to: length do: [:i | aString at: i put: self next asCharacter]. ^aString! nextStringPut: aString "Append the string, aString, to the receiver." | length | (length _ aString size) < 192 ifTrue: [self nextPut: length] ifFalse: [self nextPut: (length // 256 + 192). self nextPut: (length \\ 256)]. aString do: [:char | self nextPut: char asciiValue]. ^aString! nextWord "Answer the next two bytes from the receiver as an Integer." | high low | high _ self next. high==nil ifTrue: [^false]. low _ self next. low==nil ifTrue: [^false]. ^(high asInteger bitShift: 8) + low asInteger! nextWordPut: aWord "Append to the receiver an Integer as the next two bytes." self nextPut: ((aWord bitShift: -8) bitAnd: 255). self nextPut: (aWord bitAnd: 255). ^aWord! ! !ExternalStream methodsFor: 'positioning'! resetContents "Reset pointers so that can restart reading the collection over which the receiver streams." position _ 0. readLimit _ 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExternalStream class instanceVariableNames: ''! !ExternalStream class methodsFor: 'instance creation'! new "Answer a new instance of the receiver." ^self basicNew! ! Boolean subclass: #False instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! False comment: 'Class False describes the behavior of its sole instance, false'! !False methodsFor: 'logical operations'! & alternativeObject "Evaluating conjunction. Answer false since receiver is false." ^self! not "Negation -- answer true since the receiver is false." ^true! | aBoolean "Evaluating disjunction (OR) -- answer with the argument, aBoolean." ^aBoolean! ! !False methodsFor: 'controlling'! and: alternativeBlock "Nonevaluating conjunction -- answer with false since the receiver is false." ^self! ifFalse: alternativeBlock "Answer the value of alternativeBlock." "Execution does not actually reach here because the expression is compiled in-line." ^alternativeBlock value! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Answer the value of falseAlternativeBlock." "Execution does not actually reach here because the expression is compiled in-line." ^falseAlternativeBlock value! ifTrue: alternativeBlock "Since the condition is false, answer the value of the false alternative, which is nil." "Execution does not actually reach here because the expression is compiled in-line." ^nil! ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock "Answer the value of falseAlternativeBlock." "Execution does not actually reach here because the expression is compiled in-line." ^falseAlternativeBlock value! or: alternativeBlock "Nonevaluating disjunction -- answer value of alternativeBlock." ^alternativeBlock value! ! !False methodsFor: 'printing'! printOn: aStream "Print false." aStream nextPutAll: 'false'! ! Object subclass: #FileAccessor instanceVariableNames: 'handle name position buffer bufferSize binary bufferAmount fileSize bufferDirty currentBuffer lastBuffer ' classVariableNames: 'DefaultBufferSize TranslateCr TranslateLf TranslateScanner ' poolDictionaries: '' category: 'Files-Abstract'! FileAccessor comment: 'Class FileAccessor is an abstract class that represents a positionable buffered file to be used by class FileStream. Instances of class FileStream will share a buffer with instances of subclasses of FileAccessor. Instance Variables: handle open file handle. Nil when closed. name the file name. position the absolute file position where the next read or write will take place buffer the data buffer bufferSize the size of the data buffer binary determines whether the data is Byte or Character bufferAmount the amount of valid data in the buffer. important at end of file fileSize the absolute size of the file in bytes bufferDirty determines whether the buffer needs to be flushed currentBuffer the buffer location (aPosition // bufferSize) lastBuffer the buffer location of the last buffer in the file Class Variables: TranslateCr stop condition array for carriage return TranslateLf stop condition array for line feed TranslateScanner used for the fast swapping of carriage returns and line feeds.'! !FileAccessor methodsFor: 'initialize-release'! initialize "Initialize the receiver." bufferSize _ self defaultFileBufferSize. buffer _ String new: bufferSize. bufferAmount _ 0. bufferDirty _ false. binary _ false. position _ 0. fileSize _ 0. currentBuffer _ 0. lastBuffer _ 0! ! !FileAccessor methodsFor: 'accessing'! binary "Answer whether the receiver's data is byte or character." ^binary! binary: aBinaryFlag "Set data to be either byte or character." | newBuffer | aBinaryFlag == binary ifTrue: [^self]. binary _ aBinaryFlag. newBuffer _ (binary ifTrue: [ByteArray] ifFalse: [String]) new: buffer size. binary ifTrue: [newBuffer replaceFrom: 1 to: buffer size withString: buffer startingAt: 1] ifFalse: [newBuffer replaceFrom: 1 to: buffer size withByteArray: buffer startingAt: 1]. buffer _ newBuffer! buffer "Answer the data buffer." ^buffer! file "Answer the receiver." ^self! fileName "Answer the file name." ^name! fileName: aString "Set the file name." name _ aString! fullName "Answer the file name." ^name! name "Answer the file name." ^name! name: aString "Set the file name." name _ aString! ! !FileAccessor methodsFor: 'positioning'! position "Answer the position of where the next read or write will take place." ^position! position: anInteger "Set the buffer to the correct place and answer the offset within the buffer that corresponds to the position." |bufferNumber pos| bufferNumber _ anInteger // bufferSize. pos _ anInteger \\ bufferSize. bufferNumber = currentBuffer ifTrue: [^pos]. self flush. self setPosition: bufferNumber. self read. ^pos! setToEnd "Set the buffer to the last buffer in the file." currentBuffer = lastBuffer ifFalse: [self setPosition: lastBuffer. self read]! ! !FileAccessor methodsFor: 'buffering'! bufferAmount "Answer the position of the last valid data item in the buffer." ^bufferAmount! bufferChanged "Assert that the buffer's data has changed." bufferDirty _ true.! bufferSize "Answer the size of the data buffer." ^bufferSize! currentBufferPosition "Answer the absolute byte position of the current buffer." ^currentBuffer * bufferSize! firstDataPosition "Answer the first valid data position in the buffer." ^self bufferHeader! lastBuffer "Answer whether the receiver is positioned at the last buffer in the file." ^currentBuffer = lastBuffer! lastDataPosition "Answer the last valid data position in the buffer." ^bufferAmount! lastWriteablePosition "Answer the last valid position in the buffer that data may be written." ^bufferSize - self bufferTrailer! nextBuffer "Advance the receiver's buffer position." currentBuffer _ currentBuffer + 1.! postRead: aBuffer "Perform any cleanup after reading." binary ifFalse: [self convertLfToCrIn: aBuffer forLength: bufferAmount].! preWrite: aBuffer "Perform any cleanup before actually writing." (binary or: [self lineEndCR]) ifFalse: [self convertCrToLfIn: aBuffer forLength: bufferAmount].! ! !FileAccessor methodsFor: 'basic buffer locations'! bufferHeader "Answer the amount of header information in a buffer." ^0! bufferTrailer "Answer the amount of trailer information in a buffer." ^0! ! !FileAccessor methodsFor: 'reading'! read "Read in the next buffer if there is one to read and answer the position of the last valid character in the buffer." position = fileSize ifTrue: [^bufferAmount _ 0]. bufferAmount _ self read: bufferSize into: buffer. position _ position + bufferAmount. bufferDirty _ false. ^bufferAmount! ! !FileAccessor methodsFor: 'writing'! flush "Write the currentBuffer if it has been changed. Change position and return the amount written." | amountWritten | bufferDirty ifFalse: [^self]. self currentBufferPosition = position ifFalse: [self setPosition: currentBuffer]. amountWritten _ self write: bufferAmount from: buffer. bufferDirty _ false. position _ position + amountWritten. position > fileSize ifTrue: [self setFileSize]. ^amountWritten! flush: lastValidDataPosition "Flush the buffer if changed after making current the last valid data position." "This is important at the end of the file." bufferDirty ifFalse: [^false]. lastValidDataPosition == nil ifFalse: [bufferAmount _ bufferAmount max: (lastValidDataPosition min: bufferSize)]. self flush.! write "Write out the current buffer and update position. Keep fileSize current if at the end." | amountWritten| amountWritten _ self write: bufferAmount from: buffer. position _ position + amountWritten. bufferDirty _ false. position > fileSize ifTrue: [self setFileSize]. ^amountWritten! ! !FileAccessor methodsFor: 'file operations'! close "Close the file if open." handle == nil ifTrue: [^nil]. self flush. self closeFile. handle _ nil! open "Open the file and read in the first buffer if there is one." handle _ self openFile. position _ currentBuffer _ 0. self setFileSize > 0 ifTrue: [self read].! release "Close the file." self close! rename: newFileName "Change the name of the receiver to be newFileName." self directory rename: name newName: newFileName. self name: newFileName! reopen "Open file and read the current buffer." handle == nil ifFalse: [^false]. handle _ self openFile. self setFileSize > 0 ifTrue: [self setPosition: currentBuffer. self read]. ^true! shortenTo: aPosition "Shorten the file to the absolute byte position." handle == nil ifFalse: [^self shortenFileTo: aPosition]! size "Answer how many bytes the file contains." ^fileSize! ! !FileAccessor methodsFor: 'basic file operations'! closeFile "Close the file." ^SystemCall closeFile: handle! defaultFileBufferSize "Answer the default buffer size for the physical file." ^DefaultBufferSize! defaultFileBufferSize: newSize "Set the default buffer size for the physical file." ^DefaultBufferSize _ newSize! directory "Answer the directory in which the receiver resides." ^FileDirectory directoryFromName: name setFileName: [:nameBody]! fileSize "Answer the size of the physical file." ^SystemCall sizeOfFile: handle! flushToDisk "Put any internal information on the disk." "This is not required if running of a Unix System because Unix keeps the disk synchronized in the background." self lineEndCR ifTrue: [handle == nil ifFalse: [SystemCall flushToDisk: handle]]! openFile "Open the file." | canRead canWrite readWriteMode status bufSize newBuffer | status _ SystemCall statusForFileNamed: name. status == nil ifTrue: [^SystemCall openFile: name for: (SystemCall createIfAbsent bitOr: SystemCall readWriteMode)]. canRead _ status at: 5. canWrite _ (status at: 6) and: [(status at: 4 "directory" ) not]. readWriteMode _ canRead ifTrue: [canWrite ifTrue: [SystemCall readWriteMode] ifFalse: [SystemCall readMode]] ifFalse: [canWrite ifTrue: [SystemCall writeMode] ifFalse: [nil]]. readWriteMode == nil ifTrue: [^self error: name , ': permission denied']. bufSize _ status at: 7. (bufSize == bufferSize or: [bufSize == nil]) ifFalse: [newBuffer _ (binary ifTrue: [ByteArray] ifFalse: [String]) new: bufSize. currentBuffer _ currentBuffer * bufferSize // bufSize. buffer _ newBuffer. bufferSize _ bufSize. self defaultFileBufferSize: bufSize]. ^SystemCall openFile: name for: readWriteMode! read: amount into: aBuffer "Read from the physical file into aBuffer the number of characters specified by amount." |amountRead| amountRead _ SystemCall read: handle into: aBuffer amount: bufferSize. bufferAmount _ amountRead. self postRead: aBuffer. ^amountRead! setFilePositionTo: aPosition "Set the absolute position of the physical file." ^SystemCall setFile: handle toPosition: aPosition how: 0! shortenFileTo: aPosition "Shorten the physical file to an absolute length." ^SystemCall shortenFile: handle toPosition: aPosition! write: amount from: aBuffer "Write to the physical file from aBuffer the number of characters specified by amount." | amt| self preWrite: aBuffer. amt _ SystemCall write: handle from: aBuffer amount: amount. self postRead: aBuffer. ^amt! ! !FileAccessor methodsFor: 'private'! convertCrToLfIn: aString forLength: length "Change carrage returns to line feeds for length." |i size lf | length < 1 ifTrue: [^aString]. TranslateScanner destX: 0. TranslateScanner stopConditions: TranslateCr. i _ 1. size _ length. lf _ Character lf. [(TranslateScanner scanCharactersFrom: i to: size in: aString rightX: 1 stopConditions: TranslateCr displaying: false) == nil] whileFalse: [i _ TranslateScanner lastIndex. aString at: i put: lf. i _ i + 1]! convertLfToCrIn: aString forLength: length "Change line feeds to carrage returns for length." |i size cr | length < 1 ifTrue: [^aString]. TranslateScanner destX: 0. TranslateScanner stopConditions: TranslateLf. i _ 1. size _ length. cr _ Character cr. [(TranslateScanner scanCharactersFrom: i to: size in: aString rightX: 1 stopConditions: TranslateLf displaying: false) == nil] whileFalse: [i _ TranslateScanner lastIndex. aString at: i put: cr. i _ i + 1]! lineEndCR "Answer true if the end of line is a CR" ^true! setFileSize "Set the fileSize and lastBuffer instance variables." fileSize _ self fileSize. lastBuffer _ fileSize // bufferSize. ^fileSize! setPosition: aBufferNumber "Set the currentBuffer and position instance variables." currentBuffer _ aBufferNumber. position _ aBufferNumber * bufferSize. self setFilePositionTo: position. ^position! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileAccessor class instanceVariableNames: ''! !FileAccessor class methodsFor: 'class initialization'! initialize "Set up scanner for fast crToLf and lfToCr." "FileAccessor initialize" DefaultBufferSize _ 512. TranslateScanner _ CharacterScanner new. TranslateScanner xTable: (Array new: 257 withAll: 0). TranslateCr _ Array new: 258. TranslateCr at: (Character cr asciiValue + 1) put: #cr. TranslateLf _ Array new: 258. TranslateLf at: (Character lf asciiValue + 1) put: #lf.! ! !FileAccessor class methodsFor: 'instance creation'! new "Answer an initialized instance." ^super new initialize! ! FileAccessor initialize! Object subclass: #FileDirectory instanceVariableNames: 'directoryName ' classVariableNames: 'ExternalReferences ' poolDictionaries: '' category: 'Files-Abstract'! FileDirectory comment: 'A FileDirectory is uniquely identified by the device or server that it refers to. A FileDirectory is a collection of file names. Instance Variable: directoryName the path that identifies the FileDirectory to the operating system. Class Variables: ExternalReferences A collection of objects to be sent the message release upon quitting or snapshoting. Separator the character used to separate items in file paths'! !FileDirectory methodsFor: 'testing'! includesKey: fileName "Answer whether there is a file with the given name in the receiver. FileName is relative to the receiver." ^SystemCall existsFile: (self fullPathFor: fileName)! ! !FileDirectory methodsFor: 'accessing'! contents "Answer an OrderedCollection containing all of the files within the receiver." ^SystemCall directoryContentsFor: self fullName! fullName "Answer the full path name of the directory." ^directoryName! name "Answer the name of the directory." | separator i | separator _ self class separator. i _ directoryName size - 1. [i >= 1 and: [((directoryName at: i) == separator) not]] whileTrue: [i _ i - 1]. ^directoryName copyFrom: i + 1 to: directoryName size! requestFileName: message default: default version: versionType ifFail: failBlock "Prompt for a file name. Insist on an existing file if versionType = #old. Evaluate failBlock if none obtained." "(FileDirectory named: '' ) requestFileName: 'file:' default: '*.st' version: #any ifFail: [] " | fileName list menu index err list2| fileName _ default. [true] whileTrue: [fileName _ FillInTheBlank request: message initialAnswer: fileName. fileName isEmpty ifTrue: [^failBlock value]. ((fileName includes: $*) or: [fileName includes: $#]) ifTrue: [list _ self filesMatching: fileName. list2 _ list collect: [:name | (name findString: self fullName startingAt: 1) = 1 ifTrue: [name copyFrom: self fullName size + 1 to: name size] ifFalse: [name]] . menu _ PopUpMenu labelList: (Array with: list2 with: #('new pattern' 'abort')). index _ menu startUp: #anyButton withHeading: (list isEmpty ifTrue: [' No Matches '] ifFalse: ['Choose a file from ', self fullName, fileName]) asText. (index == 0 or: [index = (list size + 2)]) ifTrue: [^failBlock value]. index <= list size ifTrue: [^list at: index]] ifFalse: [(self includesKey: fileName) ifTrue: [^fileName]. versionType ~= #old ifTrue: [^fileName]. (self isLegalFileName: fileName) ifTrue: [err _ ' File not found: \ '] ifFalse: [err _ ' Illegal file name: \ ']. menu _ PopUpMenu labels: 'try again\abort' withCRs. (menu startUp: #anyButton withHeading: err withCRs , fileName , ' ') = 2 ifTrue: [^failBlock value]. fileName _ self fixFileName: fileName]]! size "Answer the number of files contained in the receiver." ^self contents size! ! !FileDirectory methodsFor: 'dictionary removing'! removeKey: fileName "Remove the file from the receiver." ^self removeKey: fileName ifAbsent: [self error: 'file not found: ' , fileName]! removeKey: fileName ifAbsent: failBlock "Remove the file from the receiver. If the file does not exist, evaluate the fail block. FileName is assumed to be local to the receiver." (self includesKey: fileName) ifFalse: [^failBlock value]. ^SystemCall removeFile: (self fullPathFor: fileName)! ! !FileDirectory methodsFor: 'file accessing'! checkName: aFileName fixErrors: aBoolean "Check a string aFileName for validity as a file name. If there are problems (e.g., illegal length or characters) and aBoolean is false, create an error; if there are problems and aBoolean is true, make the name legal (usually by truncating and/or tranforming characters) and answer the new name. Otherwise, answer the name. Default behavior is to get rid of ending period. Subclasses can do any kind of checking they want and answer either the name, or false if no good." aFileName isEmpty ifTrue: [aBoolean ifFalse: [self error: 'file name empty']]. aFileName last = $. ifTrue: [aBoolean ifFalse: [self error: 'file name ends in .']. ^aFileName copyFrom: 1 to: aFileName size - 1] ifFalse: [^aFileName]! filesMatching: aFilePattern "Answer an OrderedCollection of the files within the receiver that match the file name pattern given." | collection nameList patternStream directoryPattern subDirectoryPattern fullPathName | nameList _ self contents. patternStream _ ReadStream on: aFilePattern. directoryPattern _ patternStream upTo: self class separator. subDirectoryPattern _ patternStream upToEnd. collection _ OrderedCollection new. nameList do: [:name | (directoryPattern match: name ignoreCase: false) ifTrue: [fullPathName _ self fullPathFor: name. subDirectoryPattern = '' ifTrue: [collection add: fullPathName] ifFalse: [(self class isDirectory: fullPathName) ifTrue: [collection addAll: (self class filesMatching: fullPathName, self class separatorString ,subDirectoryPattern)]]]]. ^collection! fixFileName: fileName "Make the argument, fileName, a string, into a legal file name. fileName is assumed to be local to the receiver." ^fileName! isLegalFileName: fileName "Answer whether fileName is a legal file name." ^true! rename: oldName newName: newName "Rename the file oldName to be newName." ^SystemCall renameFile: (self fullPathFor: oldName) to: (self fullPathFor: newName)! ! !FileDirectory methodsFor: 'enumerating'! do: aBlock "Evaluate the block with each file in the receiver as an argument." self contents do: [:fileName | aBlock value: (FileStream fileNamed: (self fullPathFor: fileName))]! keysDo: aBlock "Evaluate aBlock for each of the receiver's keys." self contents do: [:fileName | aBlock value: fileName]! ! !FileDirectory methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." super printOn: aStream. aStream nextPutAll: ' named ' ; nextPutAll: self fullName! ! !FileDirectory methodsFor: 'private'! fullPathFor: fileName "Answer a full path name for the file whose local name is given." (self class name: fileName startsWith: self fullName) ifTrue: [^fileName] ifFalse: [^self fullName , fileName]! setNameFrom: aPathName "Set the name of the receiver." directoryName _ self class nameWithSeparator: aPathName! ! !FileDirectory methodsFor: 'constants'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileDirectory class instanceVariableNames: ''! !FileDirectory class methodsFor: 'class initialization'! initialize "Initialize the collection of external references." "FileDirectory initialize" self initializeExternalReferences! ! !FileDirectory class methodsFor: 'instance creation'! default "Answer the default file directory." ^self named: ''! directoryFromName: fullName setFileName: localNameBlock "Send the file directory and local name into the block localNameBlock." | nameArray directory | nameArray _ self nameAndDirectoryOf: (self fixFileName: fullName). directory _ self named: (nameArray at: 1). localNameBlock value: (nameArray at: 2). ^directory! forName: fullName setDirectoryAndNameIn: directoryAndNameBlock "Create an instance of me available within the scope of the block." | nameArray | nameArray _ self nameAndDirectoryOf: (self fixFileName: fullName). directoryAndNameBlock value: (self named: (nameArray at: 1)) value: (nameArray at: 2)! named: aPathName "Create an instance of me representing the directory whose path is aPathname." ^self new setNameFrom: (aPathName = '' ifTrue: [SystemCall currentWorkingDirectory] ifFalse: [aPathName])! ! !FileDirectory class methodsFor: 'external reference access'! addExternalReference: anElement "Add anElement as a file that is currently referenced in the system." (ExternalReferences includes: anElement) ifFalse: [ExternalReferences addLast: anElement]! initializeExternalReferences "ExternalReferences is an OrderedCollection of the files that are referenced in the system. Initialize this class variable." ExternalReferences _ OrderedCollection new! releaseExternalReferences "Remove and release all of the files referenced by the collection ExternalReferences." [ExternalReferences isEmpty] whileFalse: [ExternalReferences removeLast release]! removeExternalReference: anElement "Remove anElement as a file that is currently referenced in the system." ExternalReferences remove: anElement ifAbsent: []! ! !FileDirectory class methodsFor: 'utilities'! canReadFile: fileName "Answer true if the file can be read." (self includesKey: fileName) ifTrue: [^SystemCall canReadFile: fileName] ifFalse: [^false]! canWriteFile: fileName "Answer true if the file can be written." (self includesKey: fileName) ifTrue: [^(SystemCall canWriteFile: fileName) and: [(self isDirectory: fileName) not]] ifFalse: [^SystemCall canWriteFile: ((self nameAndDirectoryOf: fileName) at: 1)]! copyFileNamed: sourceName to: destName "Copy the file named sourceName to a file named destName." "FileDirectory copyFileNamed: 'sourceFileName' to: 'destFileName'" | buffer bufferSize sourceFile destFile sourceRead destWrite amountRead status| status _ SystemCall statusForFileNamed: sourceName. status == nil ifTrue: [self error: 'File does not exist.']. bufferSize _ status at: SystemCall preferredBufferSizeSlot. "Get preferred buffer size" buffer _ ByteArray new: bufferSize. sourceFile _ SystemCall openFile: sourceName for: SystemCall readMode. "Open sourceFile readOnly" destFile _ SystemCall createFile: destName. "Create the destFile" "set up system calls" sourceRead _ SystemCall default read: sourceFile into: buffer count: bufferSize. destWrite _ SystemCall default write: destFile from: buffer count: bufferSize. "Copy until we have a read that is less than buffer size" [(amountRead _ sourceRead value) = bufferSize] whileTrue: [destWrite value]. "Copy any thing left over" amountRead > 0 ifTrue: [(SystemCall default write: destFile from: buffer count: amountRead) value]. SystemCall closeFile: sourceFile. SystemCall closeFile: destFile.! filesMatching: aFilePattern "Answer an OrderedCollection of files whose names match the pattern given." | match| match _ self pathAndPattern: aFilePattern forSeparator: self separator. ^(self named: (match at: 1)) filesMatching: (match at: 2)! fixFileName: aFileName "Make the file name a valid file name." ^aFileName! includesKey: aFileName "Answer true if the file system contains a file with the given name." ^SystemCall existsFile: aFileName! isDirectory: fileName "Answer true if the file is a directory." ^SystemCall isDirectory: fileName! isLegalFileName: fileDesignator "Answer whether the specified file name is legal." "Example: FileDirectory isLegalFileName: 'someFileName' " self forName: fileDesignator setDirectoryAndNameIn: [:dir :localName | ^ dir isLegalFileName: localName]! removeKey: fileDesignator "Delete the specified file from its directory." "Example: FileDirectory removeKey: 'someFileName' " ^self removeKey: fileDesignator ifAbsent: [nil]! removeKey: fileDesignator ifAbsent: failBlock "Remove the specified file from its directory. If the file is not in the directory, then answer the result of evaluating failBlock. Otherwise, answer the fileDesignator." "For example: FileDirectory removeKey: 'someFileName' ifAbsent: [^nil]" (self includesKey: fileDesignator) ifFalse: [^failBlock value]. ^SystemCall removeFile: fileDesignator! requestFileName: message default: default version: versionType ifFail: failBlock "Prompt for a file name. Insist on an existing file if versionType = #old. Evaluate failBlock if none obtained." "FileDirectory requestFileName: 'file:' default: '*.st' version: #any ifFail: []" | fileName list menu index err list2 currentDir| fileName _ default. currentDir _ SystemCall currentWorkingDirectory , self separatorString. [true] whileTrue: [fileName _ FillInTheBlank request: message initialAnswer: fileName. fileName isEmpty ifTrue: [^failBlock value]. ((fileName includes: $*) or: [fileName includes: $#]) ifTrue: [list _ self filesMatching: fileName. list2 _ list collect: [:fname | (fname findString: currentDir startingAt: 1) = 1 ifTrue: [fname copyFrom: currentDir size + 1 to: fname size] ifFalse: [fname]] . menu _ PopUpMenu labelList: (Array with: list2 with: #('new pattern' 'abort')). index _ menu startUp: #anyButton withHeading: (list isEmpty ifTrue: [' No Matches '] ifFalse: ['Choose a file']) asText. (index == 0 or: [index = (list size + 2)]) ifTrue: [^failBlock value]. index <= list size ifTrue: [^list at: index]] ifFalse: [(self includesKey: fileName) ifTrue: [^fileName]. versionType ~= #old ifTrue: [^fileName]. (self isLegalFileName: fileName) ifTrue: [err _ ' File not found: \ '] ifFalse: [err _ ' Illegal file name: \ ']. menu _ PopUpMenu labels: 'try again\abort' withCRs. (menu startUp: #anyButton withHeading: err withCRs , fileName , ' ') = 2 ifTrue: [^failBlock value]. fileName _ self fixFileName: fileName]]! ! !FileDirectory class methodsFor: 'file creation'! fileAccessorNamed: aFileDesignator "Answer a file whose name is aFileDesignator." | file | file _ self defaultFileClass new. file name: aFileDesignator. ^file! ! !FileDirectory class methodsFor: 'constants'! defaultFileClass "Return the default file accessor class" ^FileAccessor! separator "Answer the character that is the separator in path names." ^self separatorString at: 1! separatorString "Answer the string that is the separator in path names." ^String with: $/! ! !FileDirectory class methodsFor: 'name parsing'! name: aName startsWith: aPath "Answer true if the file name aName starts with aPath." ^aName size >= aPath size and: [(aName copyFrom: 1 to: aPath size) = aPath]! nameWithSeparator: aNameString "Answer a file name with a path separator appended to the end." ^(aNameString at: aNameString size) ~= self separator ifTrue: [aNameString , self separatorString] ifFalse: [aNameString]! ! !FileDirectory class methodsFor: 'private'! nameAndDirectoryOf: fileName "Answer an array with the directory and file components of the given name." | separator i file directory| separator _ self separator. i _ fileName size. [i >= 1 and: [((fileName at: i) == separator) not]] whileTrue: [i _ i - 1]. directory _ fileName copyFrom: 1 to: i. file _ fileName copyFrom: i + 1 to: fileName size. directory = '' ifTrue: [directory _ self nameWithSeparator: SystemCall currentWorkingDirectory]. ^Array with: directory with: file! pathAndPattern: fileName forSeparator: separator "Answer an array with the directory and pattern components of the given name." | i lastSeparator char notFound len | fileName = '' ifTrue: [^Array with: '' with: '*']. lastSeparator _ 0. notFound _ true. i _ 1. len _ fileName size. [i <= len and: [notFound]] whileTrue: [ char _ fileName at: i. char == separator ifTrue: [lastSeparator _ i] ifFalse: [(char == $* or: [char == $#]) ifTrue: [ notFound _ false]]. i _ i + 1]. notFound ifTrue: [^Array with: fileName with: '']. lastSeparator > 0 ifTrue: [^Array with: (fileName copyFrom: 1 to: lastSeparator) with: (fileName copyFrom: lastSeparator + 1 to: len)] ifFalse: [^Array with: '' with: fileName]! ! FileDirectory initialize! FileModel subclass: #FileList instanceVariableNames: 'list myPattern isReading ' classVariableNames: 'DefaultPattern FileMenu PatternMenu ' poolDictionaries: '' category: 'Interface-File Model'! FileList comment: 'I am a FileModel that can be viewed as a filtered ListMenu of file names as well as the text of a file. Instance Variables: list of file names myPattern representing the filter to select the list'! !FileList methodsFor: 'pattern'! acceptPattern: aText from: aController "The text consists of file names and file name patterns separated by carriage returns. Patterns can include the characters * (any chars) and # (any single char). Make my new list be those file names on my directory which match the patterns." | testPattern readStream newList | Cursor execute showWhile: [self pattern: aText string. readStream _ ReadStream on: self pattern asString. newList _ SortedCollection new. [readStream atEnd] whileFalse: [testPattern _ readStream upTo: Character cr. "get next name/pattern" testPattern last = $. ifTrue: [testPattern _ testPattern copyFrom: 1 to: testPattern size-1]. (testPattern includes: $*) | (testPattern includes: $#) ifTrue: [newList addAll: (self filesMatching: testPattern)] ifFalse: [(self isLegalFileName: testPattern) ifTrue: [newList add: testPattern]]]. self list: newList. (list isEmpty and: [aController ~= nil]) ifTrue: [aController deselect; replaceSelectionWith: 'No matching files' asText; select]. self changed: #fileName]. ^true! pattern ^ myPattern! pattern: aString "Set a new pattern for me. Inform my dependents so that the labels for my views can be updated." myPattern _ aString asText. self changed: #newPattern! patternMenu "FileList flushMenus." PatternMenu == nil ifTrue: [PatternMenu _ ActionMenu labels: 'again\undo\copy\cut\paste\accept\cancel\volumes' withCRs lines: #(2 5 7) selectors: #(again undo copySelection cut paste accept cancel setVolume:from:)]. ^PatternMenu! setVolume: ignored from: aController | newVol | newVol _ SystemCall default getVolumes. newVol == nil ifFalse: [self acceptPattern: (newVol, FileDirectory separatorString, '*') asText from: aController. self changed: #pattern]! ! !FileList methodsFor: 'user protocol'! spawnFile: aText from: aController "Open a file editor that edits the current selection." |fileModel newController| fileModel _ FileModel new. fileModel setFileName: self nameOfSelection. newController _ aController copy. "Copy gets the changes" aController cancel; controlTerminate. "Cancel changes in spawning fileModel" FileModel open: fileModel named: self nameOfSelection withController: newController! ! !FileList methodsFor: 'file name list'! copyName "Put a copy of the current selections name in the text buffer." ParagraphEditor new copySelection: self nameOfSelection asText! deleteFile "Remove the selected file from its directory." | dir localName | dir _ FileDirectory directoryFromName: fileName setFileName: [:lname | localName _ lname]. (dir includesKey: localName) ifTrue: [(self confirm: 'really remove the selected file?') ifFalse: [^self]. dir removeKey: localName]. list remove: self nameOfSelection. self changed: #fileName.! fileListMenu "Answer the menu for my list subview." fileName == nil ifTrue: [^nil]. FileMenu == nil ifTrue: [FileMenu _ ActionMenu labels: 'get contents\file in\copy name\rename\remove\spawn' withCRs lines: #(2 4 5) selectors: #(getFile fileInFile copyName renameFile deleteFile spawnFileList)]. ^ FileMenu "Evaluate this when you change this method: FileList flushMenus"! fileName "Answer the current selection's file name." ^fileName! fileName: selection "Change the file selection. If the argument selection is not nil, it is the name of a file to be viewed." self setFileName: selection. isReading _ false. self changed: #text! fileNameList ^ list! getFile "Get the contents of the selected file." self changeRequest ifFalse: [^self]. isReading _ true. self changed: #text! isSelected "Answer true if a file is selected." ^isReading! nameOfSelection "Answer the name of the current selection." ^ fileName! renameFile "Rename the selected file. Prompt the user for a new name." | newList newName continue | fileName == nil ifTrue: [^nil]. self changeRequest ifFalse: [^nil]. continue _ true. [continue] whileTrue: [newName _ FillInTheBlank request: 'New name for file?' initialAnswer: self nameOfSelection. newName isEmpty ifTrue: [^nil]. newName last = $. ifTrue: [newName _ newName copyFrom: 1 to: newName size-1]. ((self isLegalFileName: newName) and: [(FileDirectory includesKey: newName) not]) ifTrue: [continue _ false] ifFalse: [(BinaryChoice message: 'File exists or bad file name. Try again?') ifFalse: [^nil]]]. Cursor execute showWhile: [newList _ list copyWithout: self nameOfSelection. SystemCall renameFile: fileName to: newName. newList add: newName. list _ newList. self changed: #fileName. self changed: #text]! spawnFileList "Open a FileList on the current selection." self class openOnFileNames: (Array with: self nameOfSelection) label: self nameOfSelection! ! !FileList methodsFor: 'text'! acceptText: aText from: aController "Update the contents of a new version of the file stream with the receiver's contents." Cursor write showWhile: [(FileStream fileNamed: fileName) nextPutAll: aText string; close]. ^true! text "Return the text for the selected file." isReading ifTrue: [^super text] ifFalse: [^'' asText]! ! !FileList methodsFor: 'list access'! list: aList "Set the list of files to be aList." list _ aList. isReading _ false! ! !FileList methodsFor: 'file accessing'! filesMatching: pattern "Answer a list of file names matching the pattern string. Do this by asking the appropriate directory." ^FileDirectory filesMatching: pattern! isLegalFileName: pattern "Answer whether pattern is a valid file name. Do this by asking the appropriate directory." ^FileDirectory isLegalFileName: pattern! setToRead isReading _ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileList class instanceVariableNames: ''! !FileList class methodsFor: 'instance creation'! open "Create and schedule a view of a new instance of me. For example, evaluate FileList open" ^self openOnPattern: self defaultPattern! openOnFileNames: aFileNameList label: labelString "Create and schedule a view of a new instance of me such that the instance references the files named in the argument, aFileNameList." | topView aFileList | aFileList _ self new list: aFileNameList. topView _ FileListView model: aFileList label: labelString minimumSize: 200 @ 200. topView addSubView: (SelectionInListView on: aFileList aspect: #fileName change: #fileName: list: #fileNameList menu: #fileListMenu initialSelection: nil) in: (0@0 extent: 1@0.3) borderWidth: 1. topView addSubView: (CodeView on: aFileList aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil) in: (0@0.3 extent: 1@0.7) borderWidth: 1. topView icon: (Icon constantNamed: #default). topView controller open! openOnPattern: aPattern "Create and schedule a view of a new instance of me with the using the pattern aPattern. For example, evaluate FileList openOnPattern: '*'" | topView aFileList patternView label| aFileList _ self new. aPattern = '' ifFalse: [Cursor read showWhile: [aFileList list: (SortedCollection new addAll: (aFileList filesMatching: aPattern))]. label _ 'File List on ', aPattern asString ] ifTrue: [label _ 'File List']. aFileList pattern: aPattern. topView _ FileListView model: aFileList label: label minimumSize: 200 @ 200. patternView _ CodeView on: aFileList aspect: #pattern change: #acceptPattern:from: menu: #patternMenu initialSelection: nil. topView addSubView: patternView in: (0@0 extent: 1@0.10) borderWidth: 1. patternView controller: AlwaysAcceptCodeController new. topView addSubView: (SelectionInListView on: aFileList aspect: #fileName change: #fileName: list: #fileNameList menu: #fileListMenu initialSelection: nil) in: (0@0.10 extent: 1@0.25) borderWidth: 1. topView addSubView: (OnlyWhenSelectedCodeView on: aFileList aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil selection: #isSelected) in: (0@0.35 extent: 1@0.65) borderWidth: 1. topView icon: (Icon constantNamed: #default). topView controller open! ! !FileList class methodsFor: 'default pattern access'! defaultPattern "Answer the default file pattern." DefaultPattern == nil ifTrue: [^''] ifFalse: [^DefaultPattern]! defaultPattern: aString "Set the default file pattern to be aString." "FileList defaultPattern: '*'" DefaultPattern _ aString! ! !FileList class methodsFor: 'class initialization'! flushMenus "Flush the menus that I hold onto." "FileList flushMenus." PatternMenu _ nil. FileMenu _ nil. super flushMenus! ! StandardSystemView subclass: #FileListView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-File Model'! !FileListView methodsFor: 'updating'! update: anAspect "See if the pattern has changed so that the label can change." anAspect = #newPattern ifTrue: [self deEmphasize. self newLabel: 'File List on ', (self stripPattern: model pattern). self emphasize]! ! !FileListView methodsFor: 'private'! stripPattern: aString "Answer a String that is the argument up to the first carriage return." | readStream | readStream _ ReadStream on: aString. ^readStream upTo: Character cr! ! Model subclass: #FileModel instanceVariableNames: 'fileName ' classVariableNames: 'TextMenu ' poolDictionaries: '' category: 'Interface-File Model'! FileModel comment: 'I represent an interface between a File and an editable view of it. As a StringHolder, the string is the contents of the File. Instance Variables: fileName The name of the file I am viewing.'! !FileModel methodsFor: 'text'! text | dir localName | fileName == nil ifTrue: [^nil]. dir _ FileDirectory directoryFromName: fileName setFileName: [:lname | localName _ lname]. (dir includesKey: localName) ifTrue: [ ^Cursor read showWhile: [(FileStream oldFileNamed: fileName) contentsOfEntireFile asText] ] ifFalse: [^'-new file-' asText emphasizeFrom: 2 to: 9 with: 3].! textMenu "FileModel flushMenus" fileName == nil ifTrue: [^ nil]. TextMenu == nil ifTrue: [TextMenu _ ActionMenu labelList: #((again undo) (copy cut paste) ('do it' 'print it' inspect) ('file it in') (put get ) (spawn)) selectors: #(again undo copySelection cut paste doIt printIt inspectIt fileItIn:from: accept getNew:from: spawnFile:from:)]. ^ TextMenu! ! !FileModel methodsFor: 'user protocol'! doItValue: ignored! fileInFile "Read the entire file as Smalltalk code." (FileStream oldFileNamed: fileName) fileIn.! fileItIn: fullText from: controller "Make a Stream on the text selection and fileIn it." | selection | selection _ controller selection. (ReadWriteStream on: selection from: 1 to: selection size) fileIn! getNew: ignoreText from: aController "Reinitialize the information the receiver models by re-reading the file stream." self changeRequest ifFalse: [^ aController view flash]. self changed: #text! spawnFile: aText from: aController | newController | newController _ aController copy. "Copy gets the changes" aController cancel; controlTerminate. "Cancel changes in spawning fileModel" self class open: self copy named: fileName withController: newController! ! !FileModel methodsFor: 'doIt/accept/explain'! acceptText: aText from: aController "Update the contents of the file stream with the receiver's contents." Cursor write showWhile: [(FileStream fileNamed: fileName) nextPutAll: aText string; close]. ^true! doItContext ^ nil! doItReceiver ^ nil! ! !FileModel methodsFor: 'private'! setFileName: fullFileName fileName _ fullFileName! setFileStream: aStream aStream release. "close, since later a new file stream will be created" fileName _ aStream file fullName! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileModel class instanceVariableNames: ''! !FileModel class methodsFor: 'instance creation'! fileStream: aFileStream "Answer an instance of me on the argument, aFileStream." ^self new setFileStream: aFileStream! open: aFileModel named: aString "Scheduled a view whose model is aFileModel and whose label is aString." | topView | topView _ StandardSystemView model: aFileModel label: aString minimumSize: 180 @ 180. topView addSubView: (CodeView on: aFileModel aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil) in: (0@0 extent: 1@1) borderWidth: 1. topView controller open! open: aFileModel named: aString withController: aController "Scheduled a FileModel view with changes made in another editor." | topView textView | topView _ StandardSystemView model: aFileModel label: aString minimumSize: 180 @ 180. textView _ CodeView on: aFileModel aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil. textView controller: aController. topView addSubView: textView in: (0@0 extent: 1@1) borderWidth: 1. topView controller open! ! !FileModel class methodsFor: 'initialization'! flushMenus TextMenu _ nil! ! ExternalStream subclass: #FileStream instanceVariableNames: 'fileAccessor rwmode closed ' classVariableNames: 'Read Shorten Write ' poolDictionaries: '' category: 'Files-Streams'! FileStream comment: 'FileStreams stream over a buffered file and simulate streaming over a contiguous collection. It uses the stream primitives next, nextPut: and atEnd. When position exceeds the readLimit or writeLimit, the stream primitives fail and the Smalltalk failure code gets the next buffer and resets position, readLimit and writeLimit. Instance Variables: fileAccessor the buffered file rwmode the modes are ReadOnly ReadWrite ReadWriteShorten WriteShorten closed true if closed. used to keep file streams open across snapshots Class Variables: Read mode constant Shorten mode constant Write mode constant '! !FileStream methodsFor: 'accessing'! contentsOfEntireFile "Answer the contents of the receiver." | s | self readOnly. self reset. s _ self next: self size. self close. ^s! next "Answer with the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive. " (position >= readLimit and: [self atEnd]) ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! next: anInteger "Answer the next anInteger elements of the receiver." | newCollection howManyRead increment | newCollection _ collection species new: anInteger. howManyRead _ 0. [howManyRead < anInteger] whileTrue: [ self atEnd ifTrue: [^newCollection]. increment _ (readLimit - position) min: (anInteger - howManyRead). newCollection replaceFrom: (howManyRead + 1) to: (howManyRead _ howManyRead + increment) with: collection startingAt: (position + 1). position _ position + increment. ]. ^newCollection! nextPut: aByte "Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. writeLimit may be set to nil for the first write to fail" self writing ifFalse: [^self error: 'no writing allowed!!' ]. closed ifTrue: [self reopen]. writeLimit == nil ifTrue: [writeLimit _ fileAccessor lastWriteablePosition. fileAccessor bufferChanged]. position < writeLimit ifTrue: [^collection at: (position _ position + 1) put: aByte]. self fetchNextBuffer. writeLimit _ fileAccessor lastWriteablePosition. fileAccessor bufferChanged. ^collection at: (position _ position + 1) put: aByte! nextPutAll: aCollection "Append the elements of aCollection onto the receiver. Answer aCollection." | howManyWritten increment collectionSize | collectionSize _ aCollection size. ((collectionSize < 10) or: [(aCollection class == String) or: [(aCollection class == ByteArray) or: [aCollection class == Symbol]]]) ifFalse: [^super nextPutAll: aCollection]. self writing ifFalse: [^self error: 'no writing allowed!!']. closed ifTrue: [self reopen]. writeLimit == nil ifTrue: [writeLimit _ fileAccessor lastWriteablePosition]. position >= writeLimit ifTrue: [self fetchNextBuffer. writeLimit _ fileAccessor lastWriteablePosition]. howManyWritten _ 0. [increment _ (writeLimit - position) min: (collectionSize - howManyWritten). collection replaceFrom: position + 1 to: (position _ position + increment) with: aCollection startingAt: howManyWritten + 1. fileAccessor bufferChanged. howManyWritten _ howManyWritten + increment. howManyWritten < collectionSize] whileTrue: [self fetchNextBuffer. writeLimit _ fileAccessor lastWriteablePosition. ]. ^aCollection! size "Answer the size of the file the receiver streams over." | size | closed ifTrue: [self reopen]. size _ fileAccessor size. fileAccessor lastBuffer ifFalse: [^size]. self fixEnd. ^fileAccessor currentBufferPosition + readLimit! ! !FileStream methodsFor: 'testing'! atEnd "Answer true if the position is greater than or equal to the limit, otherwise answer false. " ^self basicAtEnd and: [self endTest]! ! !FileStream methodsFor: 'nonhomogeneous positioning'! padTo: bsize "Pad (skip) to next boundary of bsize characters, and answer how many characters were skipped." | rem | rem _ bsize - (self position \\ bsize). rem = bsize ifTrue: [^0]. self skip: rem. ^rem! padTo: bsize put: aCharacter "Pad using the argument, aCharacter, to the next boundary of bsize characters, and answer how many characters were written." | rem | rem _ bsize - (self position \\ bsize). rem = bsize ifTrue: [^0]. self next: rem put: aCharacter. ^rem! ! !FileStream methodsFor: 'positioning'! position "Answer my position." ^fileAccessor currentBufferPosition + position! position: anIndex "Set position to anInteger as long as anInteger is within the bounds of the receiver's contents. If it is not, provide an error notification." self skip: anIndex - self position! reset "Set my position to the beginning of the file." closed ifTrue: [self reopen]. self writing ifTrue: [self flush]. fileAccessor position: 0. readLimit _ fileAccessor lastDataPosition. position _ fileAccessor firstDataPosition! setToEnd "Set the position to the end of the file." closed ifTrue: [self reopen]. self writing ifTrue: [self flush]. fileAccessor setToEnd. position _ readLimit _ fileAccessor lastDataPosition! skip: n "Reposition to the relative number n." | pos oldPos| n = 0 ifTrue: [^self]. closed ifTrue: [oldPos _ self position. self reopen. oldPos = self position ifFalse: [self setPosition: oldPos]]. pos _ position + n. (pos >= 0 and: [pos <= collection size]) ifTrue: [n < 0 ifTrue: [self fixEnd. position _ pos] ifFalse: [position _ pos. self fixEnd]] ifFalse: [self setPosition: self position + n]! ! !FileStream methodsFor: 'editing'! edit "Create and schedule a FileView of the contents of the receiver. The label of the view is the name of the receiver. " FileModel open: (FileModel fileStream: self) named: fileAccessor fullName! ! !FileStream methodsFor: 'file accessing'! directory "Answer the directory in which the receiver resides." ^fileAccessor directory! file "Answer the FileAccessor that I am streaming over." ^fileAccessor! fileName "Answer the name of the file being streamed over." ^fileAccessor fullName! fullName "Answer the name of the file being streamed over." ^fileAccessor fullName! name "Answer the name of the file being streamed over." ^fileAccessor fullName! rename: newFileName "Change the name of the receiver to be newFileName." fileAccessor rename: newFileName! ! !FileStream methodsFor: 'file modes'! binary "Set the receiver's file to be binary mode." fileAccessor binary: true. collection _ fileAccessor buffer! readOnly "Set the receiver's mode so that pages are not flushed and reading stops at end of file." self setMode: Read! readWrite "Set the receiver's mode so that pages are flushed, end of file can be extended by writing, and closing does not truncate file." self setMode: Read + Write! readWriteShorten "Same as readWrite except close truncates file at current position." self setMode: Read + Write + Shorten! text "Set the receiver's file to be in text mode." fileAccessor binary: false. collection _ fileAccessor buffer.! writeShorten "Allow write and shorten the receiver's file upon closing." self setMode: Write + Shorten! ! !FileStream methodsFor: 'file testing'! closed "Answer the status of the file--false if open, true otherwise." ^closed! writing "Answer whether it is possible to write on the receiver." ^(rwmode bitAnd: Write) = Write! ! !FileStream methodsFor: 'file status'! close "Set the receiver's file status to closed." closed ifFalse: [self writing ifTrue: [(rwmode bitAnd: Shorten) = Shorten ifTrue: [self shorten] ifFalse: [self flush]]. closed _ true. readLimit _ 0. writeLimit _ nil. fileAccessor close. FileDirectory removeExternalReference: self]! flush "If writeLimit is non nil the where was writing. Fix the readLimit and flush the fileAccessor buffer. Set writeLimit to nil so that we may be sure the buffer is marked changed." writeLimit == nil ifFalse: [self fixEnd. fileAccessor flush: readLimit. writeLimit _ nil]! release "Set the receiver's status to closed, if it is not already, and do not allow any further reading or writing." closed ifFalse: [closed _ true. self writing ifTrue: [self flush]. readLimit _ 0. writeLimit _ nil. fileAccessor release]! reopen "Set the receiver's file to be open again, setting the position to its previous position. Create an error if the file can not be reopened." fileAccessor reopen. closed _ false. collection _ fileAccessor buffer. self setPosition: self position. FileDirectory addExternalReference: self. writeLimit _ nil! ! !FileStream methodsFor: 'fileIn/Out'! fileIn "File in the contents of the receiver." Transcript refresh; cr; cr; show: 'Filing in from:'; crtab; show: self name; cr. self readOnly. ^super fileIn! fileOutChanges "Append to the receiver a description of all system changes." Transcript refresh; cr; cr; show: ('Filing out changes on:'); crtab; show: self name. super fileOutChanges! fileOutProjectStatistics "Write the current changeSet in the form of a report." Cursor write showWhile: [Project putStatsOn: self. self close]! printOutChanges "Print out a description of all system changes." self fileOutChanges! ! !FileStream methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." super printOn: aStream. aStream nextPutAll: ' on '. self fileName printOn: aStream! ! !FileStream methodsFor: 'private'! basicAtEnd "Answer true if the position is greater than or equal to the limit, otherwise answer false. Fail if position or readLimit is not a SmallInteger. Optional. See Object documentation whatIsAPrimitive. Normally called atEnd but renamed since I must do special teating in atEnd" ^true! endTest "Answer true if the receiver is at the end of the file. If not get the next buffer. Used by atEnd" closed ifTrue: [self reopen]. position < readLimit ifTrue: [^false]. (fileAccessor lastBuffer or: [self nextBuffer not]) ifTrue: [^true]. ^position = readLimit! fetchNextBuffer "Read the next data buffer if there is one." "Used by nextPut: to cover the case that we are writing and not at the end of the file." self writing ifTrue: [self flush]. fileAccessor nextBuffer. fileAccessor read. readLimit _ fileAccessor lastDataPosition. position _ fileAccessor firstDataPosition.! fixEnd "Set new read limit if writing has moved position past the read limit." position > readLimit ifTrue: [readLimit _ position]! nextBuffer "Read the next buffer and Answer true if there was any data." "Used by endTest" self writing ifTrue: [self flush]. fileAccessor nextBuffer. fileAccessor read. readLimit _fileAccessor lastDataPosition. position _ fileAccessor firstDataPosition. ^readLimit > 0! on: aFileAccessor "Initialize the receiver on aFileCollection." "Set writeLimit to nil so we can fail on first write to set buffer changed." rwmode _ Read + Write + Shorten. fileAccessor _ aFileAccessor. closed _ true. position _ 0. readLimit _ 0. writeLimit _ nil.! setMode: m "Set the mode and flush if changing from Write to ReadOnly." rwmode = m "don't flush if first time or not write mode or continuing write mode" ifFalse: [((rwmode bitAnd: Write) = 0 or: [(m bitAnd: Write) = Write]) ifTrue: [rwmode _ m] ifFalse: [self flush. fileAccessor flushToDisk. rwmode _ m]]! setPosition: anIndex "Reposition the receiver to a new position." anIndex < 0 ifTrue: [^self error: 'attempt to position to a negative number' ]. closed ifTrue: [self reopen]. self writing ifTrue: [self flush]. position _ fileAccessor position: anIndex. readLimit _ fileAccessor lastDataPosition.! shorten "Shorten the file." "Normally called by close and not directly by user." self writing ifTrue: [self flush]. fileAccessor shortenTo: self position. readLimit _ position.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileStream class instanceVariableNames: ''! !FileStream class methodsFor: 'class initialization'! initialize "Initialize important constants." "FileStream initialize" Read _ 1. Write _ 2. Shorten _ 4! ! !FileStream class methodsFor: 'instance creation'! fileNamed: fileDesignator "Answer a new instance of the receiver on an old or new File designated by the string fileDesignator." ^self open: fileDesignator! newFileNamed: aFileDesignator "Answer an instance of the reciever on the file whose name is given in the file designator. If the file exists, delete it." FileDirectory removeKey: aFileDesignator. ^self open: aFileDesignator! oldFileNamed: aFileDesignator "Answer an instance of the receiveer on the file whose name is given in the file designator. Provide an error notification if the file does not exist." (FileDirectory includesKey: aFileDesignator) ifFalse: [self error: 'file does not exist']. ^self open: aFileDesignator! on: aFileAccessor "Answer a new instance of the receiver initialized to stream over aFileAccessor. " ^self new on: aFileAccessor! ! !FileStream class methodsFor: 'private'! open: aFileDesignator "Open a fileStream on a file whose name is aFileDesignator." ^self on: (FileDirectory fileAccessorNamed: aFileDesignator)! ! FileStream initialize! StringHolder subclass: #FillInTheBlank instanceVariableNames: 'actionBlock actionTaken ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Prompt/Confirm'! FillInTheBlank comment: 'I represent a request for information that will be applied as the argument of a block of actions. Instance Variables actionBlock actionTaken whether the actonBlock has been evaluated at least once '! !FillInTheBlank methodsFor: 'initialize-release'! initialize super initialize. actionTaken _ false! ! !FillInTheBlank methodsFor: 'accessing'! action: aBlock "The argument, aBlock, will be evaluated when the receiver is sent the message selectAction." actionBlock _ aBlock! actionTaken ^actionTaken! setAction: aBoolean actionTaken _ aBoolean! ! !FillInTheBlank methodsFor: 'menu messages'! selectAction "Evaluate the receiver's assigned action block, if any, with the answer as the block argument." actionBlock notNil ifTrue: [actionBlock value: contents]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FillInTheBlank class instanceVariableNames: ''! !FillInTheBlank class methodsFor: 'instance creation'! action: aBlock initialAnswer: aString "Answer an instance of me whose action is aBlock and initial action argument is aString." | newBlank | newBlank _ self new initialize. newBlank action: aBlock. newBlank contents: aString. ^newBlank! message: messageString displayAt: aPoint centered: centered action: aBlock initialAnswer: aString "Answer an instance of me whose question is messageString. Once the user provides an answer, then evaluate aBlock. If centered, a Boolean, is false, display the view of the instance at aPoint; otherwise display it with its center at aPoint. " | newBlank | newBlank _ self new initialize. newBlank action: aBlock. newBlank contents: aString. FillInTheBlankView openOn: newBlank message: messageString displayAt: aPoint centered: centered! request: messageString "Create an instance of me whose question is messageString. Display it centered around the cursor. Simply return whatever the user accepts." ^self request: messageString initialAnswer: ''! request: messageString displayAt: aPoint centered: centered action: aBlock initialAnswer: aString ^self request: messageString displayAt: aPoint centered: centered action: aBlock initialAnswer: aString useCRController: true! request: messageString displayAt: aPoint centered: centered action: aBlock initialAnswer: aString useCRController: useCRController "Answer an instance of me whose question is messageString. Once the user provides an answer, then evaluate aBlock. If centered, a Boolean, is false, display the view of the instance at aPoint; otherwise display it with its center at aPoint. " | newBlank fillInView savedArea | newBlank _ self new initialize. newBlank action: aBlock. newBlank contents: aString. fillInView _ FillInTheBlankView on: newBlank message: messageString displayAt: aPoint centered: centered useCRController: useCRController. savedArea _ Form fromDisplay: fillInView displayBox. fillInView display. fillInView controller centerCursorInView. fillInView controller startUp. fillInView release. savedArea displayOn: Display at: fillInView viewport topLeft! request: messageString initialAnswer: aString "Create an instance of me whose question is messageString. Display it centered around the cursor. Supply aString as an initial answer. Simply return whatever the user accepts." | response | self request: messageString displayAt: Sensor cursorPoint centered: true action: [:resp | response _ resp] initialAnswer: aString. ^response! ! !FillInTheBlank class methodsFor: 'examples'! example1 "Example waits for you to click red button somewhere on the screen. The view will show where you point. Terminate by choosing menu command accept." FillInTheBlank message: 'What is your name?' displayAt: Sensor waitButton centered: true action: [:answer | Transcript cr; show: answer] initialAnswer: '' "FillInTheBlank example1."! example2 "Example waits for you to click red button somewhere on the screen. The view will show where you point. Terminate by choosing menu command accept or typing carriage return." FillInTheBlank request: 'What is your name?' displayAt: Sensor waitButton centered: true action: [:answer | Transcript cr; show: answer] initialAnswer: '' "FillInTheBlank example2."! example3 "Try this example by choosing menu command print it" ^Text fromUser "FillInTheBlank example3."! ! StringHolderController subclass: #FillInTheBlankController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Prompt/Confirm'! FillInTheBlankController comment: 'I am a StringHolderController for a FillInTheBlankView. The string is information that the user can type in and edit. Upon issuing the accept command, this information is used by my model in the evaluation of an action block.'! !FillInTheBlankController methodsFor: 'basic control sequence'! controlTerminate | topController | super controlTerminate. model actionTaken ifFalse: [^self]. topController _ view topView controller. (topController notNil & (topController isKindOf: StandardSystemController)) ifTrue: [topController close]. model selectAction! ! !FillInTheBlankController methodsFor: 'control defaults'! isControlActive model actionTaken ifTrue: [^false]. ^super isControlActive! isControlWanted model actionTaken ifTrue: [^false]. ^super isControlActive! ! !FillInTheBlankController methodsFor: 'menu messages'! accept super accept. model setAction: true! ! !FillInTheBlankController methodsFor: 'initialize-release'! resetState "intercept to force selection of entire text" super resetState. stopBlock stringIndex: paragraph text size + 1! ! !FillInTheBlankController methodsFor: 'marker adjustment'! updateMarker "Do not redisplay marker" ^self computeMarkerRegion! ! !FillInTheBlankController methodsFor: 'private'! initializeYellowButtonMenu self yellowButtonMenu: (PopUpMenu labels: 'again\undo\copy\cut\paste\accept\cancel' withCRs lines: #(2 5)) yellowButtonMessages: #(again undo copySelection cut paste accept cancel)! ! StringHolderView subclass: #FillInTheBlankView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Prompt/Confirm'! FillInTheBlankView comment: 'I am a view of a FillInTheBlank--I display a query and an area in which the user can type some information.'! !FillInTheBlankView methodsFor: 'controller access'! defaultControllerClass ^FillInTheBlankController! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FillInTheBlankView class instanceVariableNames: ''! !FillInTheBlankView class methodsFor: 'instance creation'! on: aFillInTheBlank message: messageString displayAt: originPoint centered: centered "Answer an instance of me on the model aFillInTheBlank 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." ^self on: aFillInTheBlank message: messageString displayAt: originPoint centered: centered useCRController: true! on: aFillInTheBlank message: messageString displayAt: originPoint centered: centered useCRController: useCRController | topView messageView answerView | messageView _ self buildMessageView: messageString. answerView _ self buildAnswerView: aFillInTheBlank frameWidth: messageView window width. useCRController ifTrue: [answerView controller: CRFillInTheBlankController new]. topView _ View new model: aFillInTheBlank. topView controller: BinaryChoiceController new. topView addSubView: messageView. topView addSubView: answerView below: messageView. topView align: (centered ifTrue: [topView viewport center] ifFalse: [topView viewport topLeft]) with: originPoint. topView window: (0 @ 0 extent: messageView window width @ (messageView window height + answerView window height)). topView translateBy: (topView displayBox amountToTranslateWithin: Display boundingBox). ^topView! openOn: aFillInTheBlank message: messageString displayAt: originPoint centered: centered "Create and schedule an instance of me that displays aFillInTheBlank 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. Do not schedule, rather take control immediately and insist that the user respond." | topView messageView answerView | messageView _ self buildMessageView: messageString. answerView _ self buildAnswerView: aFillInTheBlank frameWidth: messageView window width. topView _ StandardSystemView new model: aFillInTheBlank. topView addSubView: messageView. topView addSubView: answerView below: messageView. topView align: (centered ifTrue: [topView viewport center] ifFalse: [topView viewport topLeft]) with: originPoint. topView label: 'Type a response'. topView window: (0@0 extent: messageView window width @ (messageView window height + 40)). topView controller openDisplayAt: originPoint! ! !FillInTheBlankView class methodsFor: 'private'! buildAnswerView: aFillInTheBlank frameWidth: widthInteger | answerView | answerView _ self new model: aFillInTheBlank. answerView window: (0@0 extent: widthInteger @ 40). answerView borderWidth: 2. ^answerView! buildMessageView: messageString | messageView | messageView _ DisplayTextView new editParagraph: messageString asParagraph. messageView borderWidthLeft: 2 right: 2 top: 2 bottom: 0. messageView insideColor: Form white. messageView controller: NoController new. messageView window: (0@0 extent: (messageView window extent max: 200@30)). messageView centered. ^messageView! ! Number variableWordSubclass: #Float instanceVariableNames: '' classVariableNames: 'ExpPCoefficients ExpQCoefficients Fourthpi Halfpi Ln2 LnCoefficients Pi RadiansPerDegree SinCoefficients Sqrt2 TanCoefficients Twopi ' poolDictionaries: '' category: 'Numeric-Numbers'! Float comment: 'Instances of the class Float represent floating-point numbers in IEEE 32-bit format. These floating-point numbers are good for about 8 or 9 digits of accuracy, and the range is between plus and minus 10^32. Here are some valid floating-point examples: 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 The format consists mainly of no imbedded blanks, little e for tens power, and a digit on both sides of the decimal point. Instance Variables: *word indexed* Class Variables: ExpPCoefficients (28.8756 2525.04 ) in computing the exponential ExpQCoefficients (1.0 375.022 7285.73 ) in computing the exponential Fourthpi 0.785398 Halfpi 1.5708 Ln2 0.693147 LnCoefficients (0.237625 0.285254 0.400006 0.666667 2.0 ) in computing natural log Pi 3.14159 RadiansPerDegree 0.0174533 SinCoefficients (-0.166667 0.00833333 -1.98409e-4 2.7526e-6 -2.39e-8 ) Sqrt2 1.41421 the square root of 2 TanCoefficients (0.333331 0.133392 0.0533741 0.0245651 0.00290052 0.00951681 ) in computing ratio of the sine to the cosine Twopi 6.28318 '! !Float methodsFor: 'arithmetic'! * aNumber "Answer a Float that is the result of multiplying the receiver by the argument, aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^self retry: #* coercing: aNumber! + aNumber "Answer a Float that is the result of adding the receiver to the argument. Fail if the argument is not a Float, or if overflow occurs. Essential. See Object documentation whatIsAPrimitive." ^self retry: #+ coercing: aNumber! - aNumber "Answer a Float that is the difference between the receiver and aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^self retry: #- coercing: aNumber! / aNumber "Answer a Float that is the exact result of dividing the receiver by the argument, anInteger. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." aNumber = 0 ifTrue: [self error: 'attempt to divide by zero'] ifFalse: [^self retry: #/ coercing: aNumber]! negated "Answer a Float that is the negation of the receiver." ^0.0 - self! ! !Float methodsFor: 'mathematical functions'! arcCos "Answer the angle in radians." ^Halfpi - self arcSin! arcSin "Answer the angle in radians." self abs > 1.0 ifTrue: [self error: 'Value out of range']. self abs = 1.0 ifTrue: [^Halfpi] ifFalse: [^(self / (1.0 - (self * self)) sqrt) arcTan]! arcTan "Answer the angle in radians." | theta term y eps i | self = 1.0 ifTrue: [^Fourthpi]. self = -1.0 ifTrue: [^Fourthpi negated]. self * self > 1.0 ifTrue: [theta _ Halfpi. y _ -1.0 / (self * self). term _ -1.0 / self abs] ifFalse: [theta _ 0.0. y _ 0.0 - (self * self). term _ self abs]. i _ 1. eps _ 1.0e-4. [term abs > eps] whileTrue: [theta _ theta + term. term _ term * y * i asFloat / (i + 2) asFloat. i _ i + 2]. ^self sign asFloat * theta! cos "Answer the cosine of the receiver in radians." self < 0.0 ifTrue: [^(self + Halfpi) sin]. ^(Halfpi - self) sin! exp "See Computer Approximations, pp. 96-104, p. 205 (EXPB 1065)" | n1 x x2 P Q index len | self abs > 9212.0 ifTrue: ["Float maxVal ln" "1.0 exp" self error: 'exp overflow'] ifFalse: [x _ self / Ln2. n1 _ 2.0 raisedTo: x truncated. (x _ x - x truncated) >= 0.5 ifTrue: [n1 _ n1 * Sqrt2. x _ x - 0.5]. x2 _ x * x. "compute 2.0 power: x" P _ Q _ 0.0. index _ 0. len _ ExpPCoefficients size. [(index _ index + 1) <= len] whileTrue: [P _ P * x2 + (ExpPCoefficients at: index)]. index _ 0. len _ ExpQCoefficients size. [(index _ index + 1) <= len] whileTrue: [Q _ Q * x2 + (ExpQCoefficients at: index)]. ^n1 * (Q + (x * P) / (Q - (x * P)))]! floorLog: radix "Answer with a (quick) computation of (self log: radix) floor." | x | self < radix ifTrue: [^0]. "self assumed positive" (self / radix) < radix ifTrue: [^1]. x _ 2 * (self floorLog: radix* radix). "binary recursion like ipow" ^x + (self / (radix raisedTo: x) floorLog: radix)! ln "See Computer Approximations, pp. 105-111, p. 227 (LOGE 2663)" | expt x x2 n P index len| self <= 0.0 ifTrue: [self error: 'ln not valid for ' , self printString] ifFalse: [expt _ self exponent. n _ Ln2 * (expt - 0.5). "mantissa between 0.5 and 1.0" x _ self timesTwoPower: 0 - expt. x _ x * Sqrt2. x _ x - 1.0 / (x + 1.0). x2 _ x * x. P _ 0.0. index _ 0. len _ LnCoefficients size. [(index _ index + 1) <= len] whileTrue: [P _ P * x2 + (LnCoefficients at: index)]. ^n + (x * P)] "2.718284 ln 1.0"! log "Answer with base 10 logarithm." ^self ln / 10.0 ln! sin "Answers with the sine of the receiver in radians." | x x2 sum index len| "normalize to 0<=self<=(Pi/2)" self < 0.0 ifTrue: [^self negated sin negated]. self > Twopi ifTrue: [^(self \\ Twopi) sin]. self > Pi ifTrue: [^(self - Pi) sin negated]. self > Halfpi ifTrue: [^(Pi - self) sin]. sum _ x _ self. x2 _ x * x. index _ 0. len _ SinCoefficients size. [(index _ index + 1) <= len] whileTrue: [sum _ (SinCoefficients at: index) * (x _ x * x2) + sum]. ^sum! sqrt "Answer the square root of the receiver." | guess i| self <= 0.0 ifTrue: [self = 0.0 ifTrue: [^0.0] ifFalse: [^self error: 'sqrt invalid for x < 0']]. "copy and halve the exponent for first guess" guess _ self timesTwoPower: 0 - (self exponent // 2). i _ 1. [i <= 5 ] whileTrue: [guess _ ((self / guess) - guess) * 0.5 + guess. i _ i + 1]. ^guess! tan "Answer the ratio of the sine to cosine of the receiver in radians." | x x2 sum index len| "normalize to 0<=self<=(Pi/4)" self < 0.0 ifTrue: [^self negated tan negated]. self > Pi ifTrue: [^(self \\ Pi) tan]. self > Halfpi ifTrue: [^(Pi - self) tan negated]. self > Fourthpi ifTrue: [^1.0 / (Halfpi - self) tan]. sum _ x _ self. x2 _ x * x. index _ 0. len _ TanCoefficients size. [(index _ index + 1) <= len] whileTrue: [sum _ (TanCoefficients at: index) * (x _ x * x2) + sum]. ^sum! ! !Float methodsFor: 'comparing'! < aNumber "Answer whether the receiver is less than the argument. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^self retry: #< coercing: aNumber! <= aNumber "Answer whether the receiver is less than or equal to the argument. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive." ^super <= aNumber! = aNumber "Answer whether the receiver is equal to the argument. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive. " ^self retry: #= coercing: aNumber! > aNumber "Answer whether the receiver is greater than the argument. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^self retry: #> coercing: aNumber! >= aNumber "Answer whether the receiver is greater than or equal to the argument. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive. " ^super >= aNumber! hash "Answer a SmallInteger unique to the receiver." ^(self basicAt: 1) bitAnd: 16383 "High bits as an Integer"! ~= aNumber "Answer whether the receiver is not equal to the argument. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive. " ^super ~= aNumber! ! !Float methodsFor: 'truncation and round off'! fractionPart "Answer a Float whose value is the difference between the receiver and the receiver's truncated value. Optional. See Object documentation whatIsAPrimitive." ^self - self truncated! integerPart "Answer a new Float whose value is the receiver's truncated value." ^self - self fractionPart! rounded "Answer the integer nearest the receiver." self >= 0.0 ifTrue: [^(self + 0.5) truncated] ifFalse: [^(self - 0.5) truncated]! truncated "Answer a SmallInteger equal to the value of the receiver without its fractional part. Fail if the truncated value cannot be represented as a SmallInteger. In that case, the code below will compute a LargeInteger truncated value. Essential. See Object documentation whatIsAPrimitive." ^(self quo: SmallInteger maxVal asFloat) * SmallInteger maxVal + (self rem: SmallInteger maxVal asFloat) truncated! ! !Float methodsFor: 'coercing'! coerce: aNumber "Answer a Float representing the argument, aNumber." ^aNumber asFloat! generality "Answer the number representing the ordering of the receiver in the generality hierarchy." ^80! ! !Float methodsFor: 'converting'! asFloat "Answer the receiver itself." ^self! asFraction "Answer a new Fraction representing the receiver. This conversion uses the continued fraction method to approximate a floating point number." | num1 denom1 num2 denom2 int frac newD temp | num1 _ self truncated. "The first of two alternating numerators" denom1 _ 1. "The first of two alternating denominators" num2 _ 1. "The second numerator" denom2 _ 0. "The second denominator--will update" int _ num1. "The integer part of self" frac _ self fractionPart. "The fractional part of self" [frac = 0] whileFalse: ["repeat while the fractional part is not zero" newD _ 1.0 / frac. "Take reciprocal of the fractional part" int _ newD truncated. "get the integer part of this" frac _ newD fractionPart. "and save the fractional part for next time" temp _ num2. "Get old numerator and save it" num2 _ num1. "Set second numerator to first" num1 _ num1 * int + temp. "Update first numerator" temp _ denom2. "Get old denominator and save it" denom2 _ denom1. "Set second denominator to first" denom1 _ int * denom1 + temp. "Update first denominator" 10000.0 < denom1 ifTrue: ["Is ratio past float precision? If so, pick which of the two ratios to use" num2 = 0.0 ifTrue: ["Is second denominator 0?" ^Fraction numerator: num1 denominator: denom1]. ^Fraction numerator: num2 denominator: denom2]]. "If fractional part is zero, return the first ratio" denom1 = 1 ifTrue: ["Am i really an Integer?" ^num1"Yes, return Integer result"] ifFalse: ["Otherwise return Fraction result" ^Fraction numerator: num1 denominator: denom1]! degreesToRadians "Answer the conversion to radians. The receiver is assumed to represent degrees." ^self * RadiansPerDegree! radiansToDegrees "Answer the conversion to degrees. The receiver is assumed to represent radians." ^self / RadiansPerDegree! ! !Float methodsFor: 'copying'! deepCopy "Answer a copy of the receiver." ^self copy! shallowCopy "Answer a copy of the receiver." ^self + 0.0! ! !Float methodsFor: 'printing'! isLiteral "Answer that the receiver has a literal text form recognized by the compiler." ^true! printOn: aStream "Append to the argument, aStream, a literal form of the receiver using 6 significant digits." self printOn: aStream digits: 6! ! !Float methodsFor: 'private'! absPrintOn: aStream digits: digits "Print on aStream the receiver using the argument, digits, as the number of significant figures." | fuzz x exp q i | "x is myself normalized to [1.0, 10.0), exp is my exponent" exp _ self < 1.0 ifTrue: [(10.0 / self floorLog: 10.0) negated] ifFalse: [self floorLog: 10.0]. x _ self / (10.0 raisedTo: exp) asFloat. fuzz _ (10.0 raisedTo: 1 - digits) asFloat. "round the last digit to be printed" x _ 0.5 * fuzz + x. x >= 10.0 ifTrue: ["check if rounding has unnormalized x" x _ x / 10.0. exp _ exp + 1]. (exp < 6 and: [exp > -4]) ifTrue: ["decimal notation" q _ 0. exp < 0 ifTrue: [1 to: 1 - exp do: [:j | aStream nextPut: ('0.0000' at: j)]]] ifFalse: ["scientific notation" q _ exp. exp _ 0]. [x >= fuzz] whileTrue: ["use fuzz to track significance" i _ x truncated. aStream nextPut: (Character value: (48 + i) ). x _ x - i asFloat * 10.0. fuzz _ fuzz * 10.0. exp _ exp - 1. exp = -1 ifTrue: [aStream nextPut: $.]]. [exp >= -1] whileTrue: [aStream nextPut: $0. exp _ exp - 1. exp = -1 ifTrue: [aStream nextPut: $.]]. q ~= 0 ifTrue: [aStream nextPut: $e. q printOn: aStream]! exponent "Answer the SmallInteger to whose power two is raised. Consider the receiver to be represented as a power of two multiplied by a mantissa (between one and two). Optional. See Object documentation whatIsAPrimitive." | positive | self >= 1.0 ifTrue: [^self floorLog: 2]. self > 0.0 ifTrue: [positive _ (1.0 / self) exponent. self = (1.0 / (1.0 timesTwoPower: positive)) ifTrue: [^positive negated] ifFalse: [^positive negated - 1]]. self = 0.0 ifTrue: [^-1]. ^self negated exponent! mantissa: nBits "Answer an Integer that is the most significant nBits of the mantissa of the receiver." ^(self abs timesTwoPower: nBits-self exponent-1) truncated! printOn: aStream digits: digits "Print the receiver on aStream using the argument, digits, as the number of significant figures." self > 0.0 ifTrue: [self absPrintOn: aStream digits: digits] ifFalse: [self = 0.0 ifTrue: [aStream nextPutAll: '0.0'] ifFalse: [aStream nextPutAll: '-'. self negated = 0.0 ifTrue: [aStream nextPutAll: '0.0'] ifFalse: [self negated absPrintOn: aStream digits: digits]]]! timesTwoPower: anInteger "Answer the receiver multiplied by 2.0 raised to the power of the argument. Optional. See Object documentation whatIsAPrimitive." ^self * (2.0 raisedToInteger: anInteger)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Float class instanceVariableNames: ''! !Float class methodsFor: 'class initialization'! initialize "Constants from Computer Approximations, pp. 182-183 Pi = 3.14159265358979323846264338327950288 Pi/2 = 1.57079632679489661923132169163975144 Pi/4 = 0.78539816339744830961566084581987572 Pi*2 = 6.28318530717958647692528676655900576 Pi/180 = 0.01745329251994329576923690768488612 2.0 ln = 0.69314718055994530941723212145817657 2.0 sqrt = 1.41421356237309504880168872420969808" "Float initialize." Pi _ 3.14159. Halfpi _ Pi / 2.0. Fourthpi _ Pi / 4.0. Twopi _ Pi * 2.0. RadiansPerDegree _ Pi / 180.0. Ln2 _ 0.693147. Sqrt2 _ 1.41421. SinCoefficients _ #(-0.166667 0.00833333 -1.98409e-4 2.7526e-6 -2.39e-8 ). TanCoefficients _ #(0.333331 0.133392 0.0533741 0.0245651 0.00290052 0.00951681 ). ExpPCoefficients _ #(28.8756 2525.04 ). ExpQCoefficients _ #(1.0 375.022 7285.73 ). LnCoefficients _ #(0.237625 0.285254 0.400006 0.666667 2.0 )! ! !Float class methodsFor: 'instance creation'! new "Fail since a Float can not be created using new." self error: 'Floats can only be created by performing arithmetic'! readFrom: aStream "Answer a new Float as described on the stream, aStream." ^(super readFrom: aStream) asFloat! ! !Float class methodsFor: 'constants'! pi "Answer the constant, Pi." ^Pi! ! Float initialize! DisplayMedium subclass: #Form instanceVariableNames: 'bits width height offset ' classVariableNames: 'OneBitForm ' poolDictionaries: '' category: 'Graphics-Display Objects'! Form comment: 'The class Form denotes a rectangular pattern of dots represented as a Smalltalk Bitmap. Instance Variables: bits in which the receiver''s bits are stored width width of the rectangle height height of the rectangle offset translation of the position of the pattern when displayed Class Variable: OneBitForm that is 1 bit wide and 1 bit high and is used as a constant in computations'! !Form methodsFor: 'initialize-release'! fromDisplay: aRectangle "Create a virtual bit map from a user specified rectangular area on the display screen. Reallocates bitmap only if aRectangle ~= the receiver's extent." (width = aRectangle width and: [height = aRectangle height]) ifFalse: [self extent: aRectangle extent]. self copyBits: (aRectangle origin extent: self extent) from: Display at: 0 @ 0 clippingBox: Display boundingBox rule: Form over mask: Form black! ! !Form methodsFor: 'accessing'! extent ^width@height! extent: aPoint "Create a virtual bit map with width = (extent x) and height = (extent y) with the bits all zeros (white). The extent is guaranteed to be zero or a positive size." | nonZeroExtent extentSize | nonZeroExtent _ aPoint >= (0 @ 0) ifTrue: [aPoint] ifFalse: [0 @ 0]. extentSize _ nonZeroExtent y * (nonZeroExtent x + 15 // 16). self extent: nonZeroExtent offset: 0 @ 0 bits: (WordArray new: extentSize)! extent: extentPoint offset: offsetPoint "Create a virtual bit map with width = (extent x) and height = (extent y) with the bits all zeros (white)." | normalizedPoint | normalizedPoint _ extentPoint >= (0 @ 0) ifTrue: [extentPoint] ifFalse: [0 @ 0]. self extent: normalizedPoint offset: offsetPoint bits: (WordArray new: normalizedPoint y * (normalizedPoint x + 15 // 16))! extent: extent offset: aPoint bits: aWordArray "Create a virtual bitmap with width = (extent x) and height = (extent y) with the bits = aWordArray." width _ extent x. height _ extent y. offset _ aPoint. bits _ aWordArray! height ^height! offset "Answer the offset of the receiver." offset == nil ifTrue: [^0 @ 0] ifFalse: [^offset]! offset: aPoint "Make the argument aPoint the receiver's offset." offset _ aPoint! size "Answer the number of bits in the receiver's bitmap." ^bits size! width ^width! ! !Form methodsFor: 'copying'! deepCopy "Answer a copy of the receiver with its own copy of each instance variable." | newForm | newForm _ self shallowCopy. newForm bits: (WordArray new: self size). newForm copyBits: self boundingBox from: self at: 0 @ 0 clippingBox: newForm boundingBox rule: Form over mask: Form black. ^newForm! ! !Form 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." (BitBlt destForm: self sourceForm: sourceForm halftoneForm: aForm combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: clipRect) copyBits! 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. " aDisplayMedium copyBits: self boundingBox from: self 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." "Graphically, it means nothing to scale a Form by floating point values. Because scales and other display parameters are kept in floating point to minimize round off errors, we are forced in this routine to round off to the nearest integer." | absolutePoint scale magnifiedForm | absolutePoint _ displayTransformation applyTo: relativePoint. absolutePoint _ absolutePoint x truncated @ absolutePoint y truncated. displayTransformation noScale ifTrue: [magnifiedForm _ self] ifFalse: [scale _ displayTransformation scale. scale _ scale x rounded @ scale y rounded. (1@1 = scale) ifTrue: [scale _ nil. magnifiedForm _ self] ifFalse: [magnifiedForm _ self magnifyBy: scale]]. magnifiedForm displayOn: aDisplayMedium at: absolutePoint - alignmentPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm! drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger mask: aForm "Affect a form, the receiver, by modifying its contents so as to effectively draw line starting at beginPoint (a position relative to the receiver) and ending at endPoint, according to the combination rule anInteger, masked by aForm and clipped by clipRect. Each position on the line is drawn with the form sourceForm." | dotSetter | dotSetter _ BitBlt destForm: self sourceForm: sourceForm halftoneForm: aForm combinationRule: anInteger destOrigin: beginPoint sourceOrigin: 0 @ 0 extent: sourceForm extent clipRect: clipRect. dotSetter drawFrom: beginPoint to: endPoint! ! !Form methodsFor: 'display box access'! boundingBox "Answer the minimum enclosing rectangle around the image." ^Rectangle origin: 0 @ 0 corner: width @ height! computeBoundingBox "Answer the minimum enclosing rectangle around the image." ^Rectangle origin: 0 @ 0 corner: width @ height! ! !Form methodsFor: 'pattern'! bits "Answer the receiver's bitmap containing its bits." ^bits! bits: aWordArray "Reset the bitmap containing the receiver's bits." bits _ aWordArray! valueAt: aPoint "Answer whether a bit is on or off: 1 if the color at coordinate aPoint is black in the receiver and 0 if the color is white." OneBitForm copyBits: (aPoint extent: 1 @ 1) from: self at: 0 @ 0 clippingBox: self boundingBox rule: Form over mask: Form black. (OneBitForm bits at: 1) = 0 ifTrue: [^0] ifFalse: [^1]! valueAt: aPoint put: maskCode "Set the bit in the receiver at coordinate aPoint to be white (0) or black (1)." maskCode = 0 ifTrue: [OneBitForm white] ifFalse: [OneBitForm black]. self copyBits: OneBitForm boundingBox from: OneBitForm at: aPoint clippingBox: self boundingBox rule: Form over mask: Form black.! ! !Form methodsFor: 'bordering'! borderWidth: anInteger "Set the width of the border for the receiver to be anInteger and paint it using Form black as the border color." self border: self boundingBox width: anInteger mask: Form black! borderWidth: anInteger mask: aMask "Set the width of the border for the receiver to be anInteger and paint it using aMask as the border color." self border: self boundingBox width: anInteger mask: aMask! ! !Form methodsFor: 'coloring'! fill: aRectangle rule: anInteger mask: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule anInteger." "Make up a BitBlt table and copy the bits" (BitBlt destForm: self sourceForm: nil halftoneForm: aForm combinationRule: anInteger destOrigin: aRectangle origin sourceOrigin: self boundingBox origin extent: aRectangle extent clipRect: self boundingBox) copyBits! ! !Form methodsFor: 'printing'! storeOn: aStream "Append to the argument aStream a description of the receiver in the form: Form extent:fromArray:#()offset:" "Some examples are | s | s_ WriteStream on: (String new: 2000). Form fromUser storeOn: s. (Compiler evaluate: s contents) displayAt: 0@0. | f | f _ FileStream fileNamed: 'screen.form'. Display storeOn: f. f close. " self storeOn: aStream base: 10! storeOn: aStream base: anInteger "Store the receiver out in the form: Form extent:fromArray:#()offset:" | theBits | aStream nextPut: $(. aStream nextPutAll: self species name. aStream crtab: 1. aStream nextPutAll: 'extent: '. self extent printOn: aStream. aStream crtab: 1. aStream nextPutAll: 'fromArray: #('. theBits _ self bits. 1 to: theBits size do: [:index | anInteger = 10 ifTrue: [aStream space] ifFalse: [aStream crtab: 2; nextPutAll: anInteger printString; nextPut: $r]. (theBits at: index) printOn: aStream base: anInteger]. aStream nextPut: $). aStream crtab: 1. aStream nextPutAll: 'offset: '. self offset printOn: aStream. aStream nextPut: $)! ! !Form methodsFor: 'image manipulation'! convexShapeFill: aMask "Fill the interior of the outtermost outlined region in the receiver. The outlined region must not be concave by more than 90 degrees." | destForm tempForm skew | destForm _ Form extent: self extent. tempForm _ Form extent: self extent. self displayOn: tempForm at: (0@0) - self offset. skew _ 1. [skew < width] whileTrue: [tempForm displayOn: tempForm at: skew@0 clippingBox: tempForm boundingBox rule: Form under mask: nil. skew _ skew+skew]. tempForm displayOn: destForm. self displayOn: tempForm at: (0@0) - self offset. skew _ 1. [skew < width] whileTrue: [tempForm displayOn: tempForm at: skew negated@0 clippingBox: tempForm boundingBox rule: Form under mask: nil. skew _ skew+skew]. tempForm displayOn: destForm at: 0@0 clippingBox: destForm boundingBox rule: Form and mask: nil. self displayOn: tempForm at: (0@0) - self offset. skew _ 1. [skew < height] whileTrue: [tempForm displayOn: tempForm at: 0@skew clippingBox: tempForm boundingBox rule: Form under mask: nil. skew _ skew+skew]. tempForm displayOn: destForm at: 0@0 clippingBox: destForm boundingBox rule: Form and mask: nil. self displayOn: tempForm at: (0@0) - self offset. skew _ 1. [skew < height] whileTrue: [tempForm displayOn: tempForm at: 0@skew negated clippingBox: tempForm boundingBox rule: Form under mask: nil. skew _ skew+skew]. tempForm displayOn: destForm at: 0@0 clippingBox: destForm boundingBox rule: Form and mask: nil. destForm displayOn: self at: 0@0 clippingBox: self boundingBox rule: Form over mask: aMask! copy: destRectangle from: sourcePt in: sourceForm rule: rule "Copy into the destination rectangle destRectangle that is within the receiver those bits in the form sourceForm starting at position sourcePt according the masking rule rule." "[Sensor redButtonPressed] whileFalse: [Display copy: (30@30 extent: 300@300) from: Sensor cursorPoint in: Display rule: Form over]." (BitBlt destForm: self sourceForm: sourceForm halftoneForm: nil combinationRule: rule destOrigin: destRectangle origin sourceOrigin: sourcePt extent: destRectangle extent clipRect: (0@0 extent: width@height)) copyBits! magnifyBy: scale "Answer a new form created as a multiple of the receiver; the new form is larger, each bit in the receiver being blown up to extent=scale." "Check consistency of shrink and magnify: [Sensor redButtonPressed] whileFalse: [(((Form fromDisplay: (Sensor cursorPoint extent: 50@50)) magnifyBy: 3@5) shrinkBy: 3@5) displayAt: 100@100]" | wideForm bigForm spacing | spacing _ 0 @ 0. wideForm _ Form new extent: (width * scale x) @ height. wideForm spread: self boundingBox from: self by: scale x spacing: spacing x direction: 1 @ 0. bigForm _ Form new extent: self extent * scale. bigForm spread: wideForm boundingBox from: wideForm by: scale y spacing: spacing y direction: 0 @ 1. ^bigForm! reflect: spec "Answer a new Form created by reflecting the receiver about the veritical or horizontal axis. The argument spec = 0@1 for vertical reflection, 1@0 for horizontal" "[Sensor redButtonPressed] whileFalse: [((Form fromDisplay: (Rectangle new origin: Sensor cursorPoint extent: 113@37)) reflect: 1@0) displayAt: 0@0]." | mask temp all newForm full half | all _ self boundingBox. mask _ Form extent: self extent. temp _ Form extent: self extent. full _ self extent*spec. mask black: (0@0 extent: self extent // (spec+1)). newForm _ self deepCopy. [full x + full y > 1] whileTrue: [half _ full // 2. temp copy: all from: 0@0 in: newForm rule: 3. temp copy: all from: full-half in: newForm rule: 6. temp copy: all from: 0@0 in: mask rule: 1. newForm copy: all from: 0@0 in: temp rule: 6. newForm copy: (all translateBy: full-half) from: 0@0 in: temp rule: 6. "Now refine the mask" mask copy: all from: half - (half//2) in: mask rule: 1. mask copy: (all translateBy: full-half) from: 0@0 in: mask rule: 7. full _ half]. ^ newForm! rotate2: direction "Destructively rotate a square form of dimension 2^N by 90 degrees. direction = 1 for clockwise, -1 for counterclockwise" " [Sensor redButtonPressed] whileFalse: [((Form fromDisplay: (Rectangle new origin: Sensor cursorPoint extent: 128@128)) rotate2: 1) displayAt: 0@0]." | mask temp all quad delta | all _ self boundingBox. mask _ Form extent: self extent. temp _ Form extent: self extent. mask white. "set up the first mask" mask black: (0@0 extent: mask extent//2). quad_ self width // 2. [quad >= 1] whileTrue: [delta _ direction=1 ifTrue: [quad@0] ifFalse: [0@quad]. temp copy: all from: 0@0 in: mask rule: 3. "First exchange left and right halves" temp copy: (all translateBy: delta transpose) from: 0@0 in: mask rule: 7. temp copy: all from: 0@0 in: self rule: 1. self copy: all from: 0@0 in: temp rule: 6. temp copy: all from: delta in: self rule: 6. self copy: all from: delta in: self rule: 7. self copy: (all translateBy: delta) from: 0@0 in: temp rule: 6. temp copy: all from: 0@0 in: self rule: 3. "then flip the diagonals" temp copy: all from: quad@quad in: self rule: 6. temp copy: all from: 0@0 in: mask rule: 1. self copy: all from: 0@0 in: temp rule: 6. self copy: all from: quad negated@quad negated in: temp rule: 6. mask copy: all from: (quad//2)@(quad//2) in: mask rule: 1. "Now refine the mask" mask copy: all from: quad negated@0 in: mask rule: 7. mask copy: all from: 0@quad negated in: mask rule: 7. quad_ quad//2]! rotateBy: angle "Answer a copied Form rotated clockwise by angle in units of 90 degrees. angle = 0 means unchanged, 1 means clockwise 90 degrees, and so on" " | f | [Sensor redButtonPressed] whileFalse: [f_ Form fromDisplay: (Sensor cursorPoint extent: 100@15). (f rotateBy: 0) displayAt: 100@100. (f rotateBy: 1) displayAt: 85@100. (f rotateBy: 2) displayAt: 0@85. (f rotateBy: 3) displayAt: 100@0] " | rotSize newForm rotForm all destPt sourcePt sourceDelta destDelta rotOrigin | angle = 0 ifTrue: [^self deepCopy]. "null rotation" angle = 2 ifTrue: [^(self reflect: 0@1) reflect: 1@0]. "two reflections does 180 degrees" "Break the problem up into squares of size 2^N, and rotate them" rotSize _ (width min: height) "minimum rotation size" max: 64. "but faster if we do larger chunks" rotSize _ 2 raisedTo: ((rotSize-1) asFloat floorLog: 2)+1. "force up to a power of 2" newForm _ Form extent: self extent transpose. rotForm _ Form extent: rotSize asPoint. all _ rotForm boundingBox. sourcePt _ 0@0. width >= height ifTrue: [sourceDelta _ rotSize@0. angle=1 ifTrue: [destPt _ 0@0. destDelta _ sourceDelta transpose. rotOrigin _ (rotSize-height)@0] ifFalse: [destPt _ 0@(width-rotSize). destDelta _ (0@0) - sourceDelta transpose. rotOrigin _ 0@0]] ifFalse: [sourceDelta _ 0@rotSize. angle=1 ifTrue: [destPt _ (height-rotSize)@0. destDelta _ (0@0) - sourceDelta transpose. rotOrigin _ 0@0] ifFalse: [destPt _ 0@0. destDelta _ sourceDelta transpose. rotOrigin _ 0@(rotSize-width)]]. (width max: height) - 1 // rotSize + 1 timesRepeat: [rotForm copy: all from: sourcePt in: self rule: 3. rotForm rotate2: (angle=1 ifTrue: [1] ifFalse: [-1]). newForm copy: (all translateBy: destPt) from: rotOrigin in: rotForm rule: 3. sourcePt _ sourcePt + sourceDelta. destPt _ destPt + destDelta]. ^ newForm! shapeFill: aMask interiorPoint: interiorPoint "Fill the interior of some outlined region according to mask and rule. InteriorPoint marks a location in the interior or the region. A mark is placed at this point as a seed, then the seed is smeared into a blob until there is no change in the blob when it fills the region. Uses the upper left corner of the display screen for computing the blob." | dirs smearForm previousSmear all cycle noChange | all _ self boundingBox. smearForm _ Form extent: self extent. smearForm valueAt: interiorPoint put: 1. "Place a seed in the interior" previousSmear _ smearForm deepCopy. dirs _ Array with: 1@0 with: -1@0 with: 0@1 with: 0@-1. cycle _ 0. [(cycle _ cycle+1) \\ 10 = 0 and: "check for no change every 10 smears" [previousSmear copy: all from: 0@0 in: smearForm rule: Form reverse. noChange _ previousSmear isAllWhite. previousSmear copy: all from: 0@0 in: smearForm rule: Form over. noChange]] whileFalse: [dirs do: [:dir | "smear in each of the four directions" smearForm copy: all from: dir in: smearForm rule: Form under. "After each smear, trim around the region border" smearForm copy: all from: 0@0 in: self rule: Form erase]]. "Now paint the filled region in me with aMask" smearForm displayOn: self at: 0@0 clippingBox: self boundingBox rule: Form under mask: aMask! shrinkBy: scale "Answer a scaled-down copy of the receiver." "Each bit in the new form is a sample taken from the upper-left bit of a rectangle of extent = scale in the receiver. A more involved algorithm would count the bits in the rectangle and produce black only if more than half were black." | wideForm shrunkenForm saveOffset | saveOffset _ self offset. self offset: 0 @ 0. wideForm _ Form new extent: self width @ (self height // scale y). 0 to: wideForm height-1 do: [:index | wideForm copy: (0 @ index extent: wideForm width @ 1) from: 0 @ (index * scale y) in: self rule: Form over]. shrunkenForm _ Form new extent: self width // scale x @ wideForm height. 0 to: shrunkenForm width-1 do: [:index | shrunkenForm copy: (index @ 0 extent: 1 @ wideForm height) from: (index * scale x) @ 0 in: wideForm rule: Form over]. self offset: saveOffset. shrunkenForm offset: offset // scale. ^shrunkenForm! spread: rectangle from: sourceForm by: scale spacing: spacing direction: dir "Modify the form by scaling it by scale, spreading the contents by inserting white space at each multiple determined by the argument space along the vector dir." | slice sourcePt | slice _ 0 @ 0 corner: dir transpose * self extent + dir. sourcePt _ rectangle origin. 1 to: (rectangle extent dotProduct: dir) do: [:i | "slice up original area" self copy: slice from: sourcePt in: sourceForm rule: 3. sourcePt _ sourcePt + dir. slice moveBy: dir * scale]. 1 to: scale - spacing - 1 do: [:i | "smear out the slices, leave white space" self copy: (dir corner: self extent) from: 0 @ 0 in: self rule: 7]! wrapAround: aPoint "Answer a new form which contains the image of the receiver, but translated by deltaPoint, with wrap-around. Used for realigning halftone masks. Assumes the receiver is 16x16 with zero offset." "[Sensor anyButtonPressed] whileFalse: [((Cursor normal wrapAround: Sensor cursorPoint) magnifyBy: 8@8) displayAt: 100@100]" | newForm delta | newForm _ Form extent: width@height. delta _ (aPoint x\\16)@(aPoint y\\16). delta = (0@0) ifTrue: [^self]. self displayOn: newForm at: delta-(16@16). self displayOn: newForm at: delta-(16@0). self displayOn: newForm at: delta-(0@16). self displayOn: newForm at: delta. ^newForm! ! !Form methodsFor: 'fileIn/Out'! writeOn: fileName "Save the receiver on the file fileName in the format--fileCode, extent, offset, bits." | file fileCode filePosition | fileCode _ 1. "This indicates that the instance is a Form. Should probably be changed when better methods for permanent storage are devised." file _ FileStream fileNamed: fileName. file binary. file nextWordPut: fileCode. file nextWordPut: width. file nextWordPut: height. file nextWordPut: offset x. file nextWordPut: offset y. filePosition _ 0. 1 to: width + 15 // 16 do: [:j | 1 to: height do: [:i | file nextWordPut: (bits at: (filePosition _ filePosition + 1))]]. file close.! ! !Form methodsFor: 'editing'! bitEdit "Create and schedule a view located in an area designated by the user that contains a view of the receiver magnified by 8@8 that can be modified using the Bit Editor. It also contains a view of the original form." "Note that using direct messages to BitEditor, fixed locations and scales can be created. That is, also try BitEditor openOnForm: self at: . BitEditor openOnForm: self at: scale: ." BitEditor openOnForm: self! bitEditAt: magnifiedLocation "Create and schedule a view whose top left corner is magnifiedLocation and that contains a view of the receiver magnified by 8@8 that can be modified using the Bit Editor. It also contains a view of the original form." BitEditor openOnForm: self at: magnifiedLocation! bitEditAt: magnifiedFormLocation scale: scaleFactor "Create and schedule a view whose top left corner is magnifiedLocation and that contains a view of the receiver magnified by scaleFactor that can be modified using the Bit Editor. It also contains a view of the original form." BitEditor openOnForm: self at: magnifiedFormLocation scale: scaleFactor! edit "Start up an instance of the FormEditor on this form. Typically the form is not visible on the screen. The editor menu is located at the bottom of the form editing frame. The form is displayed centered in the frame. YellowButtonMenu accept is used to modify the form to reflect the changes made on the screen version; cancel restores the original form to the screen. Note that the changes are clipped to the original size of the form." FormEditor openOnForm: self! editAt: originPoint "Start up an instance of the FormEditor on this form in an area whose top left corrner is originPoint. Typically the form is not visible on the screen. The editor menu is located at the bottom of the form editing frame. The form is displayed centered in the frame. YellowBugMenu accept is used to modify the form to reflect the changes made on the screen version; cancel restores the original form to the screen. Note that the changes are clipped to the original size of the form." FormEditor openOnForm: self at: originPoint! ! !Form methodsFor: 'private'! isAllWhite "Answer whether the receiver is all white, i.e., contains all zeros." bits do: [:data | data ~= 0 ifTrue: [^false]]. ^true! setExtent: extentPoint fromArray: anArray setOffset: offsetPoint "Initialize the instance variables." | index len| width _ extentPoint x. height _ extentPoint y. offset _ offsetPoint. bits _ WordArray new: width + 15 // 16 * height. index _ 1. len _ anArray size. [index <= len] whileTrue: [bits at: index put: (anArray at: index). index _ index + 1]! ! !Form methodsFor: 'examples'! nextLifeGeneration "Try the game of Life." "First create a new Form and edit its bits. Leave the BitEditor displayed on the screen so you can copy from it. Form fromUser bitEdit. Now evaluate the following statements, selecting as the initial image of life all or part of the image in the BitEditor. To stop the life generations from continuing, pressing the red button. | life | life _ Form fromUser. [Sensor redButtonPressed] whileFalse: [(life nextLifeGeneration magnifyBy: 8@8) displayAt: 0@0]" | nbr1 nbr2 nbr4 carry2 carry4 all delta | nbr1 _ Form extent: self extent. nbr2 _ Form extent: self extent. nbr4 _ Form extent: self extent. carry2 _ Form extent: self extent. carry4 _ Form extent: self extent. all _ self boundingBox. 1 to: 8 do: [:i | delta _ "delta is the offset of the eight neighboring cells" ((#(-1 0 1 1 1 0 -1 -1) at: i) @ (#(-1 -1 -1 0 1 1 1 0) at: i)). carry2 copy: all from: 0@0 in: nbr1 rule: 3. carry2 copy: all from: delta in: self rule: 1. "AND for carry into 2" nbr1 copy: all from: delta in: self rule: 6. "XOR for sum 1" carry4 copy: all from: 0@0 in: nbr2 rule: 3. carry4 copy: all from: 0@0 in: carry2 rule: 1. "AND for carry into 4" nbr2 copy: all from: 0@0 in: carry2 rule: 6. "XOR for sum 2" nbr4 copy: all from: 0@0 in: carry4 rule: 6]. "XOR for sum 4 (ignore carry into 8)" self copy: all from: 0@0 in: nbr2 rule: 1. nbr1 copy: all from: 0@0 in: nbr2 rule: 1. self copy: all from: 0@0 in: nbr1 rule: 7. self copy: all from: 0@0 in: nbr4 rule: 4 "compute next generation"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Form class instanceVariableNames: 'veryLightGrayMask lightGrayMask blackMask grayMask darkGrayMask whiteMask veryDarkGrayMask '! !Form class methodsFor: 'class initialization'! initialize "Initialize the class variable." "Form initialize." self initializeMasks. OneBitForm _ Form new extent: 1 @ 1! initializeMasks "Set up the form color masks." "Form initializeMasks" | anArray | anArray _ Array new: 16. anArray atAllPut: 0. whiteMask _ Form extent: 16 @ 16 fromArray: anArray offset: 0 @ 0. anArray atAllPut: 65535. blackMask _ Form extent: 16 @ 16 fromArray: anArray offset: 0 @ 0. anArray atAll: (1 to: anArray size by: 2) put: 21845. anArray atAll: (2 to: anArray size by: 2) put: 43690. grayMask _ Form extent: 16 @ 16 fromArray: anArray offset: 0 @ 0. anArray atAll: (1 to: anArray size by: 2) put: 30583. anArray atAll: (2 to: anArray size by: 2) put: 56797. darkGrayMask _ Form extent: 16 @ 16 fromArray: anArray offset: 0 @ 0. lightGrayMask _ darkGrayMask deepCopy reverse. anArray atAll: (1 to: anArray size by: 4) put: 34952. anArray atAll: (2 to: anArray size by: 2) put: 0. anArray atAll: (3 to: anArray size by: 4) put: 8738. veryLightGrayMask _ Form extent: 16 @ 16 fromArray: anArray offset: 0 @ 0. veryDarkGrayMask _ veryLightGrayMask deepCopy reverse.! ! !Form class methodsFor: 'instance creation'! dotOfSize: diameter "Create a form which contains a round black dot." "(Form dotOfSize: 8) displayAt: Sensor cursorPoint" | radius form bite | radius _ diameter//2. form _ self new extent: diameter@diameter offset: (0@0) - (radius@radius). diameter <= 9 ifTrue: "special case for speed" [form black. diameter <= 2 ifTrue: [^form]. bite _ diameter//3. form white: (0@0 extent: bite@1). form white: (0@(diameter-1) extent: bite@1). form white: (diameter-bite@0 extent: bite@1). form white: (diameter-bite@(diameter-1) extent: bite@1). form white: (0@0 extent: 1@bite). form white: (0@(diameter-bite) extent: 1@bite). form white: (diameter-1@0 extent: 1@bite). form white: (diameter-1@(diameter-bite) extent: 1@bite). ^form]. radius _ diameter-1//2. "so circle fits entirely" (Circle new center: radius@radius radius: radius) displayOn: form. form convexShapeFill: Form black. "fill the circle with black" ^form! extent: extentPoint "Answer an instance of the receiver with blank bitmap." ^self basicNew setExtent: extentPoint fromArray: Array new setOffset: 0@0! extent: extentPoint fromArray: anArray offset: offsetPoint "Answer an instance of the receiver with bitmap initialized from anArray." ^self basicNew setExtent: extentPoint fromArray: anArray setOffset: offsetPoint! fromDisplay: aRectangle "Answer an instance of the receiver with bitmap initialized from the area of the display screen defined by aRectangle." ^self new fromDisplay: aRectangle! fromUser "Answer an instance of the receiver with bitmap initialized from the area of the display screen designated by the user. The grid for selecting an area is 1@1." ^self fromUser: 1 @ 1! fromUser: aPoint "Answer an instance of the receiver with bitmap initialized from the area of the display screen designated by the user. The grid for selecting an area is aPoint." | aRectangle | aRectangle _ Rectangle fromUser: aPoint. ^self new fromDisplay: aRectangle! readFormFile: file "Answer an instance of the receiver with bitmap initialized from the external file. The file format is: fileCode(1), extent, offset, bits." | newForm newWidth newHeight theBits filePosition offsetX offsetY | file readOnly; binary. file nextWord = 1 ifFalse: [^(Form new extent: 8 @ 8) black]. "reads fileCode" newForm _ self new. newWidth _ file nextWord. newHeight _ file nextWord. newForm extent: newWidth @ newHeight. offsetX _ file nextWord. offsetY _ file nextWord. offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536]. "stored two's-complement" offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536]. "stored two's-complement" newForm offset: offsetX @ offsetY. theBits _ WordArray new: newWidth + 15 // 16 * newHeight. filePosition _ 0. 1 to: newWidth + 15 // 16 do: [:j | 1 to: newHeight do: [:i | theBits at: (filePosition _ filePosition + 1) put: file nextWord]]. newForm bits: theBits. file close. ^newForm! readFrom: fileName "Answer an instance of the receiver with bitmap initialized from the external file named fileName. Answer nil if the file does not contain a kind of Form." | file code | file _ FileStream oldFileNamed: fileName. file readOnly; binary. code _ file nextWord. "reads fileCode" file skip: -2. code = 1 ifTrue: [^self readFormFile: file]. file close. ^nil! ! !Form class methodsFor: 'mode constants'! and "Answer the integer denoting the logical 'and' combination rule." ^1! erase "Answer the integer denoting mode erase." ^4! over "Answer the integer denoting mode over." ^3! paint "Answer the integer denoting the 'paint' combination rule." ^16! reverse "Answer the integer denoting mode reverse." ^6! under "Answer the integer denoting mode under." ^7! ! !Form class methodsFor: 'mask constants'! black "Answer the form denoting black mask." ^blackMask! darkGray "Answer the form denoting dark gray mask." ^darkGrayMask! gray "Answer the form denoting gray mask." ^grayMask! lightGray "Answer the form denoting light gray mask." ^lightGrayMask! veryDarkGray "Answer the form denoting very dark gray mask." ^veryDarkGrayMask! veryLightGray "Answer the form denoting very light gray mask." ^veryLightGrayMask! white "Answer the form denoting white mask." ^whiteMask! ! !Form class methodsFor: 'examples'! exampleEdits "In Form category editing are messages edit and bitEdit that make it possible to create editors on instances of Form. This is the general form editor-- |f| f _ Form fromUser. f edit. and the bit editor |f | f _ Form fromUser. f bitEdit. " ^self! exampleMagnify "Create a Form from the area around the cursor location and display its magnified view. Move the cursor to see the effect. Press red button to terminate the example." "Form exampleMagnify." [Sensor redButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 50@50)) magnifyBy: 3 @ 3) displayAt: 0 @ 0]! exampleShrink "Create a Form from the area around the cursor location and display its shrunken view. Move the cursor to see the effect. Press red button to terminate the example." "Form exampleShrink." [Sensor redButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 150@150)) shrinkBy: 3 @ 3) displayAt: 0 @ 0]! exampleSketch "This is a simple drawing algorithm to get a sketch on the display screen. After executing, just keep the mouse button depressed and a pen will let you scribble." "Form exampleSketch." | aPen | aPen _ Pen new. Sensor waitButton. aPen place: Sensor cursorPoint. aPen down. [Sensor anyButtonPressed] whileTrue: [aPen goto: Sensor cursorPoint]! exampleSpaceFill "This example demonstrates the area filling algorithm. The example starts by having the user sketch on the screen and then select a rectangular area of the screen which includes all off the area to be filled. Finally, (with crosshair cursor), the user points as the interior of the region to be filled, and the filling begins with that place as its seed." "Form exampleSpaceFill." | f r interiorPoint | Form exampleSketch. "sketch a little area with an enclosed region" r _ Rectangle fromUser. f _ Form fromDisplay: r. Cursor crossHair showWhile: [interiorPoint _ Sensor waitButton - r origin]. Cursor execute showWhile: [f shapeFill: Form gray interiorPoint: interiorPoint]. f displayOn: Display at: r origin! ! !Form class methodsFor: 'private'! ! Form initialize! Object subclass: #FormButtonCache instanceVariableNames: 'offset form value initialState ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Editors'! FormButtonCache comment: 'Instances of class FormButtonCache are used to save information needed to construct the menu for form editors. A collection of instances is a class variable of FormMenuView. Instance Variables: offset for displaying within a view form image of the button on the screen value the keyboard key that selects the button initialState true for on or that the button is selected'! !FormButtonCache methodsFor: 'accessing'! form "Answer the receiver's form, the image of the button on the screen." ^form! form: aForm "Set the receiver's form to be the argument." form _ aForm! initialState "Answer the receiver's initial state, on or off." ^initialState! initialState: aBoolean "Set the receiver's initial state, on or off, to be the argument." initialState _ aBoolean! offset "Answer the receiver's offset, its relative position for displaying the button." ^offset! offset: anInteger "Set the receiver's offset." offset _ anInteger! value "Answer the receiver's value, the keyboard key that selects the button." ^value! value: aCharacter "Set the receiver's key character." value _ aCharacter! ! MouseMenuController subclass: #FormEditor instanceVariableNames: 'form tool grid togglegrid mode previousTool color unNormalizedColor xgridOn ygridOn toolMenu underToolMenu ' classVariableNames: 'BitEditKey BlackKey BlockKey ChangeGridsKey CurveKey DarkGrayKey EraseKey FlashCursor GrayKey InKey LightGrayKey LineKey OutKey OverKey RepeatCopyKey ReverseKey SelectKey SingleCopyKey TogglexGridKey ToggleyGridKey UnderKey WhiteKey YellowButtonMenu YellowButtonMessages ' poolDictionaries: '' category: 'Graphics-Editors'! FormEditor comment: 'Class Form Editor supports creating and modifying Forms. This is intended to be an easy to use general-purpose picture (bitMap) editor. Instance Variables: form form representing the painting brush, i.e., the source for copying tool name of current editing tool grid togglegrid mode for masking the copying of the form to the screen previousTool name of last editing tool selected color unNormalizedColor xgridOn ygridOn toolMenu underToolMenu Class Variables: YellowButtonMenu to be displayed when the yellow button is pressed YellowButtonMessages of message names, one associated with each item in the YellowButtonMenu These are characters representing the keyboard commands to call upon form editing operations. They correspond to items in the menu of buttons displayed with a Form Editor. BitEditKey BlackKey BlockKey ChangeGridsKey CurveKey DarkGrayKey EraseKey FlashCursor GrayKey InKey LightGrayKey LineKey OutKey OverKey RepeatCopyKey ReverseKey SelectKey SingleCopyKey TogglexGridKey ToggleyGridKey UnderKey WhiteKey'! !FormEditor methodsFor: 'initialize-release'! initialize super initialize. self setVariables. self initializeYellowButtonMenu! release super release. toolMenu notNil ifTrue: [toolMenu view release]. toolMenu _ form _ nil! ! !FormEditor methodsFor: 'basic control sequence'! controlInitialize toolMenu notNil ifTrue: [toolMenu view align: toolMenu view displayBox topCenter with: view displayBox bottomCenter+(0@1). toolMenu view translateBy: (toolMenu view displayBox amountToTranslateWithin: Display boundingBox) x @ 0. underToolMenu _ Form fromDisplay: toolMenu view displayBox. toolMenu view display]. self normalizeColor: unNormalizedColor. sensor waitNoButton! controlTerminate view updateDisplay. toolMenu notNil ifTrue: [underToolMenu displayAt: toolMenu view displayBox origin. underToolMenu _ nil].! ! !FormEditor methodsFor: 'control defaults'! controlActivity (toolMenu notNil and: [toolMenu isControlWanted]) ifTrue: [^toolMenu startUp]. self viewHasCursor ifTrue: [sensor redButtonPressed ifTrue: [^self redButtonActivity]. sensor yellowButtonPressed ifTrue: [^self yellowButtonActivity]. sensor blueButtonPressed ifTrue: [^self blueButtonActivity]. self dragForm]! isControlActive ^(toolMenu notNil and: [toolMenu isControlWanted]) or: [sensor noButtonPressed or: [sensor blueButtonPressed not and: [self viewHasCursor]]]! isControlWanted ^(toolMenu notNil and: [toolMenu isControlWanted]) or: [self viewHasCursor]! ! !FormEditor methodsFor: 'editing tools'! block "Allow the user to fill a rectangle with the gray tone and mode currently selected." | rectangle | rectangle _ Rectangle fromUser: grid. rectangle isNil ifFalse: [Display fill: (rectangle intersect: view insetDisplayBox) rule: mode mask: color]! changeGridding "Allow the user to change the values of the horizontal and(or) vertical grid modules. Does not change the primary tool." | response gridInteger | response _ self promptRequest: 'Current horizontal gridding is: ' , togglegrid x printString , '. Type new horizontal gridding.'. response isEmpty ifFalse: [gridInteger _ Integer readFromString: response. togglegrid x: ((gridInteger max: 1) min: Display extent x)]. response _ self promptRequest: 'Current vertical gridding is: ' , togglegrid y printString , '. Type new vertical gridding.'. response isEmpty ifFalse: [gridInteger _ Integer readFromString: response. togglegrid y: ((gridInteger max: 1) min: Display extent y)]. xgridOn ifTrue: [grid x: togglegrid x]. ygridOn ifTrue: [grid y: togglegrid y]. tool _ previousTool! changeTool: aCharacter "Changes the value of the instance variable tool to be the tool corresponding to aCharacter. Typically sent from a Switch in a FormMenuView. " previousTool _ tool. tool _ self selectTool: aCharacter. (#(singleCopy repeatCopy line curve block) includes: tool) ifFalse: [self perform: tool]! colorBlack "Set the mask (color) to black. Leaves the tool set in its previous state." self normalizeColor: Form black. tool _ previousTool! colorDarkGray "Set the mask (color) to dark gray. Leaves the tool set in its previous state." self normalizeColor: Form darkGray. tool _ previousTool! colorGray "Set the mask (color) to gray. Leaves the tool set in its previous state." self normalizeColor: Form gray. tool _ previousTool! colorLightGray "Set the mask (color) to light gray. Leaves the tool set in its previous state." self normalizeColor: Form lightGray. tool _ previousTool! colorWhite "Set the mask (color) to white. Leaves the tool set in its previous state." self normalizeColor: Form white. tool _ previousTool! curve "Conic-section specified by three points from the mouse. the resultant curve on the display is displayed according to the current form and mode." | firstPoint secondPoint curve | firstPoint _ self cursorPoint. form displayOn: Display at: firstPoint clippingBox: view insetDisplayBox rule: mode mask: color. secondPoint _ self trackFormUntil: [sensor noButtonPressed]. curve _ self rubberBandCurve: firstPoint to: secondPoint until: [sensor redButtonPressed]. curve displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: mode mask: color. sensor waitNoButton! eraseMode "Set the mode for the tools that copy the form onto the display to erase. Leaves the tool set in its previous state." mode _ 4. tool _ previousTool! fileInForm "Ask the user for a file name and then recalls the Form in that file as the current source Form (form). Does not change the tool." | inName directory localName trying newForm | trying _ true. tool _ previousTool. [trying] whileTrue: [inName _ self promptRequest: 'type a name for recalling a source Form . . . '. inName isEmpty ifTrue: [^self]. directory _ FileDirectory directoryFromName: inName setFileName: [:localNamex | localName _ localNamex]. (((directory isLegalFileName: localName) and: [directory includesKey: localName]) and: [(newForm _ Form readFrom: inName) ~~ nil]) ifTrue: [trying _ false] ifFalse: [trying _ BinaryChoice message: 'File name illegal, or file not found, or file not valid form file. Try again?']]. newForm ~~ nil ifTrue: [form _ newForm]! fileOutForm "Ask the user for a file name and then save the current source form (form) under that name. Does not change the tool." | outName directory localName trying | trying _ true. tool _ previousTool. [trying] whileTrue: [outName _ self promptRequest: 'type a name for saving the source Form . . . '. outName isEmpty ifTrue: [^self]. directory _ FileDirectory directoryFromName: outName setFileName: [:localNamex | localName _ localNamex]. (directory isLegalFileName: outName) ifTrue: [(directory includesKey: localName) ifTrue: [(BinaryChoice message: 'writing over old file--okay?') ifTrue: [form writeOn: outName]] ifFalse: [form writeOn: outName]. trying _ false] ifFalse: [trying _ BinaryChoice message: 'Bad file name, try again?']]! line "Rubber-band line is specified by two points from the mouse. The resultant line on the display is displayed according to the current form and mode." | firstPoint endPoint | firstPoint _ self cursorPoint. endPoint _ self rubberBandFrom: firstPoint until: [sensor noButtonPressed]. (Line from: firstPoint to: endPoint withForm: form) displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: mode mask: color! magnify "Allow for bit editing of an area of the Form. The user designates a rectangular area that is scaled by 5 to allow individual screens dots to be modified. red button is used to set a bit to black and yellow button is used to set a bit to white. Editing continues until the user depresses any key on the keyboard." | smallRect smallForm scaleFactor tempRect | scaleFactor _ 8@8. smallRect _ (Rectangle fromUser: grid) intersect: view insetDisplayBox. smallRect isNil ifTrue: [^self]. smallForm _ Form fromDisplay: smallRect. "Do this computation here in order to be able to save the existing display screen." tempRect _ BitEditor locateMagnifiedView: smallForm scale: scaleFactor. BitEditor openScreenViewOnForm: smallForm at: smallRect topLeft magnifiedAt: tempRect topLeft scale: scaleFactor. tool _ previousTool! newSourceForm "Allow the user to define a new sourceForm for the FormEditor. Copying the sourceForm onto the display is the primary graphical operation. Resets the tool to be repeatCopy." form _ Form fromUser: grid. tool _ previousTool! overMode "Set the mode for the tools that copy the form onto the display to over. Leaves the tool set in its previous state." mode _ Form over. tool _ previousTool! repeatCopy "As long as the red button is pressed, copy the source form onto the display screen." [sensor redButtonPressed] whileTrue: [form displayOn: Display at: self cursorPoint clippingBox: view insetDisplayBox rule: mode mask: color]! reverseMode "Set the mode for the tools that copy the form onto the display to reverse. Leaves the tool set in its previous state." mode _ Form reverse. tool _ previousTool! singleCopy form displayOn: Display at: self cursorPoint clippingBox: view insetDisplayBox rule: mode mask: color. sensor waitNoButton! togglexGridding "Turns x (horizontal) gridding off, if it is on, and turns it on, if it is off. Does not change the primary tool." xgridOn ifTrue: [grid x: 1. xgridOn _ false] ifFalse: [grid x: togglegrid x. xgridOn _ true]. tool _ previousTool! toggleyGridding "Turns y (vertical) gridding off, if it is on, and turns it on, if it is off. Does not change the primary tool." ygridOn ifTrue: [grid y: 1. ygridOn _ false] ifFalse: [grid y: togglegrid y. ygridOn _ true]. tool _ previousTool! underMode "Sets the mode for the tools that copy the form onto the display to under. Leaves the tool set in its previous state." mode _ Form under. tool _ previousTool! ! !FormEditor methodsFor: 'menu messages'! accept "The edited information should now be accepted by the view." view updateDisplay. view accept! cancel "The edited information should be forgotten by the view." view cancel! fileIn "read in a new form and open an editor on it." | inName directory localName newForm | inName _ self promptRequest: 'type a name for reading a new Form . . . '. directory _ FileDirectory directoryFromName: inName setFileName: [:localNamex | localName _ localNamex]. (directory isLegalFileName: localName) ifTrue: [newForm _ Form readFormFile: (FileStream oldFileNamed: localName). view topView controller close. toolMenu view release. newForm edit]! fileOut "Ask the user for a file name and then save the current source picture from the Display under that name. Does not change the tool." | outName directory localName trying picture | picture _ Form fromDisplay: (view insetDisplayBox). trying _ true. [trying] whileTrue: [outName _ self promptRequest: 'type a name for saving the Form being edited . . . '. directory _ FileDirectory directoryFromName: outName setFileName: [:localNamex | localName _ localNamex]. (directory isLegalFileName: outName) ifTrue: [(directory includesKey: localName) ifTrue: [(BinaryChoice message: 'writing over old file--okay?') ifTrue: [picture writeOn: outName]] ifFalse: [picture writeOn: outName]. trying _ false] ifFalse: [trying _ BinaryChoice message: 'Bad file name, try again?']]! redButtonActivity Cursor blank showWhile: [self perform: tool]! ! !FormEditor methodsFor: 'cursor'! cursorPoint "Answer the mouse coordinate data gridded according to the receiver's grid." ^sensor cursorPoint grid: grid! ! !FormEditor methodsFor: 'private'! dragForm tool = #block ifTrue: [Cursor origin showWhile: [[sensor anyButtonPressed or: [sensor keyboardPressed or: [self viewHasCursor not]]] whileFalse: []]. ^ self cursorPoint] ifFalse: [^Cursor blank showWhile: [self trackFormUntil: [sensor anyButtonPressed or: [sensor keyboardPressed or: [self viewHasCursor not]]]]].! initializeYellowButtonMenu self yellowButtonMenu: YellowButtonMenu yellowButtonMessages: YellowButtonMessages! normalizeColor: halftoneForm unNormalizedColor _ halftoneForm. color _ unNormalizedColor wrapAround: view insetDisplayBox origin.! promptRequest: outputMessage "Answer a string typed by the user on the keyboard. keyboard input is terminated by a line feed character. Typing feedback happens in a window that is at least 100 bits wide and 50 bits high." | answer | FillInTheBlank request: outputMessage displayAt: view insetDisplayBox topCenter + (0@80) centered: true action: [:ans | answer _ ans] initialAnswer: ''. ^answer! rubberBandCurve: startPoint to: endPoint until: aBlock | curve previousApex apex | "Return a curve" curve _ Curve new. curve firstPoint: startPoint. curve secondPoint: (previousApex _ self cursorPoint). curve thirdPoint: endPoint. curve form: form. curve displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: Form black. Cursor crossHair showWhile: [ [aBlock value] whileFalse: [(apex _ self cursorPoint) = previousApex ifFalse: [curve displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: Form black. curve secondPoint: apex. curve displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: Form black. previousApex _ apex]]]. curve displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: Form black. ^ curve! rubberBandFrom: startPoint until: aBlock "Show an xor line from startPoint to the cursor point until aBlock evaluates to true, then remove the line and answer the endPoint." | line endPoint | line _ Line from: startPoint to: startPoint withForm: form. line displayOn: Display at: 0@0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil. "display" [aBlock value] whileFalse: [(endPoint _ self cursorPoint) = line endPoint ifFalse: [line displayOn: Display at: 0@0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil. "erase" line endPoint: endPoint. line displayOn: Display at: 0@0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil. "display" ]]. line displayOn: Display at: 0@0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil. "erase" ^line endPoint! selectTool: aCharacter "A new tool has been selected. It is denoted by aCharacter. Set the tool." "This code is written out in long hand (i.e., rather than dispatching on a table of options) so that it is obvious what is happening." aCharacter = SingleCopyKey ifTrue: [^#singleCopy]. aCharacter = RepeatCopyKey ifTrue: [^#repeatCopy]. aCharacter = LineKey ifTrue: [^#line]. aCharacter = CurveKey ifTrue: [^#curve]. aCharacter = BlockKey ifTrue: [^#block]. aCharacter = SelectKey ifTrue: [^#newSourceForm]. aCharacter = OverKey ifTrue: [^#overMode]. aCharacter = UnderKey ifTrue: [^#underMode]. aCharacter = ReverseKey ifTrue: [^#reverseMode]. aCharacter = EraseKey ifTrue: [^#eraseMode]. aCharacter = ChangeGridsKey ifTrue: [^#changeGridding]. aCharacter = TogglexGridKey ifTrue: [^#togglexGridding]. aCharacter = ToggleyGridKey ifTrue: [^#toggleyGridding]. aCharacter = BitEditKey ifTrue: [^#magnify]. aCharacter = WhiteKey ifTrue: [^#colorWhite]. aCharacter = LightGrayKey ifTrue: [^#colorLightGray]. aCharacter = GrayKey ifTrue: [^#colorGray]. aCharacter = DarkGrayKey ifTrue: [^#colorDarkGray]. aCharacter = BlackKey ifTrue: [^#colorBlack]. aCharacter = OutKey ifTrue: [^#fileOutForm]. aCharacter = InKey ifTrue: [^#fileInForm]. ^ #singleCopy! setVariables tool _ #repeatCopy. previousTool _ tool. grid _ 1 @ 1. togglegrid _ 8 @ 8. xgridOn _ false. ygridOn _ false. mode _ Form over. unNormalizedColor _ color _ Form black. form _ Form new extent: 8 @ 8. form black! toolMenu: aController toolMenu _ aController.! trackFormUntil: aBlock | previousPoint cursorPoint | previousPoint _ self cursorPoint. form displayOn: Display at: previousPoint rule: Form reverse. [aBlock value] whileFalse: [cursorPoint _ self cursorPoint. (FlashCursor or: [cursorPoint ~= previousPoint]) ifTrue: [form displayOn: Display at: previousPoint rule: Form reverse. form displayOn: Display at: cursorPoint rule: Form reverse. previousPoint _ cursorPoint]]. form displayOn: Display at: previousPoint rule: Form reverse. ^ previousPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FormEditor class instanceVariableNames: ''! !FormEditor class methodsFor: 'class initialization'! flashCursor: aBoolean FlashCursor _ aBoolean "FormEditor flashCursor: true."! initialize "FormEditor initialize." FlashCursor _ false. self setKeyboardMap. YellowButtonMenu _ PopUpMenu labels: 'accept cancel'. YellowButtonMessages _ #(accept cancel) "FormEditor initialize"! ! !FormEditor class methodsFor: 'instance creation'! createOnForm: aForm "Creates a StandardSystemView for a FormEditor on aForm." | formView formEditor menuView topView extent | formView _ FormHolderView new model: aForm. formEditor _ self new. formView controller: formEditor. menuView _ FormMenuView new makeFormEditorMenu model: formEditor. menuView insideColor: Form lightGray. menuView borderWidth: 1. menuView window: (menuView defaultWindow expandBy: 16). formEditor toolMenu: menuView controller. topView _ StandardSystemView new. topView model: aForm. topView addSubView: formView. topView label: 'Form Editor'. topView borderWidth: 2. extent _ topView viewport extent. topView minimumSize: extent. topView maximumSize: extent. ^topView! openFullScreenForm "Create and schedule an instance of me on the form whose extent is the extent of the display screen." | topView | topView _ self createFullScreenForm. topView controller openDisplayAt: (topView viewport extent//2) "FormEditor openFullScreenForm."! openOnForm: aForm "Create and schedule an instance of me on the form aForm." | topView | topView _ self createOnForm: aForm. topView controller open! openOnForm: aForm at: originPoint "Create and schedule an instance of me on the form aForm whose view origin is originPoint." | topView | topView _ self createOnForm: aForm. topView controller openDisplayAt: originPoint + (topView viewport extent//2)! ! !FormEditor class methodsFor: 'examples'! formFromDisplay "Create an instance of me on a new form designated by the user at a location designated by the user." "FormEditor formFromDisplay." Form fromUser edit! fullScreen "Create an instance of me on a new form that fills the full size of the display screen." "FormEditor fullScreen." FormEditor openFullScreenForm! newForm "Create an instance of me on a new form at a location designated by the user." "FormEditor newForm." (Form new extent: 300@300) edit! newFormAtOrigin "Create an instance of me on a new form at location 100,100." "FormEditor newFormAtOrigin." (Form new extent: 300@300) editAt: 100@100! ! !FormEditor class methodsFor: 'private'! createFullScreenForm "Create a StandardSystemView for a FormEditor on the form whole screen." ^self createOnForm: (Form new extent: (Display extent x - 4 @ (Display extent y - 112)))! setKeyboardMap "Keyboard Mapping" SelectKey_$a. SingleCopyKey_$s. "tools" RepeatCopyKey_$d. LineKey_$f. CurveKey_$g. BlockKey_$h. OverKey_$j. "modes" UnderKey_$k. ReverseKey_$l. EraseKey_$;. InKey_$'. "file In" BitEditKey_$z. WhiteKey_$x. "colors" LightGrayKey_$c. GrayKey_$v. DarkGrayKey_$b. BlackKey_$n. TogglexGridKey_$m. "gridding" ToggleyGridKey_$,. ChangeGridsKey_$.. OutKey_$/ "file Out"! ! FormEditor initialize! FormView subclass: #FormHolderView instanceVariableNames: 'displayedForm ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Views'! FormHolderView comment: 'Class FormHolderView represents a view of a Form. Editing takes place by modifying a working version of the Form. The message accept is used to copy the working version into the Form; the message cancel copies the Form into the working version. Instance Variable: displayedForm a working version of the Form for being able to cancel editing'! !FormHolderView methodsFor: 'initialize-release'! release "Release references to all dependencies." super release. displayedForm release. displayedForm _ nil! ! !FormHolderView methodsFor: 'model access'! changeValueAt: location put: anInteger "The receiver's model is a Form which has an array of bits. Change the bit at index location to be anInteger (either 1 or 0). Inform all objects that depend on the model that it has changed." displayedForm valueAt: location put: anInteger. displayedForm changed: self! model: aForm "Set the receiver's model to a copy of aForm. The model of the receiver's controller is also set to aModel. " super model: aForm. displayedForm _ aForm deepCopy! workingForm "Answer the Form that is currently being displayed--the working version in which edits are carried out." ^displayedForm! ! !FormHolderView methodsFor: 'displaying'! displayView "This method displays the Form associated with this View according to the rule and mask specified by this class." | oldOffset | oldOffset _ displayedForm offset. displayedForm offset: 0@0. displayedForm displayOn: Display transformation: self displayTransformation clippingBox: self insetDisplayBox rule: self rule mask: self mask. displayedForm offset: oldOffset! updateDisplay "The working version is redefined by copying the bits displayed in the receiver's display area." displayedForm fromDisplay: self insetDisplayBox. displayedForm changed: self.! ! !FormHolderView methodsFor: 'menu messages'! accept "Store the current screen image as the saved model." model copyBits: displayedForm boundingBox from: displayedForm at: 0 @ 0 clippingBox: model boundingBox rule: Form over mask: Form black. model changed: self! cancel "Replace the screen image with the saved form." displayedForm become: model deepCopy. displayedForm changed: self. self display! ! Controller subclass: #FormMenuController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Editors'! FormMenuController comment: 'Class FormMenuController is a subclass of Controller that adds keyboard mapping to the menu selection.'! !FormMenuController methodsFor: 'control defaults'! controlActivity "Pass control to a subView corresponding to a pressed keyboard key or to a mouse button pressed, if any." sensor keyboardPressed ifTrue: [self processMenuKey] ifFalse: [self controlToNextLevel]! isControlActive "Answer false if the blue mouse button is pressed and the cursor is outside of the inset display box of the Controller's view; answer true, otherwise." ^sensor keyboardPressed | (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." ^sensor keyboardPressed | self viewHasCursor! processMenuKey "The user typed a key on the keyboard. Give control to the subView that is selected by this key." | aView | aView _ view subViewContainingCharacter: sensor keyboard. aView ~~ nil ifTrue: [aView controller sendMessage]! ! View subclass: #FormMenuView instanceVariableNames: '' classVariableNames: 'BorderForm FormButtons SpecialBorderForm ' poolDictionaries: '' category: 'Graphics-Editors'! FormMenuView comment: 'Class FormMenuView represents a View whose subViews are Switches (Buttons or OneOnSwitches) whose actions set the mode, color, and tool for editing a Form on the screen. The default controller for instances of the class is FormMenuController. Class Variables: BorderForm that is an image of a small square with thick black borders which is used as a border for each of the menu items SpecialBorderForm that is an image of a small square with thick black borders used to highlight the selection FormButtons of FormButtonCaches each of which represents one of the items that can be selected from the menu'! !FormMenuView methodsFor: 'initialize-release'! makeFormEditorMenu "Construct the menu by creating subviews for each button form." self makeButton: 1. "form source" self makeConnections: (2 to: 6). "tools" self makeConnections: (7 to: 10). "modes" self makeButton: 11. "filing in" self makeButton: 12. "bit editing" self makeColorConnections: (13 to: 17). "colors" self makeGridSwitch: 18. "toggle x" self makeGridSwitch: 19. "toggle y" self makeButton: 20. "setting grid" self makeButton: 21 "filing out"! ! !FormMenuView methodsFor: 'subView access'! subViewContainingCharacter: aCharacter "Answer the receiver's subView that corresponds to the key, aCharacter. Answer nil if no subView is selected by aCharacter." self subViews reverseDo: [:aSubView | (aSubView containsKey: aCharacter) ifTrue: [^aSubView]]. ^nil! ! !FormMenuView methodsFor: 'controller access'! defaultControllerClass "Answer the default controller class for the receiver." ^FormMenuController! ! !FormMenuView methodsFor: 'private'! makeButton: index | button buttonCache aSwitchView| buttonCache _ FormButtons at: index. button _ Button newOff. button onAction: [model changeTool: buttonCache value]. aSwitchView _ self makeViews: buttonCache for: button. aSwitchView controller: IndicatorOnSwitchController new! makeColorConnections: indexInterval | connector button buttonCache aSwitchView | connector _ Object new. "A dummy model for connecting dependents" indexInterval do: [:index | buttonCache _ FormButtons at: index. buttonCache initialState = true ifTrue: [button _ OneOnSwitch newOn] ifFalse: [button _ OneOnSwitch newOff]. button onAction: [model changeTool: buttonCache value]. button connection: connector. aSwitchView _ self makeViews: buttonCache for: button. aSwitchView highlightForm: BorderForm. aSwitchView borderWidthLeft: 1 right: 0 top: 1 bottom: 1. aSwitchView controller selector: #turnOn]. aSwitchView highlightForm: SpecialBorderForm. aSwitchView borderWidth: 1.! makeConnections: indexInterval | connector button buttonCache aSwitchView | connector _ Object new. "A dummy model for connecting dependents." indexInterval do: [:index | buttonCache _ FormButtons at: index. buttonCache initialState = true ifTrue: [button _ OneOnSwitch newOn] ifFalse: [button _ OneOnSwitch newOff]. button onAction: [model changeTool: buttonCache value]. button connection: connector. aSwitchView _ self makeViews: buttonCache for: button. aSwitchView borderWidthLeft: 1 right: 0 top: 1 bottom: 1. aSwitchView controller selector: #turnOn]. aSwitchView borderWidth: 1.! makeGridSwitch: index | button buttonCache | buttonCache _ FormButtons at: index. buttonCache initialState = true ifTrue: [button _ Switch newOn] ifFalse: [button _ Switch newOff]. button onAction: [model changeTool: buttonCache value]. button offAction: [model changeTool: buttonCache value]. self makeViews: buttonCache for: button! makeSwitch: index | button buttonCache | buttonCache _ FormButtons at: index. buttonCache initialState = true ifTrue: [button _ Switch newOn] ifFalse: [button _ Switch newOff]. button onAction: [model changeTool: buttonCache value]. self makeViews: buttonCache for: button! makeViews: cache for: aSwitch | form aSwitchView | form _ cache form. aSwitchView _ SwitchView new model: aSwitch. aSwitchView key: cache value. aSwitchView label: form. aSwitchView window: (0@0 extent: form extent). aSwitchView translateBy: cache offset. aSwitchView borderWidth: 1. aSwitchView insideColor: Form white. self addSubView: aSwitchView. ^aSwitchView! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FormMenuView class instanceVariableNames: ''! !FormMenuView class methodsFor: 'class initialization'! initialize "The forms for the menu are typically stored on files. In order to avoid reading them every time, they are stored in a collection that is a class variable, along with the offset, tool value, and initial visual state (on or off), that makes up the view of the form in the menu view. " "FormMenuView initialize" "To see the use of the FormMenuView, try (Form fromUser) edit" FormButtons _ OrderedCollection new. FormButtons addLast: self selectFormButton. FormButtons addLast: self singlecopyFormButton. FormButtons addLast: self repeatcopyFormButton. FormButtons addLast: self lineFormButton. FormButtons addLast: self curveFormButton. FormButtons addLast: self blockFormButton. FormButtons addLast: self overFormButton. FormButtons addLast: self underFormButton. FormButtons addLast: self reverseFormButton. FormButtons addLast: self eraseFormButton. FormButtons addLast: self inFormButton. FormButtons addLast: self magnifyFormButton. FormButtons addLast: self whiteFormButton. FormButtons addLast: self lightgrayFormButton. FormButtons addLast: self grayFormButton. FormButtons addLast: self darkgrayFormButton. FormButtons addLast: self blackFormButton. FormButtons addLast: self xgridFormButton. FormButtons addLast: self ygridFormButton. FormButtons addLast: self togglegridsFormButton. FormButtons addLast: self outFormButton. SpecialBorderForm _ self specialBorderForm. BorderForm _ self borderForm! ! !FormMenuView class methodsFor: 'constant initialization'! blackFormButton ^(FormButtonCache new "name: black;" offset: 192@48; value: $n; initialState: true; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! blockFormButton ^(FormButtonCache new "name: block;" offset: 192@0; value: $h; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FC 16r3F81 16r80FC 16r3F81 16r80FC 16r3F81 16r80FC 16r3F81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r80FF 16rFF81 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! borderForm ^(Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFC00 16r1F 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF) offset: 0@0)! curveFormButton ^(FormButtonCache new "name: curve;" offset: 160@0; value: $g; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r3F00 16r8001 16rFF80 16r8007 16rFFC0 16r800F 16rFFC0 16r801F 16rFFC0 16r803F 16rFFC0 16r807F 16rFF80 16r80FF 16rFF00 16r80FF 16rC000 16r81FF 16r0 16r81FE 16r0 16r81FE 16r0 16r83FC 16r0 16r83FC 16r0 16r83FC 16r0 16r83FC 16r0 16r83FC 16r0 16r83FC 16r0 16r81F8 16r0 16r80F0 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! darkgrayFormButton ^(FormButtonCache new "name: darkgray;" offset: 160@48; value: $b; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r83FF 16rFFE0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r82EE 16rEEE0 16r83BB 16rBBA0 16r83FF 16rFFE0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! eraseFormButton ^(FormButtonCache new "name: erase;" offset: 352@0; value: $;; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8300 16r1 16r8280 16rFFE1 16r8260 16rFFE1 16r8210 16rFFE1 16r820C 16rFFE1 16r8202 16rFFE1 16r8201 16rFFE1 16r8200 16r7FE1 16r8200 16r1FE1 16r8200 16rFE1 16r8200 16r3E1 16r8200 16rFE1 16r8200 16r1FE1 16r8200 16r7FE1 16r8201 16rFFE1 16r8202 16rFFE1 16r820C 16rFFE1 16r8210 16rFFE1 16r8260 16rFFE1 16r8280 16rFFE1 16r8300 16rFFE1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! grayFormButton ^(FormButtonCache new "name: gray;" offset: 128@48; value: $v; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r83FF 16rFFE0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r8355 16r5560 16r82AA 16rAAA0 16r83FF 16rFFE0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! inFormButton ^(FormButtonCache new "name: in;" offset: 420@0; value: $'; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8001 16r1 16r8003 16r1 16r8007 16r1 16r800F 16r1 16r801F 16r1 16r803F 16rFFE1 16r807F 16rFFE1 16r80FF 16rFFE1 16r81FF 16rFFE1 16r83FF 16rFFE1 16r83FF 16rFFE1 16r81FF 16rFFE1 16r80FF 16rFFE1 16r807F 16rFFE1 16r803F 16r1 16r801F 16r1 16r800F 16r1 16r8007 16r1 16r8003 16r1 16r8001 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! lightgrayFormButton ^(FormButtonCache new "name: lightgray;" offset: 96@48; value: $c; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r83FF 16rFFE0 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r8288 16r88A0 16r8222 16r2220 16r83FF 16rFFE0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! lineFormButton ^(FormButtonCache new "name: line;" offset: 128@0; value: $f; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r700 16r8000 16rF80 16r8000 16r1FC0 16r8000 16r3FC0 16r8000 16r7FC0 16r8000 16rFFC0 16r8001 16rFF80 16r8003 16rFF80 16r8007 16rFF00 16r800F 16rFE00 16r801F 16rFC00 16r803F 16rF800 16r807F 16rF000 16r80FF 16rE000 16r81FF 16rC000 16r81FF 16r8000 16r81FF 16r0 16r81FE 16r0 16r80FC 16r0 16r8078 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! magnifyFormButton ^(FormButtonCache new "name: magnify;" offset: 0@48; value: $z; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r801F 16rFFE1 16r83E0 16r1 16r83E0 16r1 16r83E0 16r1 16r83E0 16r1 16r83E0 16r1 16r83E0 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! outFormButton ^(FormButtonCache new "name: out;" offset: 420@48; value: $/; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r8001 16r8000 16rC001 16r8000 16rE001 16r8000 16rF001 16r8000 16rF801 16r83FF 16rFC01 16r83FF 16rFE01 16r83FF 16rFF01 16r83FF 16rFF81 16r83FF 16rFFC1 16r83FF 16rFFC1 16r83FF 16rFF81 16r83FF 16rFF01 16r83FF 16rFE01 16r8000 16rFC01 16r8000 16rF801 16r8000 16rF001 16r8000 16rE001 16r8000 16rC001 16r8000 16r8001 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! overFormButton ^(FormButtonCache new "name: over;" offset: 256@0; value: $j; initialState: true; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8100 16r0 16r8280 16rFFE0 16r8140 16rFFE0 16r82A8 16rFFE0 16r8154 16rFFE0 16r82AA 16rFFE0 16r8155 16r7FE0 16r82AA 16rBFE0 16r8155 16r5FE0 16r82AA 16rAFE0 16r8155 16r57E0 16r82AA 16rAFE0 16r8155 16r5FE0 16r82AA 16rBFE0 16r8155 16r7FE0 16r82AA 16rFFE0 16r8154 16rFFE0 16r82A8 16rFFE0 16r8150 16rFFE0 16r8280 16rFFE0 16r8100 16rFFE0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! repeatcopyFormButton ^(FormButtonCache new "name: repeatcopy;" offset: 96@0; value: $d; initialState: true; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16rF00 16r8000 16r1F80 16r8000 16r3FC0 16r8000 16r3FC0 16r8000 16r3FC0 16r8000 16r3FC0 16r801E 16r1F80 16r803F 16rF00 16r807F 16r8000 16r807F 16r8000 16r807F 16r8000 16r807F 16r8000 16r803F 16r0 16r807E 16r0 16r80FF 16r0 16r80FF 16r0 16r80FF 16r0 16r80FF 16r0 16r807E 16r0 16r803C 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! reverseFormButton ^(FormButtonCache new "name: reverse;" offset: 320@0; value: $l; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8300 16r0 16r8380 16rFFE0 16r83E0 16rFFE0 16r83F0 16rFFE0 16r83FC 16rFFE0 16r83FE 16rFFE0 16r83FF 16rFFE0 16r83FF 16rFFE0 16r83FF 16r3FE0 16r83FF 16rFE0 16r83FF 16r3E0 16r83FF 16rFE0 16r83FF 16r3FE0 16r83FF 16rFFE0 16r83FF 16rFFE0 16r83FE 16rFFE0 16r83FC 16rFFE0 16r83F0 16rFFE0 16r83E0 16rFFE0 16r8380 16rFFE0 16r8300 16rFFE0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! selectFormButton ^(FormButtonCache new "name: select;" offset: 0@0; value: $a; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r83FF 16r8001 16r83FF 16r8001 16r83FF 16r8001 16r8380 16r1 16r8380 16r1 16r8380 16r1 16r8380 16r1 16r8380 16r1 16r8380 16rE1 16r8380 16rE1 16r8380 16rE1 16r8380 16rE1 16r8380 16rE1 16r8000 16rE1 16r8000 16rE1 16r8000 16rE1 16r8000 16rE1 16r8003 16rFFE1 16r8003 16rFFE1 16r8003 16rFFE1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! singlecopyFormButton ^(FormButtonCache new "name: singlecopy;" offset: 64@0; value: $s; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8003 16rC000 16r8007 16rE000 16r800F 16rF000 16r800F 16rF000 16r800F 16rF000 16r800F 16rF000 16r8007 16rE000 16r8003 16rC000 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! specialBorderForm ^(Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rF800 16rF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF 16rFFFF) offset: 0@0)! togglegridsFormButton ^(FormButtonCache new "name: togglegrids;" offset: 352@48; value: $.; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r83FF 16rFFE1 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r83FF 16rFFE1 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r8201 16r21 16r83FF 16rFFE1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! underFormButton ^(FormButtonCache new "name: under;" offset: 288@0; value: $k; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8100 16r0 16r8280 16rFFE0 16r8140 16rFFE0 16r82A8 16rFFE0 16r8154 16rFFE0 16r82AA 16rFFE0 16r8155 16rFFE0 16r82AA 16rFFE0 16r8155 16rFFE0 16r82AA 16rFFE0 16r8155 16rFFE0 16r82AA 16rFFE0 16r8155 16rFFE0 16r82AA 16rFFE0 16r8155 16rFFE0 16r82AA 16rFFE0 16r8154 16rFFE0 16r82A8 16rFFE0 16r8140 16rFFE0 16r8280 16rFFE0 16r8100 16rFFE0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! whiteFormButton ^(FormButtonCache new "name: white;" offset: 64@48; value: $x; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r83FF 16rFFE0 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r8200 16r20 16r83FF 16rFFE0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16r8000 16r0 16rFFFF 16rFFFF) offset: 0@0))! xgridFormButton ^(FormButtonCache new "name: xgrid;" offset: 256@48; value: $m; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8300 16r61 16r8300 16r61 16r8300 16r61 16r8300 16r61 16r8300 16r61 16r8300 16r61 16r8300 16r61 16r83FF 16rFFE1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! ygridFormButton ^(FormButtonCache new "name: ygrid;" offset: 304@48; value: $,; initialState: false; form: (Form extent: 32@32 fromArray: #( 16rFFFF 16rFFFF 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8007 16rF801 16r8007 16rF801 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8004 16r1 16r8007 16rF801 16r8007 16rF801 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16r8000 16r1 16rFFFF 16rFFFF) offset: 0@0))! ! FormMenuView initialize! View subclass: #FormView instanceVariableNames: 'rule mask ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Views'! FormView comment: 'Instances of class FormView have as their model a Form. It is used mainly to allow display of Forms on the display screen in the model-view-controller metaphor. Instance Variables: rule from 0 to 15 that indicates which of the sixteen display rules(logical function of two boolean values) is to be used when copying the receiver''s model (a Form) onto the display screen mask used when displaying the receiver''s mode on the display screen'! !FormView methodsFor: 'accessing'! mask "Answer an instance of class Form that is the mask used when displaying the receiver's model (a Form) on the display screen." mask == nil ifTrue: [^self defaultMask] ifFalse: [^mask]! mask: aForm "Set the display mask for displaying the receiver's model." mask _ aForm! rule "Answer a number from 0 to 15 that indicates which of the sixteen display rules (logical function of two boolean values) is to be used when copying the receiver's model (a Form) onto the display screen." rule == nil ifTrue: [^self defaultRule] ifFalse: [^rule]! rule: anInteger "Set the display rule for the receiver." rule _ anInteger! ! !FormView methodsFor: 'controller access'! defaultControllerClass "Answer the default class of the receiver." ^FormEditor! ! !FormView methodsFor: 'model access'! changeValueAt: location put: anInteger "The receiver's model is a Form which has an array of bits. Change the bit at index location to be anInteger (either 1 or 0). Inform all objects that depend on the model that it has changed." model valueAt: location put: anInteger. model changed: self! ! !FormView methodsFor: 'window access'! defaultWindow ^(Rectangle origin: 0 @ 0 extent: model extent) expandBy: self borderWidth! ! !FormView methodsFor: 'displaying'! displayView | oldOffset | super displayView. self insideColor == nil ifFalse: [Display fill: self insetDisplayBox mask: self insideColor]. oldOffset _ model offset. model offset: 0@0. model displayOn: Display transformation: self displayTransformation clippingBox: self insetDisplayBox rule: self rule mask: self mask. model offset: oldOffset! ! !FormView methodsFor: 'updating'! update: aFormView self == aFormView ifFalse: [self display]! ! !FormView methodsFor: 'menu messages'! accept "The receiver's model is set to the working version, the one in which edits are carried out." ^self! cancel "Set the working form to be a copy of the model." ^self! ! !FormView methodsFor: 'private'! defaultMask "The default display mask, blackMask, is a 16x16 Form that is all ones" ^Form black! defaultRule "This is the default display rule (3=over or storing)" ^Form over! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FormView class instanceVariableNames: ''! !FormView class methodsFor: 'examples'! exampleOne "Frame a Form (specified by the user) with a border of 5 bits in width and display it offset 100 x 100 from the corner of the display screen." "FormView exampleOne." | f view | f _ Form fromUser. view _ self new model: f. view translateBy: 100 @ 100. view borderWidth: 2. view insideColor: Form white. view display. view release! exampleTwo "Frame a Form (specified by the user) that is scaled by 2. The border is 2 bits in width. Displays at location 100,100." "FormView exampleTwo." | f view | f _ Form fromUser. view _ self new model: f. view scaleBy: 2.0. "if you eliminate this message, no inside border displays" view translateBy: 100 @ 100. view borderWidth: 2. view insideColor: Form white. view display. view release! ! Number subclass: #Fraction instanceVariableNames: 'numerator denominator ' classVariableNames: '' poolDictionaries: '' category: 'Numeric-Numbers'! Fraction comment: 'Instances of class Fraction represent some rational number as a fraction. They can be created as a result of an arithmetic operation if one of the operands is a Fraction and the other is not a Float. All public arithmetic operations return reduced fractional results. Instance Variables: numerator denominator '! !Fraction methodsFor: 'arithmetic'! * aNumber "Answer the result of multiplying the receiver by the argument, aNumber. Result is a new Fraction unless the argument is a Float, in which case the result is a Float." (aNumber isMemberOf: Fraction) ifTrue: [^(Fraction numerator: numerator * aNumber numerator denominator: denominator * aNumber denominator) reduced] ifFalse: [^self retry: #* coercing: aNumber]! + aNumber "Answer the sum of the receiver and the argument, aNumber. Sum is a new Fraction unless the argument is a Float, in which case the sum is a Float." | commonDenominator newNumerator | (aNumber isMemberOf: Fraction) ifTrue: [denominator = aNumber denominator ifTrue: [^(Fraction numerator: numerator + aNumber numerator denominator: denominator) reduced]. commonDenominator _ denominator lcm: aNumber denominator. newNumerator _ numerator * (commonDenominator / denominator) + (aNumber numerator * (commonDenominator / aNumber denominator)). ^(Fraction numerator: newNumerator denominator: commonDenominator) reduced] ifFalse: [^self retry: #+ coercing: aNumber]! - aNumber "Answer the difference between the receiver and the argument, aNumber. The difference is a new Fraction unless the argument is a Float, in which case the result is a Float." (aNumber isMemberOf: Fraction) ifTrue: [^self + aNumber negated] ifFalse: [^self retry: #- coercing: aNumber]! / aNumber "Answer the result of dividing receiver by the argument, aNumber. The result is a new Fraction unless the argument is a Float, in which case the result is a Float." (aNumber isMemberOf: Fraction) ifTrue: [^self * aNumber reciprocal] ifFalse: [^self retry: #/ coercing: aNumber]! negated "Answer a Fraction that is the negation of the receiver." ^Fraction numerator: numerator negated denominator: denominator! reciprocal "Answer 1 divided by the receiver. Result is the denominator or the denominator negated if the numerator of the receiver is 1 or -1 respectively. Else the result is a new Float. Fail if the numerator of the receiver is 0." numerator = 0 ifTrue: [self error: '0 has no reciprocal']. numerator = 1 ifTrue: [^denominator]. numerator = -1 ifTrue: [^denominator negated]. ^Fraction numerator: denominator denominator: numerator! ! !Fraction methodsFor: 'comparing'! < aFraction "Answer whether the receiver is less than the argument." (aFraction isMemberOf: Fraction) ifTrue: [aFraction numerator = 0 ifTrue: [^numerator < 0] ifFalse: [^self - aFraction < 0]] ifFalse: [^self retry: #< coercing: aFraction]! = aNumber "Answer whether the receiver and the argument, aNumber, represent the same numeric value." (aNumber isMemberOf: Fraction) ifTrue: [aNumber numerator = 0 ifTrue: [^numerator = 0] ifFalse: [^aNumber numerator = numerator and: [aNumber denominator = denominator]]] ifFalse: [^self retry: #= coercing: aNumber]! hash "Answer a SmallInteger unique to the receiver." ^numerator bitXor: denominator! ! !Fraction methodsFor: 'truncation and round off'! truncated "Answer an Integer nearest the receiver toward zero." ^numerator quo: denominator! ! !Fraction methodsFor: 'coercing'! coerce: aNumber "Answer a new Fraction. If the receiver is not a Float, then the new Fraction numerator is the argument, aNumber, and denominator is 1." ^aNumber asFraction! generality "Answer the number representing the ordering of the receiver in the generality hierarchy." ^60! ! !Fraction methodsFor: 'converting'! asFloat "Answer a new Float that represents the same value as does the receiver." ^numerator asFloat / denominator asFloat! asFraction "Answer the receiver itself." ^self! ! !Fraction methodsFor: 'printing'! printOn: aStream "Append to the argument, aStream, the receiver's numerator and denominator separated by / and enclosed in parentheses." aStream nextPut: $(. numerator printOn: aStream. aStream nextPut: $/. denominator printOn: aStream. aStream nextPut: $)! ! !Fraction methodsFor: 'private'! denominator "Answer the denominator of the receiver." ^denominator! numerator "Answer the numerator of the receiver." ^numerator! reduced "Answer a Fraction determined by finding the greatest common divisor of the numerator and denominator of the receiver. Answer the reduced numerator if the reduced denominator is 1." | gcd numer denom | numerator = 0 ifTrue: [^0]. gcd _ numerator gcd: denominator. numer _ numerator // gcd. denom _ denominator // gcd. denom = 1 ifTrue: [^numer]. ^Fraction numerator: numer denominator: denom! setNumerator: nInteger denominator: dInteger "Initialize the instance variables. Fail if the denominator is zero." dInteger = 0 ifTrue: [self error: 'denominator cannot be zero'] ifFalse: [numerator _ nInteger truncated. denominator _ dInteger truncated abs. "keep sign in numerator" dInteger < 0 ifTrue: [numerator _ numerator negated]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Fraction class instanceVariableNames: ''! !Fraction class methodsFor: 'instance creation'! numerator: numInteger denominator: denInteger "Answer a new Fraction numInteger/denInteger." ^self new setNumerator: numInteger denominator: denInteger! ! View subclass: #GClockView instanceVariableNames: 'cacheForm cacheBox myProject date ' classVariableNames: 'NumberForms ' poolDictionaries: '' category: 'Interface-Clocks'! GClockView comment: 'I am the view of the graphical clock - I display the date in my top view''s label tab and display the time in my insides like a graphical clock. My instance variables are: cacheForm the bitmap of the numbers for the face of the clock, cacheBox the box (i.e., self insetDisplayBox) that the face lives in, myProject the project I''m open in and, date the date i have in my label'! !GClockView methodsFor: 'initialize-release'! initialize "set up the view's constants" super initialize. myProject _ Project current. date _ Date today! ! !GClockView methodsFor: 'displaying'! display "sent on update, check if my project is the current one." myProject == Project current ifTrue: [super display]! displayFace "update my face if the time has changes, write out the cached form if not (i.e., if i was moved)" (cacheBox == nil or: [cacheBox ~= self insetDisplayBox]) ifTrue: [self reallyDisplayFace. cacheForm _ Form fromDisplay: (cacheBox _ self insetDisplayBox)] ifFalse: [cacheForm displayAt: self insetDisplayBox topLeft]! displayHands "display the hands of the clock. This is where the fancy stuff is..." | x y radius center extent time hour minute hand | extent _ self insetDisplayBox extent. center _ self insetDisplayBox center. radius _ extent // 2 - 20. time _ Time now. minute _ time minutes. hour _ time hours * 5 + (minute / 12) asFloat. hand _ Pen new. hand defaultNib: 4. x _ (hour * 6 - 90) degreesToRadians cos. y _ (hour * 6 - 90) degreesToRadians sin. hand up; goto: center + (x@y * radius // 2); down. hand goto: center. hand defaultNib: 2. x _ (minute * 6 - 90) degreesToRadians cos. y _ (minute * 6 - 90) degreesToRadians sin. hand goto: center + (x@y * (radius-8))! displayView "do the updating of the view" | today | today _ Date today. date = today ifFalse: [date _ today. self topView newLabel: today printString]. self topView isCollapsed ifFalse: [self displayFace. self displayHands]! reallyDisplayFace "generate the background face form" | degree radius center direction form extent | center _ self insetDisplayBox center. extent _ self insetDisplayBox extent. radius _ extent // 2 - 12. 1 to: 12 do: [:number | degree _ number-3 * 30. direction _ (degree degreesToRadians cos @ degree degreesToRadians sin). form _ NumberForms at: number. form displayAt: center+1 + (direction*radius) - (form extent // 2). Display black: (center + (direction*(radius-11)) extent: 2@2)]! ! !GClockView methodsFor: 'controller access'! defaultControllerClass "answer my controller class" ^ClockController! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GClockView class instanceVariableNames: ''! GClockView class comment: 'I am the view of the graphical clock - I hold the date in my label tab and display the time in my insides like a graphical clock. I am not constrained to being square. My instance variables are: cacheForm the bitmap of the numbers for the face of the clock, cacheBox the box (i.e., self insetDisplayBox) that the face lives in, myProject the project i''m open in and, date the date i have in my label'! !GClockView class methodsFor: 'instance creation'! open "open a new GClockView by executing the following comment" "GClockView open" | topView insideView | topView _ StandardSystemView new. topView label: Date today printString. topView borderWidth: 2. topView insideColor: Form white. topView minimumSize: 100@100. insideView _ self new. topView addSubView: insideView. topView controller open! ! !GClockView class methodsFor: 'class initialization'! initialize "initialize the class constants" "GClockView initialize" | text | NumberForms _ Array new: 12. 1 to: 12 do: [:number | text _ number printString asText. text emphasizeFrom: 1 to: text size with: 11. NumberForms at: number put: text asParagraph asForm]! ! GClockView initialize! FileList subclass: #HierarchicalFileList instanceVariableNames: 'selectionName isDirectory emptyDir myDirectory ' classVariableNames: '' poolDictionaries: '' category: 'Interface-File Model'! HierarchicalFileList comment: 'I am a fileList on a Hierarchical file system.'! !HierarchicalFileList methodsFor: 'file name list'! directoryPattern "Set the pattern to be the path to the selected directory." | newPattern | newPattern _ self nameOfSelection. newPattern == nil ifFalse: [self pattern: (newPattern , (FileDirectory separatorString) ,'*'). self changed: #pattern. self acceptPattern: self pattern asText from: nil]! fileListMenu "Answer the menu." "Evaluate this when you change this method: HierarchicalFileList flushMenus" fileName == nil ifTrue: [ ^ActionMenu labels: 'make directory' withCRs lines: #() selectors: #(makeDir)]. "If fileName exists and is a directory, return a special menu" isDirectory ifTrue: [^ActionMenu labels: 'new pattern\copy name\rename\remove\spawn' withCRs lines: #(1 3 4) selectors: #(directoryPattern copyName renameDir removeDir spawnFileList)]. "If fileName does not exist or is not a directory return special getInfo menu" FileMenu == nil ifTrue: [FileMenu _ ActionMenu labels: 'get contents\file in\copy name\rename\remove\spawn' withCRs lines: #(2 4 5) selectors: #(getFile fileInFile copyName renameFile deleteFile spawnFileList)]. ^FileMenu! fileName: selection "If selection is not nil, it is either the name of a file to be viewed, or a directory" | file | isDirectory _ false. file _ nil. selection == nil ifFalse: [file _ selection. isDirectory _ (FileDirectory isDirectory: file)]. self setFileName: file. self setSelection: selection. isReading _ false. emptyDir _ true. self changed: #text! makeDir "Make a new directory." | continue newName | continue _ true. [continue] whileTrue: [newName _ FillInTheBlank request: 'New name for directory?' initialAnswer: ''. newName isEmpty ifTrue: [^nil]. ((self isLegalFileName: newName) and: [(FileDirectory includesKey: newName) not]) ifTrue: [continue _ false] ifFalse: [(BinaryChoice message: 'File exists or bad file name. Try again?') ifFalse: [^nil]]]. SystemCall makeDirectory: newName. list == nil ifTrue: [self list: SortedCollection new]. list add: newName. self changed: #fileName! nameOfSelection "Return the name of the current selection." (selectionName findString: myDirectory startingAt: 1) = 1 ifTrue: [selectionName copyFrom: myDirectory size + 1 to: selectionName size] ifFalse: [^selectionName]! removeDir "Remove the selected directory." (BinaryChoice message: 'Remove directory ', fileName) ifTrue: [(SystemCall isEmptyDirectory: fileName) ifFalse: [emptyDir _ false. self changed: #text] ifTrue: [SystemCall removeDirectory: fileName. list remove: self nameOfSelection. self changed: #fileName]]! spawnFileList "Open a FileList if the current selection is a directory otherwise open a file editor." isDirectory ifTrue: [^self class openOnPattern: (self nameOfSelection , FileDirectory separatorString ,'*')] ifFalse: [^FileModel open: (FileModel new setFileName: self nameOfSelection) named: self nameOfSelection]! ! !HierarchicalFileList methodsFor: 'user protocol'! spawnFile: aText from: aController "Open a FileList if the selected file is a directory otherwise open a file editor that edits the current selection." isDirectory ifTrue: [self spawnFileList] ifFalse: [^super spawnFile: aText from: aController].! ! !HierarchicalFileList methodsFor: 'text'! getInfo isReading _ false. self changed: #text.! getInfo: aFileName "Returns aText with proper emphasis information from the file system information on aFileName" | status size mod creation creator type aText aHeader sizeText modText createText creatorText typeText cr | status _ SystemCall default statusForFileNamed: aFileName. size _ (status at: 1) printString asText. mod _ (Time aTimeString: (status at: 3)) asText. (status at: 8) notNil ifTrue: [creator _ (status at: 8) asText. type _ (status at: 9) asText] ifFalse: [creator _ 'Unknown' asText. type _ 'Unknown' asText]. " determine if the file is an application" type string = 'APPL' ifTrue: [aHeader _ '- Application - ' asText emphasizeFrom: 2 to: 14 with: 3] ifFalse: [aHeader _ ('- file - Select ''get contents'' to view contents. ' asText) emphasizeFrom: 2 to: 7 with: 3; emphasizeFrom: 10 to: 48 with: 3]. sizeText _ 'Size: ' asText emphasizeFrom: 1 to: 5 with: 2. modText _ 'Last Modified: ' asText emphasizeFrom: 1 to: 14 with: 2. creatorText _ 'Creator: ' asText emphasizeFrom: 1 to: 8 with: 2. typeText _ 'Type: ' asText emphasizeFrom: 1 to: 5 with: 2. cr _ (String with: Character cr) asText. aText _ aHeader , cr , sizeText , size , cr , modText , mod , cr , creatorText , creator , cr , typeText , type. ^aText! text "Return the text for the text subview." | text dirList dirStream dname| isDirectory ifTrue: [ emptyDir ifFalse: [text _ '- Directory is not empty, cannot be removed. -' asText emphasizeFrom: 2 to: 44 with: 3] ifTrue: [Cursor wait showWhile: [dirList _ SortedCollection new. dirStream _ WriteStream on: (String new). dirStream nextPutAll: ('- directory -'); cr; cr. dname _ self nameOfSelection. dirList addAll: (self filterOutMyDirectoryFrom: ((FileDirectory named: dname) filesMatching: '*')). dirList do: [ :name | dirStream nextPutAll: name; cr]. text _ dirStream contents asText emphasizeFrom: 2 to: 12 with: 3. isReading _ true]]] ifFalse: [ "Then it is a file." isReading ifTrue: [fileName == nil ifTrue: [^nil]. (FileDirectory includesKey: fileName) ifTrue: [text _ Cursor read showWhile: [(FileStream fileNamed: fileName) contentsOfEntireFile asText]] ifFalse: [text _ '- new file -' asText emphasizeFrom: 2 to: 11 with: 3]] ifFalse: [fileName == nil ifTrue: [text _ '' asText] ifFalse: [(FileDirectory includesKey: fileName) ifTrue: [text _ Cursor wait showWhile: [self getInfo: fileName].] ifFalse: [text _ '- new file -' asText emphasizeFrom: 2 to: 11 with: 3. isReading _ true.]]]]. ^text! textMenu isDirectory ifFalse: [^super textMenu]. fileName == nil ifTrue: [^ nil]. ^ActionMenu labelList: #((again undo) (copy cut paste) ('do it' 'print it' inspect) (spawn)) selectors: #(again undo copySelection cut paste doIt printIt inspectIt spawnFile:from:)! ! !HierarchicalFileList methodsFor: 'private'! filterOutMyDirectoryFrom: aList "Return a list of my files without the current path." ^aList collect: [:name | (name findString: myDirectory startingAt: 1) = 1 ifTrue: [name copyFrom: myDirectory size + 1 to: name size] ifFalse: [name]]! list: aList "Set my list of files." super list: (self filterOutMyDirectoryFrom: aList) asSortedCollection! setSelection: selection "Set my current selection." selectionName _ selection! setWorkingDirectory "Set my directory to be the current working directory." myDirectory _ FileDirectory nameWithSeparator: SystemCall currentWorkingDirectory! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HierarchicalFileList class instanceVariableNames: ''! !HierarchicalFileList class methodsFor: 'instance creation'! new ^super new setWorkingDirectory! ! PopUpMenu subclass: #HierarchicalMenu instanceVariableNames: 'prefix items background ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! HierarchicalMenu comment: 'I am a menu that is tree structured. For an example of how to use me see the example in my class.'! !HierarchicalMenu methodsFor: 'accessing'! asString ^labelString! menuItems ^items! ! !HierarchicalMenu methodsFor: 'displaying'! displayAt: aPoint "Display the receiver centered at aPoint while aBlock is evaluated. If necessary, translate so the view is completely on the screen." | delta | frame _ frame align: marker center with: aPoint. delta _ frame amountToTranslateWithin: Display boundingBox. frame moveBy: delta. frame _ frame intersect: Display boundingBox. "frame _ frame adjustInsideHeightToMultipleOf: marker height." marker _ marker align: marker center with: aPoint + delta. background _ Form fromDisplay: frame. frame displayOn: Display. origin _ frame inside topLeft. self displayForm.! displayLeftAt: aPoint self displayAt: aPoint + (marker extent + (2@0) // 2).! eraseMenus "Erase all visible menus" self selectedMenuDo: [:item | item eraseMenus]. self restoreBackground. selection _ nil.! restoreBackground background displayOn: Display at: frame topLeft! ! !HierarchicalMenu methodsFor: 'marker adjustment'! markerOff selection isNil ifTrue: [^self] ifFalse: [self selectedMenuDo: [:item | item eraseMenus]. "erase overlapping sub-menus first" Display reverse: marker. selection _ nil]! markerOn: aPoint "The item whose bounding area contains aPoint should be marked as selected. Highlight its area and set the selection to its index." selection notNil ifTrue: [(marker containsPoint: aPoint) ifTrue: [^self] "no change" ifFalse: [self markerOff]]. "erase old marker" marker _ marker align: marker topLeft with: marker left @ (self markerTop: aPoint). Display reverse: marker. "display new marker" selection _ marker top - origin y // marker height + 1. self selectedMenuDo: [:item | item displayLeftAt: marker topRight].! ! !HierarchicalMenu methodsFor: 'selecting'! menuAt: aPoint "Answer the receiver or selected sub-menu containing this screen coordinate" | sub | self selectedMenuDo: "find overlapping sub-menu first" [:menu | (sub _ menu menuAt: aPoint) notNil ifTrue: [^sub]]. (frame containsPoint: aPoint) ifTrue: [^self]. ^nil! selectedItem selection isNil ifTrue: [^nil]. selection > items size ifTrue: [^#other]. ^items at: selection! selectedMenuDo: menuBlock | item | (selection notNil and: [selection <= items size]) ifTrue: [item _ items at: selection. item class == self class ifTrue: [^menuBlock value: item]]! selectorAt: item "Included so that one can address HierarchicalMenus just like ActionMenus - see implementors of messages like yellowButtonActivity." ^item! takeCursor "Jump the cursor to the center of the item last selected in this menu" (marker containsPoint: Sensor cursorPoint) ifFalse: "don't jump if unnecessary" [Sensor cursorPoint: marker center]! ! !HierarchicalMenu methodsFor: 'controlling'! controlLoop "Allow this menu to change its selection while it contains the cursor or until a leaf selection is made. Display and erase any submenus as necessary." | item selPoint | item _ self selectedItem. ["(self menuAt: (selPoint _ Sensor cursorPoint)) == self" frame inside containsPoint: (selPoint _ Sensor cursorPoint)] whileTrue: [Sensor anyButtonPressed ifTrue: [self markerOn: selPoint] "side-effects selection and sub-menus" ifFalse: [item _ self selectedItem. item class == self class ifTrue: [item takeCursor. "jump cursor to sub-menu (optional)" [Sensor anyButtonPressed] whileFalse: [item scrollIfNeeded]. "sub-menu selected, wait for button down" ^nil "give control to sub-menu"] ifFalse: [(selection isNil "non sub-menu selection" or: [selection <= items size]) ifTrue: [^item] ifFalse: [^FillInTheBlank request: 'Enter a new name' initialAnswer: prefix]]]]. ^nil "button down outside menu, give up control"! startUp: aSymbol "Display this menu and allow the user to select an item from it or one of its sub-menus. Answer the selected item or 0." | menu result newMenu | self displayAt: Sensor cursorPoint during: [Sensor cursorPoint: marker center. [self buttonPressed: aSymbol] whileFalse: [self scrollIfNeeded]. menu _ nil. [Sensor anyButtonPressed] whileTrue: [menu == nil ifTrue: [newMenu _ self menuAt: self scrollIfNeeded] ifFalse: [newMenu _ self menuAt: menu scrollIfNeeded]. newMenu isNil ifTrue: [menu notNil ifTrue: [menu markerOff]] ifFalse: [(menu notNil and: [newMenu selectedItem == menu]) ifTrue: [menu markerOff]. menu _ newMenu. result _ menu controlLoop]]. self selectedMenuDo: [:item | item eraseMenus]. selection _ nil]. Sensor waitNoButton. result == nil ifTrue: [^0] ifFalse: [^result]! startUp: aSymbol withHeading: aText "Display this menu and allow the user to select an item from it or one of its sub-menus. Answer the selected item or nil." | menu result newMenu | self displayAt: Sensor cursorPoint withHeading: aText during: [Sensor cursorPoint: marker center. [self buttonPressed: aSymbol] whileFalse: [self scrollIfNeeded]. menu _ nil. [self buttonPressed: aSymbol] whileTrue: [menu == nil ifTrue: [newMenu _ self menuAt: self scrollIfNeeded] ifFalse: [newMenu _ self menuAt: menu scrollIfNeeded]. newMenu isNil ifTrue: [menu notNil ifTrue: [menu markerOff]] ifFalse: [(menu notNil and: [newMenu selectedItem == menu]) ifTrue: [menu markerOff]. menu _ newMenu. result _ menu controlLoop]]. self selectedMenuDo: [:item | item eraseMenus]. selection _ nil]. ^result! ! !HierarchicalMenu methodsFor: 'private'! labels: aString font: aFont lines: anArray | style labelPara oldForm | labelString _ aString. font _ aFont. style _ TextStyle fontArray: (Array with: font). style alignment: 2. "centered" style gridForFont: 1 withLead: 0. labelPara _ Paragraph withText: aString asText style: style. lineArray _ anArray. oldForm _ labelPara asForm. form _ Form extent: (oldForm extent + (labelPara lineGrid -3 // 2 + 1@ 0) "for triangles at right hand side"). oldForm displayOn: form at: (0@0). frame _ Quadrangle new. frame region: ("labelPara compositionRectangle" form boundingBox expandBy: 2). frame borderWidth: (1@1 corner: 3@3). lineArray == nil ifFalse: [lineArray do: [:line | form fill: (0 @ (line * font height) extent: (frame width @ 1)) mask: Form black]]. marker _ frame inside topLeft extent: frame inside width @ labelPara lineGrid. selection _ nil! prefix: prefixString items: itemList | on height dot onHeight tooBig newForm | dot _ Form dotOfSize: 1. onHeight _ (height _ marker height) - 4. on _ Form extent: (onHeight //2 + 1) @ onHeight. 1 to: onHeight // 2 do: [:index | dot displayOn: on at: 0@(index -1). dot displayOn: on at: (index -1) @ (index-1). dot displayOn: on at: 0@(onHeight - index). dot displayOn: on at: (index -1) @ (onHeight - index)]. onHeight odd ifTrue:[ dot displayOn: on at: 0@(onHeight // 2). dot displayOn: on at: onHeight //2 @ (onHeight // 2)]. prefix _ prefixString. items _ itemList. tooBig _ true. 1 to: itemList size do: [:index | ((itemList at: index) isKindOf: self class) ifTrue:["We have another hierarchical menu, mark it in our form" on displayOn: form at: (form width - (onHeight //2 + 1) )@((index -1) * height +2 ). tooBig _ false.] ifFalse:["We don't have another h-menu, clear the spot in the form" "We assume this method is called only once, and hence don't do anything" ]]. tooBig ifTrue:[ newForm _ Form extent: (form width - (onHeight //2 + 1) -1)@(form height). form displayOn: newForm at: 0@0. newForm offset: form offset. form _ newForm. frame region: ("labelPara compositionRectangle" form boundingBox expandBy: 2). marker width: frame inside width.]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HierarchicalMenu class instanceVariableNames: ''! !HierarchicalMenu class methodsFor: 'instance creation'! prefix: prefix itemList: itemList | newMenu | newMenu _ self labelList: (Array with: (itemList collect: [ :item | self removePrefix: prefix from: item asString]) with: #('new name')). newMenu prefix: prefix items: itemList. ^newMenu! ! !HierarchicalMenu class methodsFor: 'examples'! menuSampler "This example builds a hierarchical menu with the hierarchy three deep. The 'right arrow' in an item indicates that selecting the item will open up another menu. Selecting any item will cause nothing to happen." "HierarchicalMenu menuSampler" ^(MenuBuilder parseFrom: (ReadStream on: 'restore display[restoreDisplay] open window: (project[openProject] browser[openBrowser] workspace[openWorkspace] system workspace[openSystemWorkspace] transcript[openTranscript] file list[openFileList] document editor[openWYSIWYGView] clock: (ascii[openAClock] graphical [openGClock])) save/quit: (save[save] save then quit[saveThenQuit] quit: confirm[quit]) exit project[exitProject]' )) menu startUp! ! !HierarchicalMenu class methodsFor: 'private'! removePrefix: prefix from: label "Removes the prefix from the given label (or if they are the same, returns the label with brackets around it.) Does not remove trailing hyphens." | pos pot | (prefix sameAs: (label , '-')) ifTrue: [ pos _ label indexOf: $-. pos _ 1. [pot _ (label findString: '-' startingAt: pos) == 0] whileFalse: [ pos _ pot ]. ^'<' , (label copyFrom: pos to: label size), '>']. (prefix sameAs: (label copyFrom: 1 to: prefix size)) ifTrue: [^label copyFrom: (prefix size + 1) to: label size]. ^label! ! Model subclass: #Icon instanceVariableNames: 'form textRect ' classVariableNames: 'IconConstants ' poolDictionaries: '' category: 'Interface-Icons'! Icon comment: 'I am the display object displayed for collapsed views. I am used as the model for an IconView. form textRect '! !Icon methodsFor: 'initialization'! form: aForm textRect: aRectangle form _ aForm. textRect _ aRectangle! ! !Icon methodsFor: 'accessing'! extent ^form extent! form ^form! textRect ^ textRect! ! !Icon methodsFor: 'printing'! storeOn: aStream "Append to the argument aStream a description of the receiver in the form: (class-name form: form textRect: textRectangle))" aStream nextPutAll: '('; nextPutAll: self class name; nextPutAll: ' form: '; store: form; nextPutAll: ' textRect: ('; print: textRect; nextPutAll: '))'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Icon class instanceVariableNames: ''! !Icon class methodsFor: 'class initialization'! initialize "Icon initialize" IconConstants _ Dictionary new. IconConstants at: #default put: nil! ! !Icon class methodsFor: 'instance creation'! form: aForm textRect: aRectangle "Return an instance of me with my form and textRectangle set to aForm and aRectangle." ^self new form: aForm textRect: aRectangle! ! !Icon class methodsFor: 'constants'! constantDictionary "Return my Icon constant dictionary." ^IconConstants! constantNamed: aSymbol "Return an icon named aSymbol or nil if not found." ^self constantNamed: aSymbol ifAbsent: [nil]! constantNamed: aSymbol ifAbsent: aBlock "Return the icon named aSmbol or evaluate aBlock." ^IconConstants at: aSymbol ifAbsent: aBlock! constantNamed: aSymbol put: anIcon "Put anIcon under the name aSymbol in my constant dictionary" ^IconConstants at: aSymbol put: anIcon! constantsFromFile: fileName "Load my constant dictionary with the contents of the file named fileName." | stream | stream _ (FileStream oldFileNamed: fileName) readOnly. IconConstants _ Dictionary readFrom: stream. stream close! constantsToFile: fileName "Store the icons in my constant dictionary to the file named fileName." | stream | stream _ FileStream newFileNamed: fileName. IconConstants storeOn: stream. stream close! ! Icon initialize! MouseMenuController subclass: #IconController instanceVariableNames: '' classVariableNames: 'IconYellowButtonMenu IconYellowButtonMessages ' poolDictionaries: '' category: 'Interface-Icons'! IconController comment: 'I am the default controller for an IconView.'! !IconController methodsFor: 'initialize-release'! initialize super initialize. self initializeYellowButtonMenu.! initializeYellowButtonMenu self yellowButtonMenu: IconYellowButtonMenu yellowButtonMessages: IconYellowButtonMessages.! ! !IconController methodsFor: 'control defaults'! isControlActive "Return whether I still want control." ^super isControlActive and: [self mouseDetect and: [sensor blueButtonPressed not and: [ view topView ~~ view ]]]! isControlWanted "Return whether I want control." ^super isControlWanted and: [self mouseDetect]! redButtonActivity "Red button click in the icon expands." view topView controller expand! ! !IconController methodsFor: 'menu messages'! expand "have the real controller restore" view topView controller expand! ! !IconController methodsFor: 'private'! mouseDetect "Return true if the cursorPoint intersects the icons shape." | icon | icon _ model form. ^icon class == OpaqueForm ifTrue: [(model form shape valueAt: (sensor cursorPoint - view insetDisplayBox origin)) = 1] ifFalse: [view insetDisplayBox containsPoint: sensor cursorPoint]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IconController class instanceVariableNames: ''! !IconController class methodsFor: 'class initialization'! initialize "IconController initialize" IconYellowButtonMenu _ PopUpMenu labels: 'expand'. IconYellowButtonMessages _ #(expand ). self allInstances do: [:controller | controller initialize]! ! IconController initialize! View subclass: #IconView instanceVariableNames: 'iconText isReversed ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Icons'! IconView comment: 'I am the view displayed when a StandardSystemView is collapsed.'! !IconView methodsFor: 'initialize-release'! initialize super initialize. isReversed _ false.! ! !IconView methodsFor: 'text access'! iconText "Return my icon text or nil if none." ^iconText! text "Return my icon text" iconText == nil ifTrue: [^ Text new] ifFalse: [^ iconText text]! text: aStringOrText "Set my icon text to be aStringOrText" | textRect style| (aStringOrText isNil or: [aStringOrText string isEmpty]) ifTrue: [^ iconText _ nil]. iconText isNil ifTrue: [textRect _ model textRect. textRect == nil ifTrue: [^self]. style _ TextStyle styleNamed: #icon ifAbsent: [nil]. style == nil ifTrue: [style _ TextStyle default]. iconText _ Paragraph withText: aStringOrText asText style: style compositionRectangle: textRect clippingRectangle: textRect] ifFalse: [iconText text: aStringOrText asText]! ! !IconView methodsFor: 'controller access'! defaultControllerClass ^IconController! ! !IconView methodsFor: 'window access'! defaultWindow "Return my default window based on my icons extent." ^(Rectangle origin: 0 @ 0 extent: model extent) expandBy: self borderWidth! ! !IconView methodsFor: 'displaying'! deEmphasizeView "Emphasize the receiver's image on the screen." isReversed ifTrue: [self reverseImageOn: Display. isReversed _ false]! displayView "Display my icon and icon text" | textBox | model form displayOn: Display at: self insetDisplayBox origin. (iconText notNil and: [model textRect notNil]) ifTrue: [textBox _ (textBox _ self insetDisplayBox) intersect: (model textRect translateBy: textBox origin). iconText asForm displayOn: Display at: textBox origin clippingBox: textBox rule: Form over mask: nil]. isReversed _ false.! emphasizeView "Emphasize the receiver's image on the screen." isReversed ifFalse: [self reverseImageOn: Display. isReversed _ true]! image "Return a copy of my visual representation." |image| image _ model form deepCopy. (iconText notNil and: [model textRect notNil]) ifTrue: [iconText asForm displayOn: image figure at: model textRect origin clippingBox: model textRect rule: Form over mask: nil]. ^image! reverseImageOn: aMedium "Reverse the receiver's image on the screen." model form class == OpaqueForm ifTrue: [model form shape displayOn: aMedium at: self displayBox origin clippingBox: self insetDisplayBox rule: Form reverse mask: nil] ifFalse: [model form displayOn: aMedium at: self displayBox origin clippingBox: self insetDisplayBox rule: 10 mask: nil] "Reverse destination always"! ! !IconView methodsFor: 'private'! isFromLabel "This allows the system to distinguish between pictorial icons and those that are generated automatically from label text." | form | form _ self model form. ^form class == Form! newIcon "The receiver's model is being changed to a new icon. If there is display location state on the receiver, it must be updated." | width height | insetDisplayBox isNil ifFalse: [width _ self model form width. height _ self model form height. window _ Rectangle origin: 0 @ 0 corner: width @ height. viewport _ window deepCopy. insetDisplayBox corner: insetDisplayBox origin + (width @ height)]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IconView class instanceVariableNames: ''! !IconView class methodsFor: 'instance creation'! on: anIcon "Return an instance of me with anIcon as my model" | view | view _ self new model: anIcon. ^view! ! !IconView class methodsFor: 'examples'! iconSampler "This example creates the simplest view to demonstrate the use of instances of class Icon as images for collapsed views. When you evaluate this example, a view will appear. Press the red button to place the view on the screen. Try the collapse message in the blue button menu." "IconView iconSampler" | topView | topView _ StandardSystemView new. topView label: 'Default'. topView insideColor: Form white. topView borderWidth: 2. topView minimumSize: 300. topView maximumSize: 300. topView icon: (Icon constantNamed: #default). topView controller open! ! Dictionary variableSubclass: #IdentityDictionary instanceVariableNames: 'valueArray ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! IdentityDictionary comment: 'The class IdentityDictionary is a subclass of Dictionary in which the lookup is done using == rather than =. It is represented as two parallel ordered collections of keys and values, rather than as a single collection of associations. Instance Variables: *indexed* valueArray of values stored in the dictionary'! !IdentityDictionary methodsFor: 'accessing'! associationAt: key ifAbsent: aBlock "Answer an Association consisting of key and the value of the receiver at that key. If key is not found, evaluate aBlock." | index | index _ self findKey: key ifAbsent: [^aBlock value]. ^Association key: (self basicAt: index) value: (valueArray at: index)! at: key ifAbsent: aBlock "Answer the value at key. If key is not found, evaluate aBlock." | index | index _ self findKey: key ifAbsent: [^aBlock value]. ^valueArray at: index! at: key put: value "Set the value at key to be value." | index | index _ self findKeyOrNil: key. (self basicAt: index) == nil ifTrue: [tally _ tally + 1. self basicAt: index put: key]. valueArray at: index put: value. self fullCheck. ^value! keyAtValue: value ifAbsent: exceptionBlock "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." | theKey | 1 to: self basicSize do: [:index | value == (valueArray at: index) ifTrue: [(theKey _ self basicAt: index) == nil ifFalse: [^theKey]]]. ^exceptionBlock value! keys "Answer a set containing the receiver's keys." | aSet | aSet _ IdentitySet new: self size. self keysDo: [:key | aSet add: key]. ^aSet! ! !IdentityDictionary methodsFor: 'adding'! add: anAssociation "Include newObject as one of the receiver's elements. Answer newObject." self at: anAssociation key put: anAssociation value! ! !IdentityDictionary methodsFor: 'copying'! copy "Answer another instance just like the receiver." | v copy | v _ valueArray. valueArray _ valueArray shallowCopy. copy _ super shallowCopy. valueArray _ v. ^copy! ! !IdentityDictionary methodsFor: 'enumerating'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." | index len | index _ 1. len _ self basicSize. [index <= len] whileTrue: [(self basicAt: index) == nil ifFalse: [aBlock value: (valueArray at: index)]. index _ index + 1]! ! !IdentityDictionary methodsFor: 'dictionary removing'! 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." self removeDangerouslyKey: key ifAbsent: [^aBlock value]! ! !IdentityDictionary methodsFor: 'dictionary enumerating'! associationsDo: aBlock "Evaluate aBlock for associations consisting of the receiver's keys and their values." | index len | index _ 1. len _ self basicSize. [index <= len] whileTrue: [(self basicAt: index) == nil ifFalse: [aBlock value: (Association key: (self basicAt: index) value: (valueArray at: index))]. index _ index + 1]! keysDo: aBlock "Evaluate aBlock for each of the receiver's keys." | index len | index _ 1. len _ self basicSize. [index <= len] whileTrue: [(self basicAt: index) == nil ifFalse: [aBlock value: (self basicAt: index)]. index _ index + 1]! ! !IdentityDictionary methodsFor: 'private'! 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." | index length probe pass | length _ self basicSize. pass _ 1. index _ key identityHash \\ length + 1. [(probe _ self basicAt: index) == nil or: [probe == key]] whileFalse: [(index _ index + 1) > length ifTrue: [index _ 1. pass _ pass + 1. pass > 2 ifTrue: [^self grow findKeyOrNil: key]]]. ^index! noCheckAdd: anAssociation "Assume that the association is in the receiver and add it without checking to make sure." ^self noCheckAdd: anAssociation key with: anAssociation value! noCheckAdd: key with: value "Assume that the key is already in the receiver and store the value without checking to make sure." | index | index _ self findKeyOrNil: key. self basicAt: index put: key. tally _ tally + 1. ^valueArray at: index put: value! removeDangerouslyKey: key ifAbsent: errorBlock "Assume that the key is in the receiver and go fetch its value. If the value is nil, answer the result of evaluating the errorBlock. Otherwise, remove the key from the receiver." | location oldKey length | location _ self findKeyOrNil: key. (self basicAt: location) == nil ifTrue: [^errorBlock value]. self basicAt: location put: nil. valueArray at: location put: nil. tally _ tally - 1. length _ self basicSize. [location _ location = length ifTrue: [1] ifFalse: [location + 1]. (self basicAt: location) == nil] whileFalse: [oldKey _ self findKeyOrNil: (self basicAt: location). location = oldKey ifFalse: [self swap: location with: oldKey]]! setTally "Initialize talley and other instance variables." super setTally. valueArray _ Array new: self basicSize! swap: oneElement with: otherElement "Store otherElement in the position for oneElement, and vice versa." super swap: oneElement with: otherElement. valueArray swap: oneElement with: otherElement! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IdentityDictionary class instanceVariableNames: ''! !IdentityDictionary class methodsFor: 'instance creation'! new: size "Answer a new instance of IdentifyDictionary, whose initial capacity is size. Size is rounded up to a power of 2 if needed." size >= 1 ifFalse: [self error: 'size must be >= 1']. ^super new: (1 bitShift: (size - 1) highBit)! ! Set variableSubclass: #IdentitySet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! IdentitySet comment: 'The class IdentitySet is just like Set, but uses == instead of = for comparisons Instance Variables: *indexed*'! !IdentitySet methodsFor: 'private'! findElementOrNil: anObject "Answer the index of the argument anObject or answer nil." "Copied from Set with equality check changed to identity." | index length probe pass | length _ self basicSize. pass _ 1. index _ anObject identityHash \\ length + 1. [(probe _ self basicAt: index) == nil or: [probe == anObject]] whileFalse: [(index _ index + 1) > length ifTrue: [index _ 1. pass _ pass + 1. pass > 2 ifTrue: [^self grow findElementOrNil: anObject]]]. ^index! ! SwitchController subclass: #IndicatorOnSwitchController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! IndicatorOnSwitchController comment: 'I am a SwitchController that has its View (a SwitchView) highlighted while the model (a Switch) handles the messages it is sent.'! !IndicatorOnSwitchController methodsFor: 'basic control sequence'! sendMessage arguments size = 0 ifTrue: [view indicatorOnDuring: [model perform: selector]] ifFalse: [view indicatorOnDuring: [model perform: selector withArguments: arguments]]! ! DisplayObject subclass: #InfiniteForm instanceVariableNames: 'patternForm ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! InfiniteForm comment: 'Class InfiniteForm represents a Form obtained by replicating a pattern form indefinitely in all directions. Instance Variable: patternForm the pattern to be replicated '! !InfiniteForm methodsFor: 'accessing'! form "Answer the form that represents the replicated pattern." ^patternForm! form: aForm "Set the argument aForm to be the repeated pattern." patternForm _ aForm! offset "Answer the point that is the offset for displaying the receiver, always 0@0." ^0 @ 0! ! !InfiniteForm 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. " | targetBox patternBox | (aForm == Form black and: [patternForm extent = (16 @ 16)]) ifTrue: ["Use patternForm as a mask for BitBlt" aDisplayMedium fill: clipRectangle rule: ruleInteger mask: patternForm] ifFalse: ["Do it iteratively" targetBox _ aDisplayMedium boundingBox intersect: clipRectangle. patternBox _ patternForm boundingBox. (targetBox left truncateTo: patternBox width) to: targetBox right - 1 by: patternBox width do: [:x | (targetBox top truncateTo: patternBox height) to: targetBox bottom - 1 by: patternBox height do: [:y | patternForm displayOn: aDisplayMedium at: x @ y clippingBox: clipRectangle rule: ruleInteger mask: aForm]]]! ! !InfiniteForm methodsFor: 'display box access'! computeBoundingBox "Answer the largest representation of the enclosing rectangle around the image." ^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InfiniteForm class instanceVariableNames: ''! !InfiniteForm class methodsFor: 'instance creation'! with: aForm "Answer a new instance of the receiver whose pattern to be replicated is the argument aForm." ^self new form: aForm! ! Object subclass: #InputSensor instanceVariableNames: '' classVariableNames: 'CurrentCursor CurrentInputState ' poolDictionaries: '' category: 'System-Support'! InputSensor comment: 'Class InputSensor represents an interface to the user input devices. There is at least one instance of the class named Sensor in the system. Class Variables: CurrentCursor reference to the cursor that is currently being displayed CurrentInputState for accessing the hardware'! !InputSensor methodsFor: 'keyboard'! ctrlDown "Answer whether the control key is down." ^self primCtrlDown! flushKeyboard "Remove all characters from the keyboard buffer." [self keyboardPressed] whileTrue: [self keyboard]! keyboard "Answer the next character from the keyboard buffer as a fully decoded (ASCII) character." ^self primKbdNext keyCharacter! keyboardEvent "Answer the next character from the keyboard buffer as a KeyboardEvent." ^self primKbdNext! keyboardPeek "Answer the next character in the keyboard buffer or false if it is empty. self keyboardPressed must be true, else an error is reported." self keyboardPressed ifTrue: [^self primKbdPeek keyCharacter]. self error: 'Cant peek when nothing there'! keyboardPressed "Answer false if the keyboard buffer is empty, else true." "The keyboard queue only contains real keystrokes, so just test if it is non-empty." ^self primKbdPeek notNil! leftShiftDown "Answer whether the left shift key is down." ^self primLeftShiftDown! ! !InputSensor methodsFor: 'mouse'! anyButtonPressed "Answer whether a mouse button is being pressed." ^self buttons > 0! blueButtonPressed "Answer whether only the blue mouse button is being pressed." ^(self buttons bitAnd: 1) ~= 0! mousePoint "Answer a Point indicating the coordinates of the current mouse location." ^self primMousePt! mousePointNext "Answer the next mouse point if red button or tablet is down; false otherwise." self redButtonPressed ifTrue: [^self mousePoint]. ^false! noButtonPressed "Answer whether any mouse button is not being pressed." ^self anyButtonPressed == false! redButtonPressed "Answer whether only the red mouse button is being pressed." ^(self buttons bitAnd: 4) ~= 0! waitButton "Wait for the user to press any mouse button and then answer with the current location of the cursor." [self anyButtonPressed] whileFalse. ^self cursorPoint! waitClickButton "Wait for the user to click (press and then release) any mouse button and then answer with the current location of the cursor." self waitButton. ^self waitNoButton! waitNoButton "Wait for the user to release any mouse button and then answer with the current location of the cursor." [self anyButtonPressed] whileTrue. ^self cursorPoint! yellowButtonPressed "Answer whether only the yellow mouse button is being pressed." ^(self buttons bitAnd: 2) ~= 0! ! !InputSensor methodsFor: 'current cursor'! currentCursor "Answer the instance of Cursor currently displayed." ^CurrentCursor! currentCursor: newCursor "Set newCursor to be the displayed Cursor form." CurrentCursor offset = newCursor offset ifFalse: [self primCursorLocPut: self cursorPoint + newCursor offset]. CurrentCursor _ newCursor. Cursor currentCursor: CurrentCursor! cursorPoint "Answer a Point indicating the cursor location." ^self mousePoint - CurrentCursor offset! cursorPoint: aPoint "Set aPoint to be the current cursor location." ^self primCursorLocPut: aPoint + CurrentCursor offset! ! !InputSensor methodsFor: 'private'! buttons ^self primMouseButtons! primCtrlDown ^CurrentInputState ctrlDown! primCursorLocPut: pt CurrentInputState cursorPoint: pt! primKbdNext ^CurrentInputState keyboardNext! primKbdPeek ^CurrentInputState keyboardPeek! primLeftShiftDown ^CurrentInputState leftShiftDown! primMouseButtons ^CurrentInputState mouseButtons! primMousePt "Poll the mouse to find out its position. Return a Point. Fail if event-driven tracking is used instead of polling. Optional. See Object documentation whatIsAPrimitive. " ^CurrentInputState mousePoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InputSensor class instanceVariableNames: ''! !InputSensor class methodsFor: 'class initialization'! install "Create an instance of InputState for accessing the hardware, and save it in the class variable CurrentInputState." CurrentInputState _ InputState new. CurrentInputState install! ! !InputSensor class methodsFor: 'constants'! default "Answer the default system InputSensor, Sensor." ^Sensor! initSensor "Create the default system InputSensor, Sensor." Sensor _ InputSensor new! ! Object subclass: #InputState instanceVariableNames: 'x y bitState lshiftState rshiftState ctrlState lockState metaState keyboardQueue deltaTime baseTime timeProtect metaKeyState otherMetaKey1State otherMetaKey2State otherMetaKey3State ' classVariableNames: 'BitMax BitMin CtrlKey EmergencyInterruptKey InputProcess InputSemaphore InterruptKey LetterCKey LockKey LshiftKey MetaKey OtherMeta1 OtherMeta2 OtherMeta3 RshiftKey ' poolDictionaries: '' category: 'System-Support'! InputState comment: 'Class InputState represents the state of the user input devices. Instance Variables: x mouse X location y mouse Y location bitState mouse button and keyset state lshiftState <1 or 0> state of left shift key rshiftState <1 or 0> state of right shift key ctrlState <2 or 0> state of ctrl key lockState <4 or 0> state of shift-lock key metaState combined state of the meta keys keyboardQueue of keyboard characters deltaTime sampling ticks since last setting of baseTime baseTime millisecond timer at last resync Class Variables: These are all integers defined in the message to the class initialize. BitMax BitMin CtrlKey EmergencyInterruptKey InputProcess InputSemaphore InterruptKey LetterCKey LockKey LshiftKey MetaKey OtherMeta1 OtherMeta2 OtherMeta3 RshiftKey '! !InputState methodsFor: 'initialize-release'! install "Initialize and connect the receiver to the hardware. Terminate the old input process if any." InputProcess == nil ifFalse: [InputProcess terminate]. self initState. InputSemaphore _ Semaphore new. InputProcess _ [self run] newProcess. InputProcess priority: Processor lowIOPriority. InputProcess resume. self primInputSemaphore: InputSemaphore! ! !InputState methodsFor: 'keyboard'! ctrlDown "Answer whether the left shift key is down." ^ctrlState ~= 0! keyboardNext "Remove and answer the next key in the keyboard buffer." ^keyboardQueue next! keyboardPeek "Answer the next key in the keyboard buffer but do not remove it." ^keyboardQueue peek! leftShiftDown "Answer whether the left shift key is down." ^lshiftState ~= 0! ! !InputState methodsFor: 'mouse'! mouseButtons "Answer the status of the mouse buttons--an Integer between 0 and 7." ^bitState bitAnd: 7! mousePoint "Answer the coordinates of the mouse location." ^self primMousePt! ! !InputState methodsFor: 'cursor'! cursorPoint: aPoint "Set the current cursor position to be aPoint." self primCursorLocPut: aPoint. x _ aPoint x. y _ aPoint y! ! !InputState methodsFor: 'time'! currentTime "Answer the time on the system clock in milliseconds since midnight." timeProtect critical: [deltaTime = 0 ifFalse: [baseTime _ baseTime + (deltaTime * 1000 // 60). deltaTime _ 0]]. ^baseTime! ! !InputState methodsFor: 'user primitive'! userEvent: event "Process the user event."! ! !InputState methodsFor: 'private'! initState timeProtect _ Semaphore forMutualExclusion. timeProtect critical: [deltaTime _ baseTime _ 0]. x _ y _ 0. keyboardQueue _ SharedQueue new: 50. ctrlState _ lshiftState _ rshiftState _ lockState _ metaState _ metaKeyState _ 0. otherMetaKey1State _ otherMetaKey2State _ otherMetaKey3State _ 0. bitState _ 0! keyAt: keyNumber put: value | index mask | index _ keyNumber bitAnd: 255. "Get rid of meta bits" (index < BitMin or: [index > OtherMeta3]) ifTrue: "Not a potential special character" [value = 1 ifTrue: "only look at down strokes" [index = InterruptKey ifTrue: [(lshiftState ~= 0 or: [(keyNumber bitAnd: 16r100) ~= 0]) ifTrue: [self forkEmergencyEvaluatorAt: Processor userInterruptPriority] ifFalse: [[ScheduledControllers interruptName: 'User Interrupt'] fork]] ifFalse: [index = EmergencyInterruptKey ifTrue: [self forkEmergencyEvaluatorAt: Processor userInterruptPriority] ifFalse: [^keyboardQueue nextPut: (KeyboardEvent code: index meta: (metaState bitOr: (keyNumber bitShift: -8)))]]]] ifFalse: [self setStateFor: index with: value. metaState _ (((((ctrlState bitOr: (lshiftState bitOr: rshiftState)) bitOr: lockState) bitOr: metaKeyState) bitOr: otherMetaKey1State) bitOr: otherMetaKey2State) bitOr: otherMetaKey3State]! primCursorLocPut: aPoint "Set the cursor to the point on the screen specified by the argument aPoint. Fail if the argument is not a Point. Essential. See Object documentation whatIsAPrimitive." ^self primCursorLocPutAgain: aPoint rounded! primCursorLocPutAgain: aPoint "Set the cursor to the point on the screen specified by the argument aPoint. Fail if the argument is not a Point. Essential. See Object documentation whatIsAPrimitive." ^self primitiveFailed! primInputSemaphore: aSemaphore "Install the argument (a Semaphore) as the object to be signalled whenever an input event occurs. The semaphore will be signaled once for every word placed in the input buffer by an I/O device. Fail if the argument is neither a Semaphore nor nil. Essential. See Object whatIsAPrimitive." ^self primitiveFailed! primInputWord "Return the next word from the input buffer and remove the word from the buffer. This message should be sent just after the input semaphore finished a wait (was sent a signal by an I/O device). Fail of the input buffer is empty. Essential. See Object documentation whatIsAPrimitive." ^self primitiveFailed! primMenuEvent: menu item: item "Process menu selections from the host menu system"! primMousePt "Poll the mouse to find out its position. Return a Point. Fail if event-driven tracking is used instead of polling. Optional. See Object documentation whatIsAPrimitive. " ^x @ y! primSampleInterval: anInteger "Set the minimum time span between event driven mouse position samples. The argument is a number of milliseconds. Fail if the argument is not a SmallInteger. Essential. See Object documentation whatIsAPrimitive. " ^self primitiveFailed! primUserEvent: event "Process the user event." [ self userEvent: event ] fork! primWindowEvent: event "Process the system window event." | code numA args index block | code _ event bitAnd: 15. numA _ (event bitShift: -4) bitAnd: 15. args _ Array new: numA. index _ 0. [numA > index ] whileTrue: [index _ index + 1. InputSemaphore wait. args at: index put: self primInputWord]. code = 6 "menu bar selection" ifTrue: [block _ [self primMenuEvent: ((args at: 1) bitShift: -8) item: ((args at: 1) bitAnd: 255)]] ifFalse: [ code = 7 "enter window" ifTrue: [block _ [SystemCall getSelection]] ifFalse: [ code =8 "exit window" ifTrue: [block _ [SystemCall putSelection]] ifFalse: [ code =9 "resize window" ifTrue: [block _ [ScheduledControllers adjustForNewDisplayExtent]] ifFalse: [ code =10 "collapse window" ifTrue: [block _ [Smalltalk suspend]] ifFalse: [ code =11 "open window" ifTrue: [block _ [ScheduledControllers adjustForNewDisplayExtent]] ifFalse: [ code =12 "repaint window" ifTrue: [block _ []] ifFalse: [ code =13 "quit" ifTrue: [block _ [Smalltalk exitSmalltalk]] ifFalse: [ code =14 "window stop" ifTrue: [block _ [Smalltalk suspend]] ifFalse: [ code =15 "bad input event" ifTrue: [block _ [self error: 'Bad event type']] ifFalse: [block _ [self error: 'Unknown Meta System event']]]]]]]]]]]. block forkAt: Processor userInterruptPriority! run "This is the loop that actually processes input events." | word type param highTime lowTime | [true] whileTrue: [InputSemaphore wait. "Test for mouse X/Y events here to avoid an activation." word _ self primInputWord. type _ word bitShift: -12. param _ word bitAnd: 4095. "Mouse X" type = 1 ifTrue: [x _ param] "Mouse Y" ifFalse: [type = 2 ifTrue: [y _ param] "Delta time"ifFalse: [type = 0 ifTrue: [timeProtect critical: [deltaTime _ deltaTime + param]] "Key down" ifFalse: [type = 3 ifTrue: [self keyAt: param put: 1] "Key up" ifFalse: [type = 4 ifTrue: [self keyAt: param put: 0] "Reset time"ifFalse: [type = 5 ifTrue: [InputSemaphore wait. highTime _ self primInputWord. InputSemaphore wait. lowTime _ self primInputWord. timeProtect critical: [baseTime _ (highTime bitShift: 16) + lowTime. deltaTime _ 0]] ifFalse: [type = 7 ifTrue: [self primWindowEvent: word] ifFalse: [type = 8 ifTrue: [self primUserEvent: word] ifFalse: [self primWindowEvent: 15 "Bad event type"]]]]]]]]]! setStateFor: index with: state "Set the state keys" | mask | index = LshiftKey ifTrue: [^lshiftState _ state]. index = RshiftKey ifTrue: [^rshiftState _ state]. index = CtrlKey ifTrue: [^ctrlState _ state bitShift: 1]. index = MetaKey ifTrue: [^metaKeyState _ state bitShift: 2]. index = OtherMeta1 ifTrue: [^otherMetaKey1State _ state bitShift: 3]. "The first four bits must agree with inputWord tag bits" index = OtherMeta2 ifTrue: [^otherMetaKey2State _ state bitShift: 4]. index = OtherMeta3 ifTrue: [^otherMetaKey3State _ state bitShift: 5]. index = LockKey ifTrue: [^lockState _ state bitShift: 6]. (index >= BitMin and: [index <= BitMax]) ifTrue: [mask _ 1 bitShift: index - BitMin. state = 1 ifTrue: [bitState _ bitState bitOr: mask] ifFalse: [bitState _ bitState bitAnd: -1 - mask]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InputState class instanceVariableNames: ''! !InputState class methodsFor: 'class initialization'! initialize "Define parameters" "InputState initialize" InterruptKey _ 3. EmergencyInterruptKey _ 227. BitMin _ 128. "Min mouse/keyset bit code" BitMax _ 135. "Max mouse/keyset bit code" LshiftKey _ 136. RshiftKey _ 137. CtrlKey _ 138. LockKey _ 139. MetaKey _ 140. OtherMeta1 _ 141. OtherMeta2 _ 142. OtherMeta3 _ 143! ! !InputState class methodsFor: 'key settings'! emergencyInterruptKey "Answer the code for the key that causes an emergency interrupt." ^EmergencyInterruptKey! emergencyInterruptKey: anInteger "Set the code for the key that causes an emergency interrupt." EmergencyInterruptKey _ anInteger! interruptKey "Answer the code for the key that causes an interrupt." ^InterruptKey! interruptKey: anInteger "Set the code for the key that causes an interrupt." InterruptKey _ anInteger! ! InputState initialize! Model subclass: #Inspector instanceVariableNames: 'object field ' classVariableNames: 'ListMenu TextMenu ' poolDictionaries: '' category: 'Interface-Inspector'! Inspector comment: 'I represent a query path into the internal representation of an object. The value of fields can be inspected by selecting the field name, and can be changed using ''accept''. Instance Variables: object any object to be queried field name of field being viewed'! !Inspector methodsFor: 'initialization'! inspect: anObject anObject == object ifTrue: [^ self update]. object _ anObject. self changed: #field! object "Answer the object being inspected by the receiver." ^object! ! !Inspector methodsFor: 'field list'! field ^ field! field: selection field _ selection. self changed: #text! fieldIndex "Answer the offset corresponding to the currently selected field." field first isDigit ifTrue: [^ Integer readFromString: field] ifFalse: [^ object class allInstVarNames indexOf: field]! fieldList "Answer an Array consisting of 'self' and the instance variable names of the inspected object. Up to 40 indices are given for variable length objects." | max | max _ object basicSize. ^(Array with: 'self'), object class allInstVarNames, ((max <= 40 ifTrue: [1 to: max] ifFalse: [(1 to: 30) , (max-10 to: max)]) collect: [:i | i printString])! fieldMenu "Inspector flushMenus" field == nil ifTrue: [^ nil]. ListMenu == nil ifTrue: [ListMenu _ ActionMenu labels: 'inspect' selectors: #(inspectField)]. ^ ListMenu! fieldValue field = 'self' ifTrue: [^object]. field first isDigit ifTrue: [^object basicAt: self fieldIndex] ifFalse: [^object instVarAt: self fieldIndex]! printItems "Answer whether the elements of the fieldList need to be converted to strings" ^false! ! !Inspector methodsFor: 'text'! text field == nil ifTrue: [^ Text new]. ^ self fieldValue printString asText! textMenu "Inspector flushMenus" TextMenu == nil ifTrue: [TextMenu _ ActionMenu labels: 'again\undo\copy\cut\paste\do it\print it\inspect\accept\cancel' withCRs lines: #(2 5 8) selectors: #(again undo copySelection cut paste doIt printIt inspectIt accept cancel)]. ^ TextMenu! ! !Inspector methodsFor: 'doIt/accept/explain'! acceptText: aText from: aController | val | object class == CompiledMethod ifTrue: [^false]. field == nil ifTrue: [^false]. val _ self evaluateText: aText string from: aController ifFail: [^ false]. field first isLetter ifTrue: [object instVarAt: self fieldIndex put: val] ifFalse: [object basicAt: self fieldIndex put: val]. self changed: #text. ^ true! doItContext ^ nil! doItReceiver "Answer the object that should be informed of the result of evaluating a text selection." ^object! doItValue: ignored! evaluateText: aText from: aController ifFail: failBlock ^ Compiler new evaluate: aText in: self doItContext to: self doItReceiver notifying: aController ifFail: failBlock! ! !Inspector methodsFor: 'updating'! update "Reshow contents, assuming selected value may have changed" field ~~ nil ifTrue: [self changed: #text]! ! !Inspector methodsFor: 'menu commands'! inspectField self fieldValue inspect! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Inspector class instanceVariableNames: ''! !Inspector class methodsFor: 'instance creation'! inspect: anObject "Answer an instance of me to provide an inspector for anObject." ^self new inspect: anObject! ! !Inspector class methodsFor: 'initialization'! flushMenus ListMenu _ TextMenu _ nil! ! StandardSystemView subclass: #InspectorView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Inspector'! InspectorView comment: 'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the interface to an object Inspector. I have two subViews, an InspectListView and an InspectCodeView.'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InspectorView class instanceVariableNames: ''! !InspectorView class methodsFor: 'instance creation'! inspector: anInspector "Answer an instance of me on the model, anInspector. Label and minimum size are not set." | anInspectorView | anInspectorView _ InspectorView new. anInspectorView model: anInspector. self view: anInspector in: (0@0 extent: 1@1) of: anInspectorView. ^anInspectorView! open: anInspector "Create and schedule an instance of me on the model, anInspector." (self buildScheduledView: anInspector) controller open! view: anInspector in: area of: superView "Create proportioned List and Code views on anInspector in area of superView" | mid | mid _ area left + (area width * 0.3). superView addSubView: (SelectionInListView on: anInspector printItems: anInspector printItems oneItem: false aspect: #field change: #field: list: #fieldList menu: #fieldMenu initialSelection: #field) in: (area copy right: mid) borderWidth: 1. superView addSubView: (CodeView on: anInspector aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: nil) in: (area copy left: mid) borderWidth: 1! ! !InspectorView class methodsFor: 'private'! buildScheduledView: anInspector | topView | topView _ self model: anInspector label: anInspector object class name minimumSize: 180 @ 180. self view: anInspector in: (0@0 extent: 1@1) of: topView. ^ topView! ! InstructionStream subclass: #InstructionPrinter instanceVariableNames: 'stream oldPC ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! InstructionPrinter comment: 'An InstructionPrinter can print the object code of a CompiledMethod in symbolic format. It prints into stream, and uses oldPC to know how many bytes to print in the listing. The inherited variable "sender" is used in an ugly way to hold the method being printed. Instance Variables: stream accumulates symbolic output oldPC remembers where current instruction started '! !InstructionPrinter methodsFor: 'initialize-release'! printInstructionsOn: aStream "Append to the stream, aStream, a description of each bytecode in the instruction stream." | end | stream _ aStream. end _ self method endPC. oldPC _ pc. [pc <= end] whileTrue: [super interpretNextInstructionFor: self]! ! !InstructionPrinter methodsFor: 'instruction decoding'! blockReturnTop "Print the ReturnTopOfStack bytecode." self print: 'blockReturn'! doDup "Print the Duplicate Top of Stack bytecode." self print: 'dup'! doPop "Print the Remove Top of Stack bytecode." self print: 'pop'! jump: offset "Print the Unconditional Jump bytecode." self print: 'jumpTo: ' , (pc + offset) printString! jump: offset if: condition "Print the Conditional Jump bytecode." self print: (condition ifTrue: ['jumpTrue: '] ifFalse: ['jumpFalse: ']) , (pc + offset) printString! methodReturnConstant: value "Print the Return Constant bytecode." self print: 'return: ' , value printString! methodReturnReceiver "Print the Return Self bytecode." self print: 'returnSelf'! methodReturnTop "Print the Return Top of Stack bytecode." self print: 'returnTop'! popIntoLiteralVariable: anAssociation "Print the Removes the Top of the Stack and Stores it into a Literal Variable bytecode." self print: 'popIntoLit: ' , anAssociation key! popIntoReceiverVariable: offset "Print the Removes the Top of the Stack and Stores it into an Instance Variable bytecode." self print: 'popIntoRcvr: ' , offset printString! popIntoTemporaryVariable: offset "Print the Removes the Top of the Stack and Stores it into a Temporary Variable bytecode." self print: 'popIntoTemp: ' , offset printString! pushActiveContext "Print the Push the Active Context on the Top of its Own Stack bytecode." self print: 'pushThisContext: '! pushConstant: value "Print the Push the Constant, value, on the Top of the Stack bytecode." self print: 'pushConstant: ' , value printString! pushLiteralVariable: anAssociation "Print the Push the Contents of anAssociation on the Top of the Stack bytecode." self print: 'pushLit: ' , anAssociation key! pushReceiver "Print the Push the Active Context's Receiver on the Top of the Stack bytecode." self print: 'self'! pushReceiverVariable: offset "Print the Push the Contents of the Receiver's Instance Variable whose Index is the argument, offset, on the Top of the Stack bytecode." self print: 'pushRcvr: ' , offset printString! pushTemporaryVariable: offset "Print the Push the Contents of the Temporary Variable whose Index is the argument, offset, on the Top of the Stack bytecode." self print: 'pushTemp: ' , offset printString! send: selector super: supered numArgs: numberArguments "Print the Send a Message with Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." self print: (supered ifTrue: ['superSend: '] ifFalse: ['send: ']) , selector! storeIntoLiteralVariable: anAssociation "Print the Store the Top of the Stack into a Literal Variable of the Method bytecode." self print: 'storeIntoLit: ' , anAssociation key! storeIntoReceiverVariable: offset "Print the Store the Top of the Stack into an Instance Variable of the Method bytecode." self print: 'storeIntoRcvr: ' , offset printString! storeIntoTemporaryVariable: offset "Print the Store the Top of the Stack into a Temporary Variable of the Method bytecode." self print: 'storeIntoTemp: ' , offset printString! ! !InstructionPrinter methodsFor: 'printing'! print: instruction "Append to the receiver a description of the bytecode, instruction." | code | stream print: oldPC; space. stream nextPut: $<. oldPC to: pc - 1 do: [:i | code _ (self method at: i) storeStringRadix: 16. stream nextPut: (code size < 5 ifTrue: [$0] ifFalse: [code at: 4]). stream nextPut: code last; space]. stream skip: -1. stream nextPut: $>. stream space. stream nextPutAll: instruction. stream cr. oldPC _ pc "(InstructionPrinter compiledMethodAt: #print:) symbolic."! ! Object subclass: #InstructionStream instanceVariableNames: 'sender pc ' classVariableNames: 'SpecialConstants ' poolDictionaries: '' category: 'Kernel-Methods'! InstructionStream comment: 'As a superclass of contexts, class InstructionStream stores the return pointer in sender, and the current position in its method in pc. This class by itself has the ability to interpret the byte-encoded Smalltalk instruction set and maintains a program counter (pc) for streaming through CompiledMethods. Contexts thus inherit all this capability and, for other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function. Instance Variables: sender , sometimes pc pointing into the receiver''s method Class Variable: SpecialConstants of special constants such as true, false, and nil '! !InstructionStream methodsFor: 'testing'! willReturn "Answer whether the next bytecode is a return." ^(self method at: pc) between: 120 and: 125! willSend "Answer whether the next bytecode is a message-send." | byte | byte _ self method at: pc. byte < 128 ifTrue: [^ false]. byte >= 176 "special send or short send" ifTrue: [^ byte ~= 200]. "but not blockCopy" ^ byte between: 131 and: 134 "long sends"! willStorePop "Answer whether the next bytecode is a store-pop." | byte | byte _ self method at: pc. ^byte = 130 or: [byte between: 96 and: 111]! ! !InstructionStream methodsFor: 'decoding'! interpretJump | t | t _ self method at: pc. (t between: 144 and: 151) ifTrue: [pc _ pc + 1. ^t - 143]. (t between: 160 and: 167) ifTrue: [pc _ pc + 2. ^(t - 164) * 256 + (self method at: pc - 1)]. ^nil! interpretNextInstructionFor: client "Send to the argument, client, a message that specifies the type of the the next instruction." | byte type offset method | method_ self method. byte_ method at: pc. type_ byte // 16. offset_ byte \\ 16. pc_ pc+1. type=0 ifTrue: [^client pushReceiverVariable: offset]. type=1 ifTrue: [^client pushTemporaryVariable: offset]. type=2 ifTrue: [^client pushConstant: (method literalAt: offset+1)]. type=3 ifTrue: [^client pushConstant: (method literalAt: offset+17)]. type=4 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+1)]. type=5 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+17)]. type=6 ifTrue: [offset<8 ifTrue: [^client popIntoReceiverVariable: offset] ifFalse: [^client popIntoTemporaryVariable: offset-8]]. type=7 ifTrue: [offset=0 ifTrue: [^client pushReceiver]. offset<8 ifTrue: [^client pushConstant: (SpecialConstants at: offset)]. offset=8 ifTrue: [^client methodReturnReceiver]. offset<12 ifTrue: [^client methodReturnConstant: (SpecialConstants at: offset-8)]. offset=12 ifTrue: [^client methodReturnTop]. offset=13 ifTrue: [^client blockReturnTop]. offset>13 ifTrue: [^self error: 'unusedBytecode']]. type=8 ifTrue: [^self interpretExtension: offset in: method for: client]. type=9 ifTrue: "short jumps" [offset<8 ifTrue: [^client jump: offset+1]. ^client jump: offset-8+1 if: false]. type=10 ifTrue: "long jumps" [byte_ method at: pc. pc_ pc+1. offset<8 ifTrue: [^client jump: offset-4*256 + byte]. ^client jump: (offset bitAnd: 3)*256 + byte if: offset<12]. type=11 ifTrue: [^client send: (Smalltalk specialSelectorAt: offset+1) super: false numArgs: (Smalltalk specialNargsAt: offset+1)]. type=12 ifTrue: [^client send: (Smalltalk specialSelectorAt: offset+17) super: false numArgs: (Smalltalk specialNargsAt: offset+17)]. type>12 ifTrue: [^client send: (method literalAt: offset+1) super: false numArgs: type-13]! ! !InstructionStream methodsFor: 'scanning'! addFieldIndexTo: set "If this instruction is an instVar reference, add its index (offset+1) to set." | byte byte2 | byte _ self method at: pc. byte < 16 ifTrue: [^ set add: byte + 1]. "load field" (byte >= 96 and: [byte <= 142]) ifTrue: [(byte <= 103) ifTrue: "short store-pop" [^ set add: byte - 96 + 1]. (byte between: 128 and: 130) ifTrue: "extended field access" [byte2 _ self method at: pc+1. byte2 < 64 ifTrue: [^ set add: byte2 \\ 64 + 1]]. (byte between: 140 and: 142) ifTrue: "expanded field access" [(self method at: pc+1) = 0 ifTrue: [^ set add: (self method at: pc+2) + 1]]]! addSelectorTo: set "If this instruction is a send, add its selector to set." | byte literalNumber | byte _ self method at: pc. byte < 128 ifTrue: [^self]. byte >= 176 ifTrue: ["special byte or short send" byte >= 208 ifTrue: [set add: (self method literalAt: (byte bitAnd: 15) + 1)] ifFalse: [set add: (Smalltalk specialSelectorAt: byte - 176 + 1)]] ifFalse: [(byte between: 131 and: 134) ifTrue: [literalNumber _ byte odd ifTrue: [(self method at: pc + 1) \\ 32] ifFalse: [self method at: pc + 2]. set add: (self method literalAt: literalNumber + 1)]]! followingByte "Answer the following bytecode." ^self method at: pc + 1! method "Answer the compiled method that supplies the receiver's bytecodes." ^sender "method access when used alone (not as part of a context)"! nextByte "Answer the next bytecode." ^self method at: pc! pc "Answer the index of the next bytecode." ^pc! scanFor: scanBlock "Answer the index of the first bytecode for which scanBlock answer true when supplied with that bytecode." | method end byte type | method _ self method. end _ method endPC. [pc <= end] whileTrue: [(scanBlock value: (byte _ method at: pc)) ifTrue: [^true]. type _ byte // 16. pc _ type = 8 ifTrue: ["extensions" pc + (#(2 2 2 2 3 2 3 1 1 1 1 1 3 3 3 1) at: byte \\ 16 + 1)] ifFalse: [type = 10 ifTrue: [pc + 2"long jumps"] ifFalse: [pc + 1]]]. ^false! ! !InstructionStream methodsFor: 'private'! interpretExpansion: offset in: method for: client | type offset2 | "pc has already been incremented by 1" ((offset < 12) or: [offset = 15]) ifTrue: [^self error: 'unusedBytecode']. "extended pushes and pops" type _ (method at: pc). offset2 _ (method at: pc +1). pc _ pc + 2. offset = 12 ifTrue: [type = 0 ifTrue: [^client pushReceiverVariable: offset2]. type = 1 ifTrue: [^client pushTemporaryVariable: offset2]. type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)]. type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 13 ifTrue: [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2]. type = 2 ifTrue: [^self error: 'illegalStore']. type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 14 ifTrue: [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2]. type = 2 ifTrue: [^self error: 'illegalStore']. type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]. self error: 'unusedTypeIndex'! interpretExtension: offset in: method for: client | numberArguments literalNumber type offset2 | "pc has already been incremented by 1" offset < 3 ifTrue: ["extended pushes and pops" type _ (method at: pc) // 64. offset2 _ (method at: pc) \\ 64. pc _ pc + 1. offset = 0 ifTrue: [type = 0 ifTrue: [^client pushReceiverVariable: offset2]. type = 1 ifTrue: [^client pushTemporaryVariable: offset2]. type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)]. type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 1 ifTrue: [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 2 ifTrue: [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]]. offset < 7 ifTrue: ["extended sends" offset odd ifTrue: [numberArguments _ (method at: pc) // 32. literalNumber _ (method at: pc) \\ 32. pc _ pc + 1] ifFalse: [numberArguments _ method at: pc. literalNumber _ method at: pc + 1. pc _ pc + 2]. ^client send: (method literalAt: literalNumber + 1) super: offset > 4 numArgs: numberArguments]. offset = 7 ifTrue: [^client doPop]. offset = 8 ifTrue: [^client doDup]. offset = 9 ifTrue: [^client pushActiveContext]. ^self interpretExpansion: offset in: method for: client! method: method pc: startpc sender _ method. "allows this class to stand alone as a method scanner" pc _ startpc! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InstructionStream class instanceVariableNames: ''! !InstructionStream class methodsFor: 'class initialization'! initialize "Initialize an array of special constants returned by single-bytecode returns." "InstructionStream initialize." SpecialConstants _ (Array with: true with: false with: nil) , (Array with: -1 with: 0 with: 1 with: 2)! ! !InstructionStream class methodsFor: 'instance creation'! on: method "Answer a new InstructionStream on the argument, method." ^self new method: method pc: method initialPC! ! InstructionStream initialize! Number subclass: #Integer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Numeric-Numbers'! Integer comment: 'Class Integer is a common abstract superclass for all Integer implementations. Subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. Subclasses must implement methods for the private message highBit'! !Integer methodsFor: 'arithmetic'! * aNumber "Answer the result of multiplying the receiver by the argument, aNumber." aNumber isInteger ifTrue: [^(self digitMultiply: aNumber neg: self negative ~~ aNumber negative) truncated] ifFalse: [^self retry: #* coercing: aNumber]! + aNumber "Answer the sum of the receiver and the argument, aNumber." aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^(self digitAdd: aNumber) truncated] ifFalse: [^self digitSubtract: aNumber]] ifFalse: [^self retry: #+ coercing: aNumber]! - aNumber "Answer the difference between the receiver and aNumber." aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^self digitSubtract: aNumber] ifFalse: [^self digitAdd: aNumber]] ifFalse: [^self retry: #- coercing: aNumber]! / aNumber "Answer the result of dividing receiver by the argument, anInteger, if the division is exact." | quoRem | aNumber isInteger ifTrue: [quoRem _ self digitDiv: aNumber neg: self negative ~~ aNumber negative. (quoRem at: 2) = 0 ifTrue: [^(quoRem at: 1) truncated] ifFalse: [^(Fraction numerator: self denominator: aNumber) reduced]] ifFalse: [^self retry: #/ coercing: aNumber]! // aNumber "Answer the result of dividing the receiver by the argument. The result is rounded down towards negative infinity to make it a whole integer." | q | aNumber = 0 ifTrue: [^self error: 'division by 0']. self = 0 ifTrue: [^0]. q _ self quo: aNumber. (q negative ifTrue: [q * aNumber ~= self] ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) ifTrue: [^q - 1"Truncate towards minus infinity"] ifFalse: [^q]! quo: aNumber "Answer the result of dividing the receiver by the argument. The result is rounded down towards zero to make it a whole integer." | ng quo | aNumber isInteger ifTrue: [ng _ self negative == aNumber negative == false. quo _ (self digitDiv: aNumber neg: ng) at: 1. (quo lastDigit = 0 and: [quo digitLength >= 2]) ifTrue: [^(quo growby: -1) truncated]. ^quo truncated] ifFalse: [^self retry: #quo: coercing: aNumber]! sqrtTruncated "Integer Square root using Newton's approximation. Algorithm from Dr. Dobb's Journal of Software Tools for the Professional Programmer. December 1987, page 50 by Ray Mariella -- with some help by Issac Newton. Performance over floating sqrt is on the order of 10 to 1." | guess1 guess2 sqrrt infi | self <= 0 ifTrue: [ self = 0 ifTrue: [^0] ifFalse: [^self error: 'sqrt invalid for x < 0']]. guess1 _ infi _ 1. guess2 _ self. [infi _ infi bitShift: 1. infi < guess2] whileTrue: [guess2 _ guess2 bitShift: -1. guess1 _ infi]. guess1 _ guess1 + guess2. guess1 _ guess1 bitShift: -1. "Newtons method" infi _ self // guess1. sqrrt _ infi + guess1. sqrrt _ sqrrt bitShift: -1. ^sqrrt! \\ aNumber "Answer the result of takeing the receiver modulo the argument. The result is the remainder rounded towards negative infinity, of the receiver divided by the argument. The remainder is defined in terms of //. The result has the same sign as the argument: e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, -9\\-4 = -1 " ^self - (self // aNumber * aNumber)! ! !Integer methodsFor: 'testing'! even "Answer whether the receiver is an even number." ^((self digitAt: 1) bitAnd: 1) = 0! isInteger "Answer that the receiver is an Integer." ^true! ! !Integer methodsFor: 'comparing'! < anInteger "Answer whether the receiver is less than the argument." anInteger isInteger ifTrue: [self negative == anInteger negative ifTrue: [self negative ifTrue: [^(self digitCompare: anInteger) > 0] ifFalse: [^(self digitCompare: anInteger) < 0]] ifFalse: [^self negative]] ifFalse: [^self retry: #< coercing: anInteger]! <= anInteger "Answer whether the receiver is less than or equal to the argument." ^super <= anInteger! = anInteger "Answer whether the receiver is equal to the argument." anInteger isInteger ifTrue: [anInteger positive & self positive | (anInteger negative & self negative) ifTrue: [^(self digitCompare: anInteger) = 0] ifFalse: [^false]] ifFalse: [^self retry: #= coercing: anInteger]! > anInteger "Answer whether the receiver is greater than the argument." anInteger isInteger ifTrue: [self negative == anInteger negative ifTrue: [self negative ifTrue: [^(self digitCompare: anInteger) < 0] ifFalse: [^(self digitCompare: anInteger) > 0]] ifFalse: [^anInteger negative]] ifFalse: [^self retry: #> coercing: anInteger]! >= anInteger "Answer whether the receiver is greater than or equal to the argument." ^super >= anInteger! hash "Answer a SmallInteger unique to the receiver." ^(self lastDigit bitShift: 8) + (self digitAt: 1)! ~= anInteger "Answer whether the receiver is not equal to the argument." ^super ~= anInteger! ! !Integer methodsFor: 'truncation and round off'! ceiling "Answer the receiver itself." ^self! floor "Answer the receiver itself." ^self! rounded "Answer the receiver itself." ^self! truncated "Answer the receiver itself." ^self! ! !Integer methodsFor: 'enumerating'! timesRepeat: aBlock "Evaluate the argument, aBlock, the number of times represented by the receiver." | count | count _ 1. [count <= self] whileTrue: [aBlock value. count _ count + 1]! ! !Integer methodsFor: 'factorization and divisibility'! factorial "Answer the factorial of the receiver. Fail if the receiver is less than 0. For example, 6 factorial == 6*5*4*3*2*1." self > 0 ifTrue: [^self * (self - 1) factorial]. self = 0 ifTrue: [^1]. self error: 'factorial invalid for: ' , self printString! gcd: anInteger "Answer the greatest common divisor of the receiver and anInteger." "Euclid's algorithm. " | m n t | m _ self abs max: anInteger abs. n _ self abs min: anInteger abs. n = 0 ifTrue:[^self error: 'division by 0']. [n = 0] whileFalse: [t _ n. n _ m \\ n. m _ t]. ^m! lcm: n "Answer the least common multiple of the receiver and the argument, n." ^self // (self gcd: n) * n! ! !Integer methodsFor: 'bit manipulation'! allMask: mask "Treat the argument as a bit mask. Answer whether all of the bits that are 1 in the argument are 1 in the receiver." ^mask = (self bitAnd: mask)! anyMask: mask "Treat the argument as a bit mask. Answer whether any of the bits that are 1 in the argument are 1 in the receiver." ^0 ~= (self bitAnd: mask)! bitAnd: aNumber "Answer the logical AND of the twos-complement representation of the receiver with the twos-complement representation of the argument." | anInteger | anInteger _ aNumber truncated. ^self digitLogic: anInteger op: #bitAnd: length: (self digitLength max: anInteger digitLength)! bitAt: i "Answer the bit at the ith position." ^(self bitAnd: (1 bitShift: i - 1)) = 0 ifTrue: [0] ifFalse: [1]! bitInvert "Answer an Integer whose bits are the complement of the receiver." ^-1 - self! bitOr: aNumber "Answer the logical OR of the twos-complement representation of the receiver with the twos-complement representation of the argument." | anInteger | anInteger _ aNumber truncated. ^self digitLogic: anInteger op: #bitOr: length: (self digitLength max: anInteger digitLength)! bitShift: anInteger "Answer the result of a logical SHIFT of the twos-complement representation of the receiver with the twos-complement representation of the argument. Shift left if the argument is positive, right if the argument is negative. Zeros are shifted in from the right in left shifts. The sign bit is extended in right shifts." | result abs | anInteger >= 0 ifTrue: [^(self digitLshift: (anInteger bitAnd: 7) bytes: (anInteger bitShift: -3) lookfirst: true) truncated]. abs _ 0 - anInteger. result _ (self digitRshift: (abs bitAnd: 7) bytes: (abs bitShift: -3) lookfirst: self digitLength) truncated. (self negative and: [self anyBitTo: abs]) ifTrue: [result _ result - 1]. ^result! bitXor: aNumber "Answer the result of a logical XOR of the twos-complement representation of the receiver with the twos-complement representation of the argument." | anInteger | anInteger _ aNumber truncated. ^self digitLogic: anInteger op: #bitXor: length: (self digitLength max: anInteger digitLength)! highBit "Answer the index of the high order bit of the binary representation of the receiver." self subclassResponsibility! noMask: mask "Treat the argument as a bit mask. Answer whether none of the bits that are 1 in the argument are 1 in the receiver." ^0 = (self bitAnd: mask)! ! !Integer methodsFor: 'printing'! isLiteral "Answer that the receiver has a literal text form recognized by the compiler. " ^true! printOn: aStream "Print a representation of the receiver on the stream, aStream, in base 10." self printOn: aStream base: 10 "default print radix"! printOn: aStream base: b "Print a representation of the receiver on the stream, aStream, in base b where 2<=b<=256." | digits source dest i j pos t rem | i _ self digitLength. "Estimate size of result, conservatively" digits _ Array new: i * 8. pos _ 0. dest _ i <= 1 ifTrue: [self] ifFalse: [LargePositiveInteger new: i]. source _ self. [i > 1] whileTrue: [rem _ 0. j _ i. [j > 0] whileTrue: [t _ (rem bitShift: 8) + (source digitAt: j). dest digitAt: j put: t // b. rem _ t \\ b. j _ j - 1]. pos _ pos + 1. digits at: pos put: rem. source _ dest. (source digitAt: i) = 0 ifTrue: [i _ i - 1]]. (dest digitAt: 1) printOn: aStream base: b. [pos > 0] whileTrue: [aStream nextPut: (Character digitValue: (digits at: pos)). pos _ pos - 1]! printStringRadix: radix "Answer a String representing the receiver as a base radix integer." | aStream | aStream _ WriteStream on: (String new: 16). self printOn: aStream base: radix. ^aStream contents! storeStringRadix: radix "Answer a String representing the receiver as a base radix integer in Smalltalk syntax (e.g. 8r377)." | aStream | aStream _ WriteStream on: (String new: 16). radix ~= 10 ifTrue: [radix printOn: aStream. aStream nextPutAll: 'r']. self printOn: aStream base: radix. ^aStream contents! ! !Integer methodsFor: 'converting'! asCharacter "Answer the Character whose value is the receiver." ^Character value: self! asFloat "Answer a Float that represents the receiver." | factor sum | sum _ 0.0. factor _ self sign asFloat. 1 to: self size do: [:i | sum _ (self digitAt: i) * factor + sum. factor _ factor * 256.0]. ^sum! asFraction "Answer a Fraction that represents the receiver." ^Fraction numerator: self denominator: 1! asInteger "Answer the receiver itself." ^self! ! !Integer methodsFor: 'coercing'! coerce: aNumber "Answer an Integer that is the argument, aNumber, truncated." ^aNumber truncated! generality "Answer the number representing the ordering of the receiver in the generality hierarchy." ^40! ! !Integer methodsFor: 'system primitives'! digitAt: n "Answer the value of an apparent indexable field." ^self subclassResponsibility! digitAt: index put: value "Store the argument value in the indexable field of the receiver indicated by index. Answer with the value that was stored." ^self subclassResponsibility! digitLength "Answer the number of indexable fields in the receiver." ^self subclassResponsibility! lastDigit "Answer the last digit of the integer." ^self digitAt: self digitLength! lastDigitGet: digit "Store the argument, digit, as the last digit of the integer. Answer digit." ^self at: self digitLength put: digit! ! !Integer methodsFor: 'private'! anyBitTo: pos "Answer whether any bit from 1 to pos is non-zero, for testing for loss of significant bits when shifting right" 1 to: pos - 1 // 8 do: [:i | (self digitAt: i) ~= 0 ifTrue: [^true]]. ^(self digitAt: pos + 7 // 8) anyMask: (#(1 3 7 15 31 63 127 255 ) at: pos - 1 \\ 8 + 1)! copyto: x "Copy the receiver into the argument, x. Answer x." 1 to: (self digitLength min: x digitLength) do: [:i | x digitAt: i put: (self digitAt: i)]. ^x! denominator "Answer the denominator of the receiver, which is 1." ^1! digitAdd: arg "Answer the result of adding the receiver to the argument, arg." | len arglen i accum sum | accum _ 0. (len _ self digitLength) < (arglen _ arg digitLength) ifTrue: [len _ arglen]. "Open code max: for speed" sum _ Integer new: len neg: self negative. i _ 1. [i <= len] whileTrue: [accum _ (accum bitShift: -8) + (self digitAt: i) + (arg digitAt: i). sum digitAt: i put: (accum bitAnd: 255). i _ i + 1]. accum > 255 ifTrue: [sum _ sum growby: 1. sum lastDigitGet: (accum bitShift: -8)]. ^sum! digitCompare: arg "Answer the result of comparing the receiver to the argument, arg, where both are presumed to have the same sign. Answer -1 if arg is less than the receiver, 1 if arg is greater than the receiver, and 0 otherwise." | len arglen t5 t6 | len _ self digitLength. (arglen _ arg digitLength) ~= len ifTrue: [arglen > len ifTrue: [^-1] ifFalse: [^1]]. [len > 0] whileTrue: [(t5 _ arg digitAt: len) ~= (t6 _ self digitAt: len) ifTrue: [t5 < t6 ifTrue: [^1] ifFalse: [^-1]]. len _ len - 1]. ^0! digitDiv: arg neg: ng "Answer an array of (quotient, remainder) that is the receiver divided by the argument arg and where the argument neg is a flag determining whether the result is negative or not." | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | l _ self digitLength - arg digitLength + 1. l <= 0 ifTrue: [^Array with: 0 with: self]. d _ 8 - arg lastDigit highBit. rem _ self digitLshift: d bytes: 0 lookfirst: false. "makes a copy and shifts" div _ arg digitLshift: d bytes: 0 lookfirst: false. "shifts so high order word is >=128" quo _ Integer new: l neg: ng. dl _ div digitLength - 1. "Last actual byte of data" ql _ l. dh _ div digitAt: dl. dnh _ dl = 1 ifTrue: [0] ifFalse: [div digitAt: dl - 1]. 1 to: ql do: [:k | "maintain quo*arg+rem=self" "Estimate rem/div by dividing the leading to bytes of rem by dh." "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." j _ rem digitLength + 1 - k. "r1 _ rem digitAt: j." (rem digitAt: j) = dh ifTrue: [qhi _ qlo _ 15"i.e. q=255"] ifFalse: ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. Note that r1,r2 are bytes, not nibbles. Be careful not to generate intermediate results exceeding 13 bits." "r2 _ (rem digitAt: j - 1)." t _ ((rem digitAt: j) bitShift: 4) + ((rem digitAt: j - 1) bitShift: -4). qhi _ t // dh. t _ (t \\ dh bitShift: 4) + ((rem digitAt: j - 1) bitAnd: 15). qlo _ t // dh. t _ t \\ dh. "Next compute (hi,lo) _ q*dnh" hi _ qhi * dnh. lo _ qlo * dnh + ((hi bitAnd: 15) bitShift: 4). hi _ (hi bitShift: -4) + (lo bitShift: -8). lo _ lo bitAnd: 255. "Correct overestimate of q. Max of 2 iterations through loop -- see Knuth vol. 2" r3 _ j < 3 ifTrue: [0] ifFalse: [rem digitAt: j - 2]. [(t < hi or: [t = hi and: [r3 < lo]]) and: ["i.e. (t,r3) < (hi,lo)" qlo _ qlo - 1. lo _ lo - dnh. lo < 0 ifTrue: [hi _ hi - 1. lo _ lo + 256]. hi >= dh]] whileTrue: [hi _ hi - dh]. qlo < 0 ifTrue: [qhi _ qhi - 1. qlo _ qlo + 16]]. "Subtract q*div from rem" l _ j - dl. a _ 0. 1 to: div digitLength do: [:i | hi _ (div digitAt: i) * qhi. lo _ a + (rem digitAt: l) - ((hi bitAnd: 15) bitShift: 4) - ((div digitAt: i) * qlo). rem digitAt: l put: (lo bitAnd: 255). a _ (lo bitShift: -8) - (hi bitShift: -4). l _ l + 1]. a < 0 ifTrue: ["Add div back into rem, decrease q by 1" qlo _ qlo - 1. l _ j - dl. a _ 0. 1 to: div digitLength do: [:i | a _ (a bitShift: -8) + (rem digitAt: l) + (div digitAt: i). rem digitAt: l put: (a bitAnd: 255). l _ l + 1]]. quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) + qlo]. rem _ rem digitRshift: d bytes: 0 lookfirst: dl. ^Array with: quo with: rem! digitLogic: arg op: op length: len "Perform the indicated bit-wise operation between the reciever and arg. This implementation depends on the fact that new Integers are initialized to be all zeros" | result neg1 neg2 rneg z1 z2 rz b1 b2 b rdigits | neg1 _ self negative. neg2 _ arg negative. rneg _ ((neg1 ifTrue: [-1] ifFalse: [0]) perform: op with: (neg2 ifTrue: [-1] ifFalse: [0])) < 0. result _ Integer new: len neg: rneg. rz _ z1 _ z2 _ true. rdigits _ 1. 1 to: result digitLength do: [:i | b1 _ self digitAt: i. neg1 ifTrue: [b1 _ z1 ifTrue: [b1 = 0 ifTrue: [0] ifFalse: [z1 _ false. 256 - b1]] ifFalse: [255 - b1]]. b2 _ arg digitAt: i. neg2 ifTrue: [b2 _ z2 ifTrue: [b2 = 0 ifTrue: [0] ifFalse: [z2 _ false. 256 - b2]] ifFalse: [255 - b2]]. b _ b1 perform: op with: b2. rneg ifTrue: [rz ifTrue: [b = 0 ifFalse: [result digitAt: i put: 256 - b. rdigits _ i. rz _ false]] ifFalse: [b _ 255 - b. b = 0 ifFalse: [result digitAt: i put: b. rdigits _ i]]] ifFalse: [b = 0 ifFalse: [result digitAt: i put: b. rdigits _ i]]]. rdigits ~= len ifTrue: [^(result growto: rdigits) truncated]. ^result truncated! digitLshift: n bytes: b lookfirst: a "Shift left 8*b+n bits, 0<=n<8. Discard all digits beyond a, and all zeroes at or below a." | x f m len r digit | "shift by 8*b+n bits, 0<=n<8. a true means check for a leading zero byte in the result " x _ 0. f _ n - 8. m _ 255 bitShift: 0 - n. len _ self digitLength + 1 + b. (a and: [(self lastDigit bitShift: f) = 0]) ifTrue: [len _ len - 1]. r _ Integer new: len neg: self negative. 1 to: b do: [:i | r digitAt: i put: 0]. 1 to: len - b do: [:i | digit _ self digitAt: i. r digitAt: i + b put: (((digit bitAnd: m) bitShift: n) bitOr: x). "Avoid values > 8 bits" x _ digit bitShift: f]. ^r! digitMultiply: arg neg: ng "Answer the result of multiplying the receiver by the argument arg, where the sign of the result is ng." | prod pl carry digit k xh xl low high | ((arg digitAt: 1) = 0 and: [arg digitLength = 1]) ifTrue: [^0]. pl _ self digitLength + arg digitLength. prod _ Integer new: pl neg: ng. "prod starts out all zero" 1 to: self digitLength do: [:i | (digit _ self digitAt: i) ~= 0 ifTrue: [k _ i. carry _ 0. xh _ digit bitShift: -4. xl _ digit bitAnd: 15. "Loop invariant: 0<=carry<=0377, k=i+j-1" 1 to: arg digitLength do: [:j | high _ (arg digitAt: j) * xh. "Do double-precision multiply in two parts. Integers must be at least 13 bits for this to work." low _ (arg digitAt: j) * xl + ((high bitAnd: 15) bitShift: 4) + carry + (prod digitAt: k). carry _ (high bitShift: -4) + (low bitShift: -8). prod digitAt: k put: (low bitAnd: 255). k _ k + 1]. prod digitAt: k put: carry]]. (prod digitAt: pl) = 0 ifTrue: [^(prod growby: -1) truncated]. ^prod truncated! digitRshift: anInteger bytes: b lookfirst: a "Shift right 8*b+anInteger bits, 0<=anInteger<8. Discard all digits beyond a, and all zeroes at or below a." | n x r f m digit count i | n _ 0 - anInteger. x _ 0. f _ n + 8. i _ a. m _ 255 bitShift: 0 - f. digit _ self digitAt: i. [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue: [x _ digit bitShift: f "Can't exceed 8 bits". i _ i - 1. digit _ self digitAt: i]. i <= b ifTrue: [^Integer new: 0 neg: self negative]. "All bits lost" r _ Integer new: i - b neg: self negative. count _ i. x _ (self digitAt: b + 1) bitShift: n. b + 1 to: count do: [:j | digit _ self digitAt: j + 1. r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) "Avoid values > 8 bits". x _ digit bitShift: n]. ^r! digitSubtract: arg "Answer the result of subtracting the argument arg from the receiver." | smaller larger i z sum sl al ng lastdigit | sl _ self digitLength. al _ arg digitLength. (sl = al ifTrue: [[(self digitAt: sl) = (arg digitAt: sl) and: [sl > 1]] whileTrue: [sl _ sl - 1]. al _ sl. (self digitAt: sl) < (arg digitAt: sl)] ifFalse: [sl < al]) ifTrue: [larger _ arg. smaller _ self. ng _ self negative == false. sl _ al] ifFalse: [larger _ self. smaller _ arg. ng _ self negative]. sum _ Integer new: sl neg: ng. lastdigit _ 1. z _ 0. "Loop invariant is -1<=z<=1" i _ 1. [i <= sl] whileTrue: [z _ z + (larger digitAt: i) - (smaller digitAt: i). (sum digitAt: i put: (z bitAnd: 255)) ~= 0 ifTrue: [lastdigit _ i]. z _ z bitShift: -8. i _ i + 1]. lastdigit = sl ifFalse: [sum _ sum growto: lastdigit]. ^sum truncated! growby: n "Answer a copy of the receiver that is increased in size by n." ^self growto: self digitLength + n! growto: n "Answer a copy of the receiver whose size is n." ^self copyto: (self species new: n)! numerator "Answer the numerator of the receiver, which is the receiver itself." ^self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Integer class instanceVariableNames: ''! !Integer class methodsFor: 'instance creation'! new: length neg: neg "Answer an instance of a large integer whose size is length. neg is a flag determining the sign of the integer." neg ifTrue: [^LargeNegativeInteger new: length] ifFalse: [^LargePositiveInteger new: length]! readFrom: aStream "Answer a new Integer as described on the stream, aStream." ^self readFrom: aStream radix: 10! readFrom: aStream radix: radix "Answer an instance of one of the concrete subclasses if Integer. Initial minus sign accepted, and bases > 10 use letters A-Z. Imbedded radix specifiers not allowed; use Integer class readFrom: for that. Answer zero if there are no digits." | digit value neg | neg _ aStream peekFor: $-. value _ 0. [aStream atEnd] whileFalse: [digit _ aStream next digitValue. (digit < 0 or: [digit >= radix]) ifTrue: [aStream skip: -1. neg ifTrue: [^value negated truncated "catch 0 minVal"]. ^value] ifFalse: [value _ value * radix + digit]]. neg ifTrue: [^value negated truncated "catch 0 minVal"]. ^value! ! SequenceableCollection subclass: #Interval instanceVariableNames: 'start stop step ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! Interval comment: 'The class Interval represents a finite arithmetic progression Instance Variables: start Initial number in the progression stop Last number in the progression step Increment for determining the next number in the progression'! !Interval methodsFor: 'comparing'! = anInterval "Answer true if anInterval is kind of my class, and if our starts, steps and sizes are equal. If anInterval is not kind of my class, superclass will deside we are = or not." (anInterval isKindOf: self class) ifTrue: [^start = anInterval first and: [step = anInterval increment and: [self size = anInterval size]]] ifFalse: [^super = anInterval]! hash "Answer a SmallInteger unique to the receiver." ^(((start hash bitShift: 2) bitOr: stop hash) bitShift: 1) bitOr: self size! ! !Interval methodsFor: 'accessing'! at: anInteger "Answer the anInteger'th element." (anInteger >= 1 and: [anInteger <= self size]) ifTrue: [^start + (step * (anInteger - 1))] ifFalse: [self errorSubscriptBounds: anInteger]! at: anInteger put: anObject "Provide an error notification that storing into an Interval is not allowed. " self error: 'you can not store into an interval'! first "Answer the first element of the arithmetic progression." ^start! increment "Answer the receiver's interval increment." ^step! last "Answer the last element of the arithmetic progression." ^stop - (stop - start \\ step)! size "Answer how many elements the receiver contains." step < 0 ifTrue: [start < stop ifTrue: [^0] ifFalse: [^stop - start // step + 1]] ifFalse: [stop < start ifTrue: [^0] ifFalse: [^stop - start // step + 1]]! ! !Interval methodsFor: 'adding'! add: newObject "Provide an error notification that adding to an Interval is not allowed." self shouldNotImplement! ! !Interval methodsFor: 'removing'! remove: newObject "Provide an error notification that removing an element from an Interval is not allowed." self error: 'elements cannot be removed from an Interval'! ! !Interval methodsFor: 'copying'! copy "Answer another instance just like the receiver." "Intervals override this message because their species is Array and copy, as inherited from SequenceableCollection, uses copyFrom:to:, which creates a new object of the species." ^self shallowCopy! ! !Interval 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." | nextValue i result | result _ self species new: self size. nextValue _ start. i _ 1. step < 0 ifTrue: [[stop <= nextValue] whileTrue: [result at: i put: (aBlock value: nextValue). nextValue _ nextValue + step. i _ i + 1]] ifFalse: [[stop >= nextValue] whileTrue: [result at: i put: (aBlock value: nextValue). nextValue _ nextValue + step. i _ i + 1]]. ^result! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." | aValue | aValue _ start. step < 0 ifTrue: [[stop <= aValue] whileTrue: [aBlock value: aValue. aValue _ aValue + step]] ifFalse: [[stop >= aValue] whileTrue: [aBlock value: aValue. aValue _ aValue + step]]! reverseDo: aBlock "Evaluate aBlock for each element of the receiver's interval, in reverse order." | aValue | aValue _ stop. step < 0 ifTrue: [[start >= aValue] whileTrue: [aBlock value: aValue. aValue _ aValue - step]] ifFalse: [[start <= aValue] whileTrue: [aBlock value: aValue. aValue _ aValue - step]]! ! !Interval methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the interval. The literal format for Intervals is used, that is (startNumber to: stopNumber by: stepNumber) unless step is 1 in which case the format is (startNumber to: stopNumber)" aStream nextPut: $(. start printOn: aStream. aStream nextPutAll: ' to: '. stop printOn: aStream. step ~= 1 ifTrue: [aStream nextPutAll: ' by: '. step printOn: aStream]. aStream nextPut: $)! storeOn: aStream "Because numbers store and print the same, append to the argument aStream the literal description of an Interval, same as printOn:." self printOn: aStream! ! !Interval methodsFor: 'private'! setFrom: startInteger to: stopInteger by: stepInteger "Initialize the instance variables." start _ startInteger. stop _ stopInteger. step _ stepInteger! species "Answer Array." ^Array! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Interval class instanceVariableNames: ''! !Interval class methodsFor: 'instance creation'! from: startInteger to: stopInteger "Answer a new instance of Interval, starting at startInteger, ending and stopInteger, and with an interval increment of 1." ^self new setFrom: startInteger to: stopInteger by: 1! from: startInteger to: stopInteger by: stepInteger "Answer a new instance of Interval, starting at startInteger, ending and stopInteger, and with an interval increment of stepInteger." ^self new setFrom: startInteger to: stopInteger by: stepInteger! new "Answer a new instance of the receiver (a class) with no indexable fields. Fail if the class is indexable. Override SequenceableCollection new. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [^self new: 0]. self primitiveFailed! ! Object subclass: #KeyboardEvent instanceVariableNames: 'keyCharacter metaState ' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! KeyboardEvent comment: 'Class KeyboardEvent represents a keyboard event consisting of a non-meta key being struck plus the state of the meta keys at that moment. Only InputState creates instances of the class. Instance Variables: keyCharacter non-meta key character metaState combined state of meta keys '! !KeyboardEvent methodsFor: 'accessing'! keyCharacter "Answer the character that was pressed." ^keyCharacter asCharacter! keyValue "Answer the keyboard character of the receiver." ^keyCharacter! metaState "Answer the state of the special keyboard characters--control, shift, lock." ^metaState! ! !KeyboardEvent methodsFor: 'testing'! hasCtrl "Answer whether a control key was pressed." ^metaState anyMask: 2! hasLock "Answer whether the shift key is locked." ^metaState anyMask: 4! hasShift "Answer whether a shift key was pressed." ^metaState anyMask: 1! ! !KeyboardEvent methodsFor: 'private'! key: anInteger meta: meta keyCharacter _ anInteger. metaState _ meta! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KeyboardEvent class instanceVariableNames: ''! !KeyboardEvent class methodsFor: 'instance creation'! code: code meta: meta "Answer an instance of the receiver, with code the regular key and meta the special keys--ctrl, shift, lock." ^self new key: code meta: meta! ! Integer variableByteSubclass: #LargeNegativeInteger instanceVariableNames: '' classVariableNames: 'MinHi ' poolDictionaries: '' category: 'Numeric-Numbers'! LargeNegativeInteger comment: 'Instances of class LargeNegativeInteger represent negative large integers. Nearly all behavior is handled in Integer. Instance Variables: *byte indexed* Class Variable: MinHi '! !LargeNegativeInteger methodsFor: 'arithmetic'! abs "Answer the receiver negated." ^self negated! negated "Answer a LargePositiveInteger that is the negation of the receiver." ^self copyto: (LargePositiveInteger new: self digitLength)! ! !LargeNegativeInteger methodsFor: 'bit manipulation'! highBit "Fail since this message is not defined for negative numbers. " self error: 'highBit not defined for negative numbers'! ! !LargeNegativeInteger methodsFor: 'testing'! negative "Answer true that the receiver is less than 0." ^true! positive "Answer false that the receiver is not less than 0." ^false! ! !LargeNegativeInteger methodsFor: 'truncation and round off'! truncated "Answer a representation of the receiver as a SmallInteger, if possible, otherwise answer the receiver itself. This message is only used internally after arithmetic and bit operations." | size partial maxSize | size _ self digitLength. size = 0 ifTrue: [^0]. partial _ self digitAt: size. partial = 0 ifTrue: [^(self growby: -1) truncated]. maxSize _ SmallInteger maxBytes. (size < maxSize or: [size = maxSize and: [partial < MinHi or: [partial = MinHi and: [(self anyBitTo: maxSize - 1 * 8) not]]]]) ifTrue: ["Convert back to a SmallInteger." partial _ 0 - partial. [(size _ size - 1) > 0] whileTrue: [partial _ (partial bitShift: 8) - (self digitAt: size)]. "Can't overflow" ^partial]! ! !LargeNegativeInteger methodsFor: 'converting'! asObject "Answer an object that is determined by the receiver as its object pointer. This handles large object pointers." ^self - SmallInteger minVal + 1! ! !LargeNegativeInteger methodsFor: 'printing'! printOn: aStream base: b "Print a representation of the receiver on the stream, aStream, in base b where 2<=b<=256." aStream nextPut: $-. super printOn: aStream base: b! ! !LargeNegativeInteger methodsFor: 'system primitives'! digitAt: index "Answer the value of an indexable field in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." self digitLength < index ifTrue: [^0] ifFalse: [^super at: index]! digitAt: index put: value "Store the argument value in the indexable field of the receiver indicated by index. Answer with the value that was stored. Fail if the value is negative or is larger than 255. Fail if the index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." ^super at: index put: value! digitLength "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LargeNegativeInteger class instanceVariableNames: ''! !LargeNegativeInteger class methodsFor: 'class initialization'! initialize "Compute the constant MinHi. If a LargeNegativeInteger is exactly SmallInteger maxBytes in size, and its high-order byte is not less than MinHi, then the result should be a SmallInteger." "LargeNegativeInteger initialize." SmallInteger initialize. MinHi _ (SmallInteger minVal bitShift: SmallInteger maxBytes - 1 * -8) negated! ! LargeNegativeInteger initialize! Integer variableByteSubclass: #LargePositiveInteger instanceVariableNames: '' classVariableNames: 'MaxHi ' poolDictionaries: '' category: 'Numeric-Numbers'! LargePositiveInteger comment: 'Instances of class LargePositiveInteger represent positive large integers. Nearly all behavior is handled in Integer. Instance Variables: *byte indexed* Class Variable: MaxHi '! !LargePositiveInteger methodsFor: 'arithmetic'! * anInteger "Answer the result of multiplying the receiver by the argument, aNumber, where the result is an Integer." "Primitive is not implemented." ^super * anInteger! + anInteger "Answer the Integer result of adding the receiver to the argument." "Primitive is not implemented." ^super + anInteger! - anInteger "Answer an Integer that is the difference between the receiver and anInteger." "Primitive is not implemented." ^super - anInteger! / anInteger "Answer the result of dividing receiver by the argument, anInteger, if the division is exact. Fail if the result is not a whole integer. Fail if the argument is 0." "Primitive is not implemented." ^super / anInteger! // anInteger "Answer the result of dividing the receiver by the argument. Round the result down towards negative infinity to make it a whole integer." "Primitive is not implemented." ^super // anInteger! abs "Answer the receiver itself." ^self! negated "Answer a LargeNegativeInteger that is the negation of the receiver." | minVal | ((self digitAt: 1) = 0 and: [self digitLength = 1]) ifTrue: [^self]. "Zero" minVal _ SmallInteger minVal. ((self digitAt: 2) = (0 - (minVal // 256)) and: [(self digitAt: 1) = 0]) ifTrue: [^minVal]. ^self copyto: (LargeNegativeInteger new: self digitLength)! quo: anInteger "Answer the result of dividing the receiver by the argument. Round the result down towards zero to make it a whole integer." "Primitive is not implemented." ^super quo: anInteger! \\ anInteger "Answer the remainder, rounded towards negative infinity, of the receiver modulo the argument." "Primitive is not implemented." ^super \\ anInteger! ! !LargePositiveInteger methodsFor: 'bit manipulation'! bitAnd: anInteger "Answer the logical AND of the twos-complement representation of the receiver with the argument." "Primitive is not implemented." ^super bitAnd: anInteger! bitOr: anInteger "Answer the logical OR of the twos-complement representation of the receiver with the argument." "Primitive is not implemented." ^super bitOr: anInteger! bitShift: anInteger "Answer an Integer whose value (in twos-complement representation) is the receiver's value (in twos-complement representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts. The sign bit is extended in right shifts." "Primitive is not implemented." ^super bitShift: anInteger! bitXor: anInteger "Answer the logical XOR of the twos-complement representation of the receiver with the argument." "Primitive is not implemented." ^super bitXor: anInteger! highBit "Answer the index of the high order bit of the binary representation of this number." ^self lastDigit highBit + (8 * (self digitLength - 1))! ! !LargePositiveInteger methodsFor: 'testing'! negative "Answer false that the receiver is not less than 0." ^false! positive "Answer true that the receiver is less than 0." ^true! ! !LargePositiveInteger methodsFor: 'comparing'! < anInteger "Answer whether the receiver is less than the argument." "Primitive is not implemented." ^super < anInteger! <= anInteger "Answer whether the receiver is less than or equal to the argument." "Primitive is not implemented." ^super <= anInteger! = anInteger "Answer whether the receiver is equal to the argument." "Primitive is not implemented." ^super = anInteger! > anInteger "Answer whether the receiver is greater than the argument." "Primitive is not implemented." ^super > anInteger! >= anInteger "Answer whether the receiver is greater than or equal to the argument." "Primitive is not implemented." ^super >= anInteger! ~= anInteger "Answer whether the receiver is not equal to the argument." "Primitive is not implemented." ^super ~= anInteger! ! !LargePositiveInteger methodsFor: 'truncation and round off'! truncated "Answer the converted result of representing the receiver as a SmallInteger, otherwise answer the receiver itself. This message is only used internally after arithmetic and bit operations, and in a few external places that construct LargePositiveIntegers in nonstandard ways." | size partial maxSize | size _ self digitLength. size = 0 ifTrue: [^0]. partial _ self digitAt: size. partial = 0 ifTrue: [^(self growby: -1) truncated]. maxSize _ SmallInteger maxBytes. (size < maxSize or: [size = maxSize and: [partial <= MaxHi]]) ifTrue: ["Convert back to a SmallInteger." [(size _ size - 1) > 0] whileTrue: [partial _ (partial bitShift: 8) + (self digitAt: size)]. "Can't overflow" ^partial]! ! !LargePositiveInteger methodsFor: 'converting'! asObject "Answer an object that is determined by the receiver as its object pointer. This handles large object pointers." ^self - SmallInteger maxVal - 1! basicAsObject "Answer the object whose object pointer is twice the receiver's value. The resulting object is never a SmallInteger. The receiver may be negative. Fails if no object has that object pointer. Essential. See Object documentation whatIsAPrimitive." self error: 'This object does not exist!!'! ! !LargePositiveInteger methodsFor: 'system primitives'! digitAt: index "Answer the value of an indexable field in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." self digitLength < index ifTrue: [^0] ifFalse: [^super at: index]! digitAt: index put: value "Store the argument value in the indexable field of the receiver indicated by index. Answer with the value that was stored. Fail if the value is negative or is larger than 255. Fail if the index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." ^super at: index put: value! digitLength "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LargePositiveInteger class instanceVariableNames: ''! !LargePositiveInteger class methodsFor: 'class initialization'! initialize "Compute the constant MaxHi. If a LargePositiveInteger is exactly SmallInteger maxBytes in size, and its high-order byte does not exceed MaxHi, the number should be a SmallInteger." "LargePositiveInteger initialize." SmallInteger initialize. MaxHi _ SmallInteger maxVal bitShift: SmallInteger maxBytes - 1 * -8! ! LargePositiveInteger initialize! ParseNode subclass: #LeafNode instanceVariableNames: 'key code ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! LeafNode comment: 'I represent a leaf node of the compiler parse tree. I am abstract. Types (defined in class ParseNode): 1 LdInstType (which uses class VariableNode) 2 LdTempType (which uses class VariableNode) 3 LdLitType (which uses class LiteralNode) 4 LdLitIndType (which uses class VariableNode) 5 SendType (which uses class SelectorNode)'! !LeafNode methodsFor: 'initialize-release'! key: object code: byte key _ object. code _ byte! key: object index: i type: type self key: object code: (self code: i type: type)! name: ignored key: object code: byte key _ object. code _ byte! name: literal key: object index: i type: type self key: object index: i type: type! ! !LeafNode methodsFor: 'accessing'! key ^key! ! !LeafNode methodsFor: 'code generation'! code ^code! emitForEffect: stack on: strm ^self! emitLong: mode on: aStream "emit extended variable access" | type index | code < 256 ifTrue: [code < 16 ifTrue: [type _ 0. index _ code] ifFalse: [code < 32 ifTrue: [type _ 1. index _ code - 16] ifFalse: [code < 96 ifTrue: [type _ code // 32 + 1. index _ code \\ 32] ifFalse: [self error: 'Sends should be handled in SelectorNode']]]] ifFalse: [index _ code \\ 256. type _ code // 256 - 1]. index < 64 ifTrue: [aStream nextPut: mode. aStream nextPut: type * 64 + index] ifFalse: [aStream nextPut: mode + 12. aStream nextPut: type. aStream nextPut: index]! reserve: encoder "if this is a yet unused literal of type -code, reserve it" code < 0 ifTrue: [code _ self code: (encoder litIndex: key) type: 0 - code]! size: encoder ^self sizeForValue: encoder! sizeForEffect: encoder ^0! sizeForValue: encoder self reserve: encoder. code < 256 ifTrue: [^1]. code \\ 256 < 64 ifTrue: [^2]. ^3! ! !LeafNode methodsFor: 'private'! code: index type: type index isNil ifTrue: [^type negated]. (CodeLimits at: type) > index ifTrue: [^(CodeBases at: type) + index]. ^type * 256 + index! ! Path subclass: #Line instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! Line comment: 'Class Line represents a straight line or path through two points. '! !Line methodsFor: 'accessing'! beginPoint "Answer the first end point of the receiver." ^self first! beginPoint: aPoint "Set the first end point of the receiver. Answer the argument, aPoint." self at: 1 put: aPoint. ^aPoint! endPoint "Answer the first end point of the receiver." ^self last! endPoint: aPoint "Set the first end point of the receiver." self at: 2 put: aPoint. ^aPoint! ! !Line methodsFor: 'displaying'! displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger mask: aForm "The form associated with this Path will be displayed, according to one of the sixteen functions of two logical variables (rule), at each point on the Line. Also the source form will be first ANDed with aForm as a mask. Does not effect the state of the Path." collectionOfPoints size < 2 ifTrue: [self error: 'a line must have two points']. aDisplayMedium drawLine: self form from: self beginPoint + aPoint to: self endPoint + aPoint clippingBox: clipRect rule: anInteger mask: aForm! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Line class instanceVariableNames: ''! !Line class methodsFor: 'instance creation'! from: beginPoint to: endPoint withForm: aForm "Answer a new instance of the receiver with end points beginPoint and endPoint such that the image is drawn using the drawing nib aForm." | newSelf | newSelf _ super new: 2. newSelf add: beginPoint. newSelf add: endPoint. newSelf form: aForm. ^newSelf! new "Answer a new instance of the receiver that is essential a single point at the upper left corner of the screen." | newSelf | newSelf _ super new: 2. newSelf add: 0@0. newSelf add: 0@0. ^newSelf! ! !Line class methodsFor: 'examples'! sampleLine "Designate two places on the screen by clicking any mouse button. A straight path with a square black form will be displayed connecting the two selected points." "Line sampleLine." | aLine aForm | aForm _ Form new extent: 20@20. "make a form one quarter of inch square" aForm black. "turn it black" aLine _ Line new. aLine form: aForm. "use the black form for display" aLine beginPoint: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: aLine beginPoint. aLine endPoint: Sensor waitButton. aLine displayOn: Display. "display the line"! ! Path subclass: #LinearFit instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! LinearFit comment: 'Class LinearFit is a subclass of Path that represents a piece-wise linear approximation to a set of points in the plane.'! !LinearFit 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. " | line | line _ Line new. line form: self form. 1 to: self size - 1 do: [:i | line beginPoint: (self at: i). line endPoint: (self at: i + 1). line displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LinearFit class instanceVariableNames: ''! !LinearFit class methodsFor: 'examples'! linearfitSample "Select points on a Path using the red button. Terminate by selecting any other button. Creates a Path from the points and displays it as a piece-wise linear approximation." "LinearFit linearfitSample." | aLinearFit aForm flag | aLinearFit _ LinearFit new. aForm _ Form new extent: 1 @ 40. aForm black. aLinearFit form: aForm. flag _ true. [flag] whileTrue: [Sensor waitButton. Sensor redButtonPressed ifTrue: [aLinearFit add: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: aLinearFit last] ifFalse: [flag_false]]. aLinearFit displayOn: Display! ! Object subclass: #Link instanceVariableNames: 'nextLink ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! Link comment: 'Class Link represents a simple record of a pointer to another Link. Instance Variable: nextLink a pointer referencing the next Link in the chain'! !Link methodsFor: 'accessing'! nextLink "Answer the Link to which the receiver points." ^nextLink! nextLink: aLink "Store the argument as the Link to which the receiver refers." ^nextLink _ aLink! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Link class instanceVariableNames: ''! !Link class methodsFor: 'instance creation'! nextLink: aLink "Answer a new instance of the receiver referring to the argument, aLink." ^self new nextLink: aLink! ! SequenceableCollection subclass: #LinkedList instanceVariableNames: 'firstLink lastLink ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! LinkedList comment: 'The class LinkedList implements ordered collections using a chain of elements. Elements of a LinkedList are ordered by the sequence in which objects are added and removed; the elements can be referred to by external keys that are indices. Each element of a LinkedList must be an instance of class Link or of one of its subclasses. Instance Variables: firstLink lastLink A new instance of LinkedList can be initialized using LinkedList with: Link new'! !LinkedList methodsFor: 'accessing'! at: anInteger "Answer the element at index anInteger. at: is used by a knowledgeable client to access an existing element" | aLink count | aLink _ firstLink. count _ 1. [aLink == nil or: [count = anInteger]] whileFalse: [count _ count + 1. aLink _ aLink nextLink]. aLink == nil ifTrue: [^self errorSubscriptBounds: anInteger] ifFalse: [^aLink]! at: anIndex put: aLink "Put anObject at element index anInteger. This message is used by a knowledgeable client to replace an element." self error: 'Do not store into a LinkedList using at:put: '! first "Answer the first link; provide an error notification if the receiver is empty. " self emptyCheck. ^firstLink! last "Answer the last link; provide an error notification if the receiver is empty." self emptyCheck. ^lastLink! size "Answer how many elements the receiver contains." | tally | tally _ 0. self do: [:each | tally _ tally + 1]. ^tally! ! !LinkedList methodsFor: 'testing'! isEmpty "Answer whether the receiver contains any elements." ^firstLink == nil! ! !LinkedList methodsFor: 'adding'! add: aLink "Add aLink to the end of the receiver's list." ^self addLast: aLink! addFirst: aLink "Add aLink to the beginning of the receiver's list." self isEmpty ifTrue: [lastLink _ aLink]. aLink nextLink: firstLink. firstLink _ aLink. ^aLink! addLast: aLink "Add aLink to the end of the receiver's list." self isEmpty ifTrue: [firstLink _ aLink] ifFalse: [lastLink nextLink: aLink]. lastLink _ aLink. ^aLink! ! !LinkedList methodsFor: 'removing'! remove: aLink ifAbsent: exceptionBlock "Remove aLink from the receiver. If it is not there, answer the result of evaluating exceptionBlock." | tempLink | aLink == firstLink ifTrue: [firstLink _ aLink nextLink. aLink == lastLink ifTrue: [lastLink _ nil]] ifFalse: [tempLink _ firstLink. [tempLink == nil ifTrue: [^exceptionBlock value]. tempLink nextLink == aLink] whileFalse: [tempLink _ tempLink nextLink]. tempLink nextLink: aLink nextLink. aLink == lastLink ifTrue: [lastLink _ tempLink]]. aLink nextLink: nil. ^aLink! removeFirst "Remove the first element. If the receiver is empty, cause an error; otherwise answer the removed element. Using the sequence addFirst:/removeFirst causes the receiver to behave as a stack; using addLast:/removeFirst causes the receiver to behave as a queue." | oldLink | self emptyCheck. oldLink _ firstLink. firstLink == lastLink ifTrue: [firstLink _ nil. lastLink _ nil] ifFalse: [firstLink _ oldLink nextLink]. oldLink nextLink: nil. ^oldLink! removeLast "Remove the receiver's last element. If the receiver is empty, cause an error; otherwise answer the removed element. Using addLast:/removeLast causes the receiver to behave as a stack; using addFirst:/removeLast causes the receiver to behave as a queue." | oldLink aLink | self emptyCheck. oldLink _ lastLink. firstLink == lastLink ifTrue: [firstLink _ nil. lastLink _ nil] ifFalse: [aLink _ firstLink. [aLink nextLink == oldLink] whileFalse: [aLink _ aLink nextLink]. aLink nextLink: nil. lastLink _ aLink]. oldLink nextLink: nil. ^oldLink! ! !LinkedList methodsFor: 'enumerating'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." | aLink | aLink _ firstLink. [aLink == nil] whileFalse: [aBlock value: aLink. aLink _ aLink nextLink]! ! ScrollController subclass: #ListController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Lists'! ListController comment: 'I am a kind of ScrollController that assumes that the view is a kind of ListView. Therefore, scrolling means moving the items in a textual list (menu) up or down. In addition, I provide the red button activity of determining when the red button is selecting an item in the list.'! !ListController methodsFor: 'control defaults'! isControlActive ^super isControlActive & sensor blueButtonPressed not! ! !ListController methodsFor: 'marker adjustment'! computeMarkerRegion | viewList | viewList _ view list. ^ 0@0 extent: 10@ ((viewList clippingRectangle height asFloat / viewList compositionRectangle height * scrollBar inside height) rounded min: scrollBar inside height)! markerDelta | viewList | viewList _ view list. ^(marker top - scrollBar inside top) - ((viewList clippingRectangle top - viewList compositionRectangle top) asFloat / viewList compositionRectangle height asFloat * scrollBar inside height asFloat) rounded! ! !ListController methodsFor: 'scrolling'! canScroll | viewList | viewList _ view list. ^viewList compositionRectangle height - viewList clippingRectangle height > (viewList lineGrid // 2)! scrollAmount ^sensor cursorPoint y - scrollBar inside top! 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 isSelectionBoxClipped "ifTrue: [ self changeModelSelection: 0] compile this code to deselect when the selection is scrolled outside of the visible region" ifFalse: [ view displaySelectionBox ]]! scrollViewDown self scrollView: self scrollAmount.! scrollViewUp self scrollView: (self scrollAmount) negated.! viewDelta | viewList | viewList _ view list. ^(viewList clippingRectangle top - viewList compositionRectangle top - ((marker top - scrollBar inside top) asFloat / scrollBar inside height asFloat * viewList compositionRectangle height asFloat)) roundTo: viewList lineGrid! ! !ListController methodsFor: 'menu messages'! redButtonActivity | noSelectionMovement oldSelection trialSelection nextSelection | noSelectionMovement _ true. oldSelection _ view selection. [sensor redButtonPressed] whileTrue: [trialSelection _ view findSelection: sensor cursorPoint. trialSelection ~~ nil ifTrue: [nextSelection _ trialSelection. view moveSelectionBox: nextSelection. nextSelection ~= oldSelection ifTrue: [noSelectionMovement _ false]]]. nextSelection ~~ nil & (nextSelection = oldSelection ifTrue: [noSelectionMovement] ifFalse: [true]) ifTrue: [self changeModelSelection: nextSelection]! ! !ListController methodsFor: 'private'! changeModelSelection: anInteger model toggleListIndex: anInteger! ! View subclass: #ListView instanceVariableNames: 'list selection topDelimiter bottomDelimiter lineSpacing isEmpty emphasisOn ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Lists'! ListView comment: 'I am an abstract View of a list of items. I provide support for storing a selection of one item, as well as formatting the list for presentation on the screen. My default controller is ListController. Instance Variables: list of Strings, each one an item selection index into the array, list topDelimiter , usually ------------, indicating the top of the list bottomDelimiter , usually ------------, indicating the bottom of the list lineSpacing the amount of extra space between line items isEmpty true if the list is empty '! !ListView methodsFor: 'initialize-release'! initialize super initialize. insideColor _ Form white. topDelimiter _ '------------'. bottomDelimiter _ '------------'. lineSpacing _ 0. isEmpty _ true. emphasisOn _ true! ! !ListView methodsFor: 'list access'! list "Answer the list of items the receiver displays." ^list! list: itemCollection "Create the textList corresponding to the items in itemCollection." isEmpty _ itemCollection isNil. list _ TextList onList: (topDelimiter == nil ifTrue: [itemCollection] ifFalse: [(Array with: topDelimiter) , itemCollection , (Array with: bottomDelimiter)]). selection _ 0. self positionList! reset "Set the list of items displayed to be empty." isEmpty _ true. self list: Array new! resetAndDisplayView "Set the list of items displayed to be empty and redisplay the receiver." isEmpty ifFalse: [self reset. self displayView]! ! !ListView methodsFor: 'delimiters'! bottomDelimiter "Answer the string used to indicate the bottom of the list." ^bottomDelimiter! bottomDelimiter: aString "Set the string used to indicate the bottom of the list." bottomDelimiter _ aString! noBottomDelimiter "Set the string used to indicate the bottom of the list to be nothing." bottomDelimiter _ nil! noTopDelimiter "Set the string used to indicate the top of the list to be nothing." topDelimiter _ nil! topDelimiter "Answer the string used to indicate the top of the list." ^topDelimiter! topDelimiter: aString "Set the string used to indicate the top of the list." topDelimiter _ aString! ! !ListView methodsFor: 'displaying'! display "Show the list of items on the screen." list == nil ifTrue: [self list: Array new]. self isUnlocked ifTrue: [self positionList]. super display! displaySelectionBox "If the receiver has a selection and that selection is visible on the display screen, then highlight it." | selectionRect | (selection > 0 and: [self selectionBox intersects: self clippingBox]) ifTrue: [selectionRect _ self selectionBox intersect: self clippingBox. emphasisOn ifTrue: [Display reverse: selectionRect] ifFalse: [Display fill: selectionRect rule: Form reverse mask: Form gray. Display fill: (selectionRect insetBy: 1) rule: Form reverse mask: Form gray]]! displayView self clearInside. list displayOn: Display. self displaySelectionBox! ! !ListView methodsFor: 'deEmphasizing'! deEmphasizeView emphasisOn ifTrue: [self deselect. emphasisOn _ false. self displaySelectionBox]! emphasizeView emphasisOn ifFalse: [self deselect. emphasisOn _ true. self displaySelectionBox]! ! !ListView methodsFor: 'controller access'! defaultControllerClass ^ListController! ! !ListView methodsFor: 'display box access'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^list boundingBox! ! !ListView methodsFor: 'clipping box access'! clippingBox "Answer the rectangle in which the model can be displayed--this is the insetDisplayBox inset by the height of a line for an item." ^self insetDisplayBox insetBy: (Rectangle left: 0 right: 0 top: 0 bottom: self insetDisplayBox height \\ list lineGrid)! ! !ListView methodsFor: 'selecting'! deselect "If the receiver has a selection, then it is highlighted. Remove the highlighting." self displaySelectionBox! findSelection: aPoint "Determine which selection is displayed in an area containing the point, aPoint. Answer the selection if one contains the point, answer nil otherwise." | trialSelection | (self clippingBox containsPoint: aPoint) ifFalse: [^nil]. trialSelection _ aPoint y - list compositionRectangle top // list lineGrid + 1. trialSelection < self minimumSelection | (trialSelection > self maximumSelection) ifTrue: [^nil] ifFalse: [^trialSelection - self minimumSelection + 1]! isSelectionBoxClipped "Answer whether there is a selection and whether the selection is visible on the screen." ^selection ~= 0 & (self selectionBox intersects: self clippingBox) not! maximumSelection "Answer which selection is the last possible one." topDelimiter == nil ifTrue: [^list numberOfLines] ifFalse: [^list numberOfLines - 1]! minimumSelection "Answer which selection is the first possible one." topDelimiter == nil ifTrue: [^1] ifFalse: [^2]! moveSelectionBox: anInteger "Presumably the selection has changed to be anInteger. Deselect the previous selection and display the new one, highlighted." selection ~= anInteger ifTrue: [self deselect. selection _ anInteger. self displaySelectionBox]! selection "Answer the receiver's current selection." ^selection! selectionBox "Answer the rectangle in which the current selection is displayed." ^(self insetDisplayBox left @ (list compositionRectangle top + self selectionBoxOffset) extent: self insetDisplayBox width @ list lineGrid) insetBy: (Rectangle left: 1 right: 1 top: 0 bottom: 0)! selectionBoxOffset "Answer an integer that determines the y position for the display box of the current selection." ^selection - 1 + self minimumSelection - 1 * list lineGrid! ! !ListView methodsFor: 'updating'! update: aSymbol aSymbol == #list ifTrue: [self list: model list. self displayView. ^self]. aSymbol == #listIndex ifTrue: [self moveSelectionBox: model listIndex. ^self]! ! !ListView methodsFor: 'private'! computeCompositionOrigin "Return a new composition rectangle origin positioned correctly in the view's clipping rectangle, such that the currently selected item is visible." | origin offset | origin _ self insetDisplayBox topLeft + (4@0) . offset _ (selection - 1 + self minimumSelection - 1) * list lineGrid. "position selection at top of list" ^origin x @ (origin y - (offset min: ((list height - self insetDisplayBox height + list lineGrid truncateTo: list lineGrid) max: 0)))! positionList |clippingBox translation| clippingBox _ self clippingBox. clippingBox extent = list clippingRectangle extent ifTrue: [translation _ clippingBox origin - list clippingRectangle origin. list clippingRectangle: clippingBox. list setCompositionRectangle: (list compositionRectangle translateBy: translation)] ifFalse: [list repositionAt: self computeCompositionOrigin clippingBox: self clippingBox]! wrappingBox | aRectangle | aRectangle _ self insetDisplayBox. selection = 0 ifTrue: [^aRectangle topLeft + (4 @ 0) extent: list compositionRectangle extent] ifFalse: [^aRectangle left + 4 @ (aRectangle top - (self selectionBoxOffset min: ((list height - aRectangle height + list lineGrid truncateTo: list lineGrid) max: 0))) extent: list compositionRectangle extent]! ! Dictionary variableSubclass: #LiteralDictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! LiteralDictionary comment: 'LiteralDictionaries check not only for equality but also for same class of their keys. This avoids the problem of 0 being considered = to 0.0 as in Dictionaries, and it also avoids the problem of 1.3 not being == to 1.3 (necessarily), as in IdentityDictionaries.'! !LiteralDictionary methodsFor: 'private'! 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 class == key class and: [probe key = key]]] whileFalse: [(location _ location + 1) > length ifTrue: [location _ 1. pass _ pass + 1. pass > 2 ifTrue: [^self grow findKeyOrNil: key]]]. ^location! ! LeafNode subclass: #LiteralNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! LiteralNode comment: 'I am a parse tree leaf representing a literal string or number'! !LiteralNode methodsFor: 'code generation'! emitForValue: stack on: strm code < 256 ifTrue: [strm nextPut: code] ifFalse: [self emitLong: LdInstLong on: strm]. stack push: 1! ! !LiteralNode methodsFor: 'printing'! printOn: aStream indent: level key storeOn: aStream! ! ListController subclass: #LockedListController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Lists'! LockedListController comment: 'I am a kind of ListController that blocks new selections if the model is locked--i.e., has been changed in some way that still requires completion.'! !LockedListController methodsFor: 'control defaults'! controlActivity self normalResponseTest ifTrue: [^super controlActivity]. self feedbackResponseTest ifTrue: [^view flash]! ! !LockedListController methodsFor: 'model access'! feedbackResponseTest "Answer whether the receiver should respond to any user button requests." ^sensor anyButtonPressed | self scrollBarContainsCursor! normalResponseTest "Answer whether the receiver can proceed with selections--depends on whether the model is locked." ^model isUnlocked! ! SwitchController subclass: #LockedSwitchController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! LockedSwitchController comment: 'I am a SwitchController that will not take control if the model (a Switch) is locked. As an indication, the view (a SwitchView) flashes.'! !LockedSwitchController methodsFor: 'control defaults'! isControlWanted model isLocked ifTrue: [view flash. ^false]. ^super isControlWanted! ! Magnitude subclass: #LookupKey instanceVariableNames: 'key ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! LookupKey comment: 'An instance of class LookupKey serves as the key for looking up entries in a Dictionary. Subclasses of LookupKey are dictionary entries. An available example is Association. Instance Variable: key that can be used for testing associations'! !LookupKey methodsFor: 'accessing'! key "Answer the lookup key of the receiver." ^key! key: anObject "Store the argument, anObject, as the lookup key of the receiver." key _ anObject! ! !LookupKey methodsFor: 'comparing'! < aLookupKey "Answer whether the receiver is less than the argument." ^key < aLookupKey key! = aLookupKey "Answer whether the receiver is equal to the argument." self species = aLookupKey species ifTrue: [^key = aLookupKey key] ifFalse: [^false]! hash "Answer a SmallInteger unique to the receiver." ^key hash! ! !LookupKey methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." key printOn: aStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LookupKey class instanceVariableNames: ''! !LookupKey class methodsFor: 'instance creation'! key: aKey "Answer a new instance of the receiver with the argument as the lookup up." ^self new key: aKey! ! Object subclass: #Magnitude instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Numeric-Magnitudes'! Magnitude comment: 'The abstract class Magnitude provides common protocol for objects that have the ability to be compared along a linear dimension like dates or times. Subclasses of Magnitude include Date, Number, and Time, as well as Character, LookupKey, and MessageTally. Subclasses must implement methods for comparison messages < = hash'! !Magnitude methodsFor: 'comparing'! < aMagnitude "Answer whether the receiver is less than the argument." ^self subclassResponsibility! <= aMagnitude "Answer whether the receiver is less than or equal to the argument." ^(self > aMagnitude) not! = aMagnitude "Answer whether the receiver is equal to the argument." ^self subclassResponsibility! > aMagnitude "Answer whether the receiver is greater than the argument." ^aMagnitude < self! >= aMagnitude "Answer whether the receiver is greater than or equal to the argument." ^(self < aMagnitude) not! between: min and: max "Answer whether the receiver is less than or equal to the argument, max, and greater than or equal to the argument, min." ^self >= min and: [self <= max]! hash "Answer a SmallInteger unique to the receiver." ^self subclassResponsibility! max: aMagnitude "Answer the receiver or the argument, whichever has the greater magnitude." self > aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! min: aMagnitude "Answer the receiver or the argument, whichever has the lesser magnitude." self < aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! ! Collection subclass: #MappedCollection instanceVariableNames: 'domain map ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! MappedCollection comment: 'Class MappedCollection represents a re-ordering or subcollecting of a writeable SequenceableCollection. It is basically an access mechanism for referencing a subcollection of a collection whose elements are named. Instance Variables: domain to be accessed indirectly through the external keys stored in map map associates a set of external keys with another set by which the domain can be accessed'! !MappedCollection methodsFor: 'accessing'! at: anInteger "Answer the element at index anInteger." ^domain at: (map at: anInteger)! at: anInteger put: anObject "Set the value at anInteger to be anObject." ^domain at: (map at: anInteger) put: anObject! contents "Answer the receiver's domain for mapping, a SequenceableCollection." ^map collect: [:mappedIndex | domain at: mappedIndex]! size "Answer how many elements the receiver contains." ^map size! ! !MappedCollection methodsFor: 'adding'! add: newObject "Provide an error notification that adding to an Interval is not allowed." self shouldNotImplement! ! !MappedCollection methodsFor: 'copying'! copy "Answer another MappedCollection whereas copyFrom:to: will return an object like the receiver's domain." ^MappedCollection collection: domain map: map! ! !MappedCollection 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." | aStream | aStream _ WriteStream on: (self species new: self size). self do: [:domainValue | aStream nextPut: (aBlock value: domainValue)]. ^aStream contents! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." map do: [:mapValue | aBlock value: (domain at: mapValue)]! select: aBlock | aStream | aStream _ WriteStream on: (self species new: self size). self do: [:domainValue | (aBlock value: domainValue) ifTrue: [aStream nextPut: domainValue]]. ^aStream contents! ! !MappedCollection methodsFor: 'printing'! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a mapped collection similar to the receiver. The general format for mapped collections is ( domain mappedBy: map)" aStream nextPut: $(. domain storeOn: aStream. aStream nextPutAll: ' mappedBy: '. map storeOn: aStream. aStream nextPut: $)! ! !MappedCollection methodsFor: 'private'! setCollection: aCollection map: aDictionary "Initialize the instance variables." domain _ aCollection. map _ aDictionary! species "Answer the class of the receiver." ^domain species! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MappedCollection class instanceVariableNames: ''! !MappedCollection class methodsFor: 'instance creation'! collection: aCollection map: aSequenceableCollection "Answer a new instance of me that maps aCollection by aSequenceableCollection." ^self basicNew setCollection: aCollection map: aSequenceableCollection! new "Provide an error notification that MappedCollections can not be created using this message." self error: 'MappedCollections must be created using the collection:map: message'! ! Object subclass: #MenuBuilder instanceVariableNames: 'myString myContents subTrees ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! MenuBuilder comment: 'I am a builder of HierarchicalMenu''s. I parse a simple language for building menus. For an example see the method "example" in class HierarchicalMenu. '! !MenuBuilder methodsFor: 'initialize-release'! contents: item myContents _ item! initialize myString _ nil. myContents _ nil. subTrees _ OrderedCollection new! string: string myString _ string! ! !MenuBuilder methodsFor: 'inserting'! add: subTree "Add subTree to the end of the receiver's list." subTrees add: subTree.! ! !MenuBuilder methodsFor: 'accessing'! contents ^myContents! hasString ^myString notNil! isLeaf ^subTrees isEmpty! string ^myString! treeNamed: string | found | myString = string ifTrue: [^self]. subTrees isNil ifTrue: [^nil]. subTrees do: [:item | (found _ item treeNamed: string) notNil ifTrue: [^found]]. ^nil! ! !MenuBuilder methodsFor: 'parsing'! parseFrom: stream "If the right square bracket is doubled in the specification of myString, then treat it like a normal character. What we really need is some way of quoteing the delimeter characters" | delimiters next newStream | delimiters _ ':([)\' withCRs. stream skipSeparators. (stream peekFor: $( ) ifTrue: [self parseGroupFrom: stream] ifFalse: [newStream _ WriteStream on: (String new: 64). [next _ stream next. next isNil or: [delimiters includes: next]] whileFalse: [newStream nextPut: next]. next isNil ifFalse: [stream skip: -1]. myString _ newStream contents. (stream peekFor: $[ ) ifTrue: [myContents _ (stream upTo: $]). [stream peekFor: $] ] whileTrue:[myContents _ myContents, ']', (stream upTo: $]).]] ifFalse: [myContents _ myString]. myContents _ myContents asSymbol. stream skipSeparators. (stream peekFor: $:) ifTrue: [stream skipSeparators. (stream peekFor: $( ) ifTrue: [self parseGroupFrom: stream] ifFalse: [self add: (self class new parseFrom: stream)]]]. ^self! parseGroupFrom: stream [stream skipSeparators. stream atEnd or: [stream peekFor: $)]] whileFalse: [subTrees add: (self class new parseFrom: stream)]! ! !MenuBuilder methodsFor: 'printing'! printOn: stream "Append to the argument aStream a sequence of characters that identifies the receiver." super printOn: stream. self printOn: stream level: 1! printOn: stream level: level | delta | delta _ 0. self hasString ifFalse: [stream nextPut: $(] ifTrue: [stream crtab: level. delta _ 1. stream nextPutAll: myString. myContents == nil ifFalse: [stream nextPut: $[; nextPutAll: myContents; nextPut: $]]. self isLeaf ifFalse: [stream nextPut: $:]]. subTrees do: [:tree | tree printOn: stream level: level+delta]. self hasString ifFalse: [stream nextPut: $)].! ! !MenuBuilder methodsFor: 'menus'! addStringListTo: list subTrees do: [:tree | tree hasString ifTrue: [list last add: tree string] ifFalse: [list last isEmpty ifFalse: [list add: OrderedCollection new]. tree addStringListTo: list]]. ^list! asString "for HierarchicalMenu compatibility" ^myString! menu | menu labels items | labels _ self stringList. items _ self menuList. menu _ HierarchicalMenu labelList: labels. menu prefix: 'prefix not used' items: items. ^menu! menuList | items | items _ WriteStream on: (Array new: 20). subTrees do: [:tree | tree isLeaf ifTrue: [items nextPut: tree contents] ifFalse: [tree hasString ifTrue: [items nextPut: tree menu] ifFalse: [items nextPutAll: tree menuList]]]. ^items contents! stringList ^self addStringListTo: (OrderedCollection with: OrderedCollection new)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MenuBuilder class instanceVariableNames: ''! !MenuBuilder class methodsFor: 'instance creation'! new ^super new initialize! parseFrom: stream ^self new parseGroupFrom: stream! ! Object subclass: #Message instanceVariableNames: 'selector args ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! Message comment: 'Class Message represents a selector and its argument values. Generally, the system does not use instances of Message. However, when a message is not understood by its receiver, the interpreter will make up a Message (to capture the information involved in an actual message transmission) and send it as an argument with the message doesNotUnderstand:. Instance Variables: selector args '! !Message methodsFor: 'accessing'! arguments "Answer the arguments of the receiver." ^args! selector "Answer the selector of the receiver." ^selector! ! !Message methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver. The general format is a Message with selector: selector and arguments: arguments" aStream nextPutAll: 'a Message with selector: '. selector printOn: aStream. aStream nextPutAll: ' and arguments: '. args printOn: aStream. ^aStream! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a message similar to the receiver. The general format for messages is ( Message selector: selector arguments: args)" aStream nextPut: $(. aStream nextPutAll: 'Message selector: '. selector storeOn: aStream. aStream nextPutAll: ' arguments: '. args storeOn: aStream. aStream nextPut: $)! ! !Message methodsFor: 'private'! setSelector: aSymbol arguments: anArray selector _ aSymbol. args _ anArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Message class instanceVariableNames: ''! !Message class methodsFor: 'instance creation'! selector: aSymbol "Answer an instance of me with unary selector, aSymbol." ^self new setSelector: aSymbol arguments: (Array new: 0)! selector: aSymbol argument: anObject "Answer an instance of me whose selector is aSymbol and single argument is anObject." ^self new setSelector: aSymbol arguments: (Array with: anObject)! selector: aSymbol arguments: anArray "Answer an instance of me with selector, aSymbol, and arguments, anArray." ^self new setSelector: aSymbol arguments: anArray! ! ParseNode subclass: #MessageNode instanceVariableNames: 'receiver selector precedence special arguments sizes pc ' classVariableNames: 'MacroEmitters MacroSelectors MacroSizers MacroTransformers ThenFlag ' poolDictionaries: '' category: 'System-Compiler'! MessageNode comment: 'I represent a receiver and its message. Precedence codes: 1 unary 2 binary 3 keyword 4 other If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.'! !MessageNode methodsFor: 'initialize-release'! receiver: rcvr selector: selNode arguments: args precedence: p "decompile" self receiver: rcvr arguments: args precedence: p. special _ MacroSelectors indexOf: selNode key. selector _ selNode! receiver: rcvr selector: selName arguments: args precedence: p from: encoder "compile" self receiver: rcvr arguments: args precedence: p. special _ MacroSelectors indexOf: selName. (self transform: encoder) ifTrue: [selector _ SelectorNode new key: (MacroSelectors at: special) code: #macro] ifFalse: [selector _ encoder encodeSelector: selName. rcvr == NodeSuper ifTrue: [encoder noteSuper]]! receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range "compile" encoder noteSourceRange: range forNode: self. ^self receiver: rcvr selector: selName arguments: args precedence: p from: encoder! ! !MessageNode methodsFor: 'testing'! canCascade ^(receiver == NodeSuper or: [special > 0]) not! isReturningIf ^(special between: 3 and: 4) and: [arguments first returns and: [arguments last returns]]! ! !MessageNode methodsFor: 'expression types'! cascadeReceiver "nil out rcvr (to indicate cascade) and return what it had been" | rcvr | rcvr _ receiver. receiver _ nil. ^rcvr! ! !MessageNode methodsFor: 'code generation'! emitForEffect: stack on: strm special > 0 ifTrue: [self perform: (MacroEmitters at: special) with: stack with: strm with: false. pc _ 0] ifFalse: [super emitForEffect: stack on: strm. pc _ strm position]! emitForValue: stack on: strm special > 0 ifTrue: [self perform: (MacroEmitters at: special) with: stack with: strm with: true. pc _ 0] ifFalse: [receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm]. arguments do: [:argument | argument emitForValue: stack on: strm]. selector emit: stack args: arguments size on: strm super: receiver == NodeSuper. pc _ strm position]! emitIf: stack on: strm value: forValue "Emit code for ifTrue: ifFalse: , with some optimizations" | thenExpr thenSize elseExpr elseSize | thenSize _ sizes at: 1. elseSize _ sizes at: 2. thenExpr _ arguments at: 1. elseExpr _ arguments at: 2. forValue ifTrue: ["Everything is straightforward for value: bfp-C jmp-end " receiver emitForValue: stack on: strm. self emitBranch: thenSize pop: stack on: strm. thenExpr emitForEvaluatedValue: stack on: strm. stack pop: 1. thenExpr returns ifFalse: [self emitJump: elseSize on: strm]. elseExpr emitForEvaluatedValue: stack on: strm] ifFalse: ["If value not needed, check for possible shortcuts" (thenSize=0) & (elseSize=0) "null conditional" ifTrue: [^ receiver emitForEffect: stack on: strm]. (elseSize = 0) | (thenSize = 0) ifTrue: [receiver emitForValue: stack on: strm. (elseSize = 0) ifTrue: ["Shortcut for ifTrue: only: bfp-end " self emitBranch: thenSize pop: stack on: strm. thenExpr emitForEvaluatedEffect: stack on: strm] ifFalse: ["Shortcut for ifFalse: only btp-end " self emitTrueBranch: elseSize pop: stack on: strm. elseExpr emitForEvaluatedEffect: stack on: strm]] ifFalse: ["If no shortcuts, then compile for value followed by pop" super emitForEffect: stack on: strm]]! emitWhile: stack on: strm value: forValue "Size code for whileTrue: , or whileFalse: " | stmt stmtSize loopSize | stmt _ arguments at: 1. stmtSize _ sizes at: 1. "Includes loop-back jump" loopSize _ sizes at: 2. receiver emitForEvaluatedValue: stack on: strm. selector key == #whileTrue: ifTrue: [self emitBranch: stmtSize pop: stack on: strm] ifFalse: [self emitTrueBranch: stmtSize pop: stack on: strm]. stmt emitForEvaluatedEffect: stack on: strm. self emitJump: 0 - loopSize on: strm. forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! pc "used by encoder source mapping" ^pc! sizeForEffect: encoder special > 0 ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: false]. ^super sizeForEffect: encoder! sizeForValue: encoder | total argSize | special > 0 ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true]. receiver == NodeSuper ifTrue: [selector _ selector copy "only necess for splOops"]. total _ selector size: encoder args: arguments size super: receiver == NodeSuper. receiver == nil ifFalse: [total _ total + (receiver sizeForValue: encoder)]. sizes _ arguments collect: [:arg | argSize _ arg sizeForValue: encoder. total _ total + argSize. argSize]. ^total! sizeIf: encoder value: forValue "Size code for ifTrue: ifFalse: , with some optimizations" | thenExpr thenSize elseExpr elseSize noElse noThen | thenExpr _ arguments at: 1. elseExpr _ arguments at: 2. forValue ifTrue: ["Everything is straightforward for value: bfp-C jmp-end " elseSize _ elseExpr sizeForEvaluatedValue: encoder. thenSize _ (thenExpr sizeForEvaluatedValue: encoder) + (thenExpr returns ifTrue: [0] ifFalse: [self sizeJump: elseSize])] ifFalse: ["If value not needed, check for possible shortcuts" (noElse _ elseExpr isJust: NodeNil) | (noThen _ thenExpr isJust: NodeNil) ifFalse: "If no shortcuts, then compile for value followed by pop" [^ super sizeForEffect: encoder]. elseSize _ noElse ifTrue: [0] ifFalse: [elseExpr sizeForEvaluatedEffect: encoder]. thenSize _ noThen ifTrue: [0] ifFalse: [thenExpr sizeForEvaluatedEffect: encoder]]. sizes _ Array with: thenSize with: elseSize. (thenSize=0) & (elseSize=0) "null conditional" ifTrue: [^ receiver sizeForEffect: encoder]. ^ (receiver sizeForValue: encoder) + (thenSize=0 ifTrue: [2 "BTP is long"] ifFalse: [self sizeBranch: thenSize]) + thenSize + elseSize! sizeWhile: encoder value: forValue "Size code for whileTrue: , or whileFalse: " | stmt branchSize stmtSize loopSize | stmt _ arguments at: 1. stmtSize _ (stmt sizeForEvaluatedEffect: encoder) + 2. "loop jump is 2 bytes" selector key == #whileTrue: ifTrue: [branchSize _ self sizeBranch: stmtSize] ifFalse: [branchSize _ 2 "BTP is always 2 bytes"]. loopSize _ (receiver sizeForEvaluatedValue: encoder) + branchSize + stmtSize. sizes _ Array with: stmtSize with: loopSize. ^ loopSize + (forValue ifTrue: [1] ifFalse: [0]) "push nil (for value) takes 1 byte"! ! !MessageNode methodsFor: 'debugger temp access'! isTemp "Sorry, folks, for now you cant use remote temps in blocks" "This could be fixed by supporting store protocol for the case of assignment into virtual fields in BlockNode sizeForValue and emitForValue" ^ false! store: expr from: encoder "ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment). For assigning into temps of a context being debugged" selector key ~= #tempAt: ifTrue: [^self error: 'cant transform this message']. ^MessageNode new receiver: receiver selector: #tempAt:put: arguments: (arguments copyWith: expr) precedence: precedence from: encoder! ! !MessageNode methodsFor: 'printing'! precedence ^precedence! printIfOn: aStream indent: level (arguments last isJust: NodeNil) ifTrue: [^self printKeywords: #ifTrue: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments last isJust: NodeFalse) ifTrue: [^self printKeywords: #and: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments first isJust: NodeNil) ifTrue: [^self printKeywords: #ifFalse: arguments: (Array with: arguments last) on: aStream indent: level]. (arguments first isJust: NodeTrue) ifTrue: [^self printKeywords: #or: arguments: (Array with: arguments last) on: aStream indent: level]. self printKeywords: #ifTrue:ifFalse: arguments: arguments on: aStream indent: level! printKeywords: key arguments: args on: aStream indent: level | keywords prev arg indent thisKey | args size = 0 ifTrue: [aStream space; nextPutAll: key. ^self]. keywords _ key keywords. prev _ receiver. 1 to: args size do: [:part | arg _ args at: part. thisKey _ keywords at: part. (prev isMemberOf: BlockNode) | ((prev isMemberOf: MessageNode) and: [prev precedence >= 3]) | ((arg isMemberOf: BlockNode) and: [arg isComplex and: [thisKey ~= #do:]]) | (args size > 2) | (key = #ifTrue:ifFalse:) ifTrue: [aStream crtab: level+1. indent _ 1] "newline after big args" ifFalse: [aStream space. indent _ 0]. aStream nextPutAll: thisKey; space. arg printOn: aStream indent: level + 1 + indent precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence]). prev _ arg]! printOn: aStream indent: level receiver == nil ifFalse: [receiver printOn: aStream indent: level precedence: precedence]. (special between: 1 and: 6) ifTrue: [self printIfOn: aStream indent: level] ifFalse: [self printKeywords: selector key arguments: arguments on: aStream indent: level]! printOn: strm indent: level precedence: p | parenthesize | parenthesize _ precedence > p or: [p = 3 and: [precedence = 3 "both keywords"]]. parenthesize ifTrue: [strm nextPutAll: '(']. self printOn: strm indent: level. parenthesize ifTrue: [strm nextPutAll: ')']! ! !MessageNode methodsFor: 'private'! checkBlock: node as: nodeName from: encoder node canBeSpecialArgument ifTrue: [^node isMemberOf: BlockNode]. ((node isKindOf: BlockNode) and: [node numberOfArguments > 0]) ifTrue: [^encoder notify: '<- ', nodeName , ' of ' , (MacroSelectors at: special) , ' must be 0-argument block'] ifFalse: [^encoder notify: '<- ', nodeName , ' of ' , (MacroSelectors at: special) , ' must be a block or variable']! receiver: rcvr arguments: args precedence: p receiver _ rcvr. arguments _ args. sizes _ Array new: arguments size. precedence _ p! transform: encoder special = 0 ifTrue: [^false]. (self perform: (MacroTransformers at: special) with: encoder) ifTrue: [^true] ifFalse: [special _ 0. ^false]! transformAnd: encoder (self transformBoolean: encoder) ifTrue: [arguments _ Array with: (arguments at: 1) with: (BlockNode new statements: (Array with: NodeFalse) returns: false). ^true] ifFalse: [^false]! transformBoolean: encoder ^self checkBlock: (arguments at: 1) as: 'argument' from: encoder! transformIfFalse: encoder (self transformBoolean: encoder) ifTrue: [arguments _ Array with: (BlockNode new statements: (Array with: NodeNil) returns: false) with: (arguments at: 1). ^true] ifFalse: [^false]! transformIfFalseIfTrue: encoder ((self checkBlock: (arguments at: 1) as: 'False arg' from: encoder) and: [self checkBlock: (arguments at: 2) as: 'True arg' from: encoder]) ifTrue: [selector _ #ifTrue:ifFalse:. arguments swap: 1 with: 2. ^true] ifFalse: [^false]! transformIfTrue: encoder (self transformBoolean: encoder) ifTrue: [arguments _ Array with: (arguments at: 1) with: (BlockNode new statements: (Array with: NodeNil) returns: false). ^true] ifFalse: [^false]! transformIfTrueIfFalse: encoder ^(self checkBlock: (arguments at: 1) as: 'True arg' from: encoder) and: [self checkBlock: (arguments at: 2) as: 'False arg' from: encoder]! transformOr: encoder (self transformBoolean: encoder) ifTrue: [arguments _ Array with: (BlockNode new statements: (Array with: NodeTrue) returns: false) with: (arguments at: 1). ^true] ifFalse: [^false]! transformWhile: encoder ^(self transformBoolean: encoder) and: [self checkBlock: receiver as: 'receiver' from: encoder]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MessageNode class instanceVariableNames: ''! !MessageNode class methodsFor: 'class initialization'! initialize "MessageNode initialize." MacroSelectors _ #(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: and: or: whileFalse: whileTrue: ). MacroTransformers _ #(transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue: transformAnd: transformOr: transformWhile: transformWhile: ). MacroEmitters _ #(emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value: emitWhile:on:value: emitWhile:on:value: ). MacroSizers _ #(sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value: sizeWhile:value: sizeWhile:value: )! ! MessageNode initialize! Magnitude subclass: #MessageTally instanceVariableNames: 'class method tally receivers ' classVariableNames: 'HowOften ObservedProcess TargetBlock Timer ' poolDictionaries: '' category: 'System-Support'! MessageTally comment: 'See the comment for spyOn: in MessageTally class for an example of how to use the spy. MessageTallies represent nodes in a tree which gathers statistics on the time spent in various parts of the system. Specifically, each node represents a message being sent. During the evaluation of an expression, a timer periodically interrupts the execution of the various methods involved, and tallies these probes in the tree of MessageTallies which it constructs. When evaluation of the expression is complete, a detailed report is produced indicating where in the system most of the time was spent. Instance Variables: class the class of the receiver of the message method which was running when probe occurred tally number of probes which hit this method or others called by it receivers of MessageTally; sons of this node in the tree, representing tallies of methods called from this one. If this field is nil, it indicates tallies due to in-line primitives MessageTallies may be taken on only one block at a time. Spying on two blocks at once does not work. The block upon which the MessageTally is spying can be stopped and started. See spyEvery:on:. Class Variables: HowOften when to take a look> ObservedProcess TargetBlock Timer '! !MessageTally methodsFor: 'initialize-release'! close (Timer isMemberOf: Process) ifTrue: [Timer terminate]. Timer _ ObservedProcess _ nil. class _ method _ tally _ receivers _ nil! continueSpying | myDelay value active | myDelay _ Delay forMilliseconds: HowOften. active _ true. Timer _ [[active] whileTrue: [myDelay wait. active ifTrue: [self tally: ObservedProcess suspendedContext]]. nil] newProcess. Timer priority: Processor userInterruptPriority. "activate the probe and evaluate the block" Timer resume. value _ TargetBlock value. active _ false. "Timer will fire once more, not tally, and terminate itself" ^value "return the block's value"! defaultInterval "Answer the number of ticks between sampling." Smalltalk frills ifTrue: [^16] ifFalse: [^60]! reportOn: aStream "Default cutoff percentage is 2%." self reportOn: aStream cutoff: 2! reportOn: aStream cutoff: perCent "Print a report on the stream. perCent should be a number like 2 or 3" tally = 0 ifTrue: [aStream nextPutAll: ' - no tallies obtained'] ifFalse: [aStream nextPutAll: ' - '; print: tally; nextPutAll: ' tallies.'; cr; cr. self fullPrintOn: aStream cutoff: perCent]! spyEvery: millisecs on: aBlock "Create a spy on the given block at the specified rate. Don't run it yet" "Set a block up for spying, and accumulate the tallies from several executions | spy | spy _ MessageTally new. spy spyEvery: spy defaultInterval on: ['this block contains your code'. 30 factorial]. 10 timesRepeat: [spy continueSpying]. spy report: 'spy.results'. spy close. (FileStream fileNamed: 'spy.results') edit. If there are no tallies reported, the block executes faster than the delay" (aBlock isMemberOf: BlockContext) ifFalse: [self error: 'spy needs a block here']. self class: aBlock receiver class method: aBlock method. "set up the probe" ObservedProcess _ Processor activeProcess. HowOften _ millisecs. TargetBlock _ aBlock! spyOn: aBlock "Spy on the evaluation of aBlock. Browse the results in a workspace." | val reportStream | "Set up the block" self spyEvery: self defaultInterval on: aBlock. "Run the block and take the tallies" val _ self continueSpying. "Report it" reportStream _ WriteStream on: (String new: 5000). self reportOn: reportStream. self close. StringHolderView open: (StringHolder new contents: reportStream contents) label: 'Spy Results'. ^val "Never gets returned due to window scheduling"! spyOn: aBlock to: fileName "Spy on the evaluation of aBlock. Write the data collected on a file named fileName." | val aFileStream | "Set up the block" self spyEvery: self defaultInterval on: aBlock. "Run the block and take the tallies" val _ self continueSpying. "Report it" aFileStream _ FileStream fileNamed: fileName. aFileStream timeStamp; nextPutAll: fileName; space. self reportOn: aFileStream. self close. aFileStream close. ^val! ! !MessageTally methodsFor: 'comparing'! < aMessageTally "Answer whether the receiver is less than the argument." ^tally > aMessageTally tally! = aMessageTally "Answer whether the receiver is equal to the argument." ^aMessageTally method == method! > aMessageTally "Answer whether the receiver is greater than the argument." ^tally < aMessageTally tally! hash "Answer with a SmallInteger unique to the receiver." ^method identityHash! sonsOver: threshold | hereTally last sons | (receivers == nil or: [receivers size = 0]) ifTrue: [^#()]. hereTally _ tally. sons _ receivers select: "subtract subNode tallies for primitive hits here" [:son | hereTally _ hereTally - son tally. son tally > threshold]. hereTally > threshold ifTrue: [last _ MessageTally new class: class method: method. ^sons copyWith: (last primitives: hereTally)]. ^sons! ! !MessageTally methodsFor: 'tallying'! bump tally _ tally + 1! tally: context "Explicitly tally the specified context and its stack." | root | context method == method ifTrue: [^self bump]. (root _ context home sender) == nil ifTrue: [^self bump tallyPath: context]. ^(self tally: root) tallyPath: context! tallyPath: context | aMethod path | aMethod _ context method. receivers do: [:aMessageTally | aMessageTally method == aMethod ifTrue: [path _ aMessageTally]]. path == nil ifTrue: [path _ MessageTally new class: context receiver class method: aMethod. receivers _ receivers copyWith: path]. ^path bump! ! !MessageTally methodsFor: 'collecting leaves'! bump: anInteger tally _ tally + anInteger! into: aDictionary | aMessageTally index | index _ aDictionary find: self ifAbsent: [aDictionary add: (aMessageTally _ MessageTally new class: class method: method). ^aMessageTally bump: tally]. (aDictionary basicAt: index) bump: tally! leaves: leafDictionary | aBreakDown | aBreakDown _ self sonsOver: 0. aBreakDown size = 0 ifTrue: [self into: leafDictionary] ifFalse: [aBreakDown do: [:aMessageTally | aMessageTally leaves: leafDictionary]]! ! !MessageTally methodsFor: 'printing'! fullPrintOn: aStream cutoff: perCent | threshold | threshold _ (perCent asFloat / 100 * tally) rounded. aStream nextPutAll: '**Tree**'; cr. self treePrintOn: aStream tabs: OrderedCollection new thisTab: '' total: tally over: threshold. aStream nextPut: Character newPage; cr. aStream nextPutAll: '**Leaves**'; cr. self leavesPrintOn: aStream over: threshold.! leavesPrintOn: aStream over: threshold | aSet | aSet _ Set new: 128. self leaves: aSet. (aSet asOrderedCollection select: [:node | node tally > threshold]) asSortedCollection do: [:node | node printOn: aStream total: tally]! printOn: aStream total: total | aSelector aClass | aStream print: (tally asFloat / total * 100.0 roundTo: 0.1); space. receivers == nil ifTrue: [aStream nextPutAll: 'primitives'] ifFalse: [aSelector _ class selectorAtMethod: method setClass: [:cl | aClass _ cl]. aStream nextPutAll: aClass name; space; nextPutAll: aSelector]. aStream cr! treePrintOn: aStream tabs: tabs thisTab: myTab total: total over: threshold | sons sonTab | tabs do: [:tab | aStream nextPutAll: tab]. tabs size > 0 ifTrue: [self printOn: aStream total: total]. sons _ self sonsOver: threshold. sons isEmpty ifFalse: [tabs addLast: myTab. sons _ sons asSortedCollection. (1 to: sons size) do: [:i | sonTab _ i < sons size ifTrue: [' |'] ifFalse: [' ']. (sons at: i) treePrintOn: aStream tabs: tabs thisTab: sonTab total: total over: threshold]. tabs removeLast]! ! !MessageTally methodsFor: 'private'! class: aClass method: aMethod class _ aClass. method _ aMethod. tally _ 0. receivers _ Array new: 0! method ^method! primitives: anInteger tally _ anInteger. receivers _ nil! tally ^tally! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MessageTally class instanceVariableNames: ''! !MessageTally class methodsFor: 'spying'! spyOn: aBlock "An execution profile of the execution of aBlock is obtained. For example: MessageTally spyOn: [Pen penSampler]. The execution profile is presented in a workspace (user is prompted for area). No value is returned" | spy val reportStream | spy _ self new. spy spyEvery: spy defaultInterval on: aBlock. "Run the block and take the tallies" val _ spy continueSpying. "Report it" reportStream _ WriteStream on: (String new: 5000). spy reportOn: reportStream; close. StringHolderView open: (StringHolder new contents: reportStream contents) label: 'Spy Results'. ^val "Never gets returned due to window scheduling"! spyOn: aBlock to: fileName "Spy on the evaluation of aBlock. Write the data collected on a file named fileName. The value of the block is returned as the value of this method. " "For example: MessageTally spyOn: [Smalltalk asSortedCollection] to: 'spy.results'. (FileStream oldFileNamed: 'spy.results') edit. " | spy val aFileStream | spy _ self new. "Set up the block" spy spyEvery: spy defaultInterval on: aBlock. "Run the block and take the tallies" val _ spy continueSpying. "Report it" aFileStream _ FileStream fileNamed: fileName. aFileStream timeStamp; nextPutAll: fileName; space. spy reportOn: aFileStream; close. aFileStream close. ^val! ! ClassDescription subclass: #Metaclass instanceVariableNames: 'thisClass ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! Metaclass comment: 'Metaclasses add instance-specific behavior to various classes in the system. This typically includes messages for initializing class variables and instance creation messages particular to that class. There is only one instance of a metaclass, namely the class (thisClass) which is being described. A metaclass shares the class variables of its instance. [Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus, Integer superclass == Number, and Integer class superclass == Number class. However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, Object superclass == nil, and Object class superclass == Class. Instance Variable: thisClass the chief instance of the receiver, which the receiver describes '! !Metaclass methodsFor: 'initialize-release'! instanceVariableNames: instVarString "Declare additional variables for my instances." | newMeta invalid ok | newMeta _ self copyForValidation. invalid _ newMeta subclassOf: superclass oldClass: self instanceVariableNames: instVarString variable: false words: true pointers: true ifBad: [^false]. invalid ifTrue: [ok _ newMeta validateFrom: self in: Smalltalk instanceVariableNames: true methods: true. Smalltalk changes changeClass: self. ^ok]! newNamed: aSymbol "Answer a new instance of me whose name is the argument, aSymbol." ^(Metaclass subclassOf: self) new superclass: Object methodDict: MethodDictionary new format: -8192 name: aSymbol organization: ClassOrganizer new instVarNames: nil classPool: nil sharedPools: nil! newNamed: aSymbol otherSupers: others "Answer a new instance of me whose name is the argument, aSymbol." ^ (MetaclassForMultipleInheritance subclassOf: self and: others) new superclass: Object methodDict: MethodDictionary new format: -8192 name: aSymbol organization: ClassOrganizer new instVarNames: nil classPool: nil sharedPools: nil! obsolete "Invalidate and recycle local messages. Remove the receiver from its superclass' subclass list." thisClass_ nil. super obsolete! subclassOf: superMeta "Change the receiver to be a subclass of the argument, superMeta, a metaclass. Reset the receiver's method dictionary and properties." superclass _ superMeta. methodDict _ MethodDictionary new. format _ superMeta format. instanceVariables _ nil! superclass: superMeta "Change the receiver's superclass to be the argument, superMeta, a metaclass." superclass _ superMeta! ! !Metaclass methodsFor: 'accessing'! name "Answer a String that is the name of the receiver, either Metaclass or the name of the receiver's class followed by the ' class'." thisClass == nil ifTrue: [^'a Metaclass'] ifFalse: [^thisClass name , ' class']! soleInstance "The receiver has only one instance. Answer it." ^thisClass! ! !Metaclass methodsFor: 'testing'! isMeta ^ true! isObsolete "Answer whether the receiver is an obsolete metaclass." ^thisClass == nil or: [thisClass ~~ (Smalltalk at: thisClass name ifAbsent: [nil])] "should only be true for obsolete metaclass"! ! !Metaclass methodsFor: 'copying'! copy "Make a copy of the receiver without a list of subclasses. Share the reference to the sole instance." | copy t | t _ thisClass. thisClass _ nil. copy _ super copy. thisClass _ t. ^copy! copyForValidation "Special copy for ClassDescription validateFrom:in:fields:methods:. Answer a copy of the receiver without the subclasses." ^super copy! ! !Metaclass methodsFor: 'instance creation'! new "The receiver can only have one instance. Create it or complain that one already exists." thisClass == nil ifTrue: [^thisClass _ super new] ifFalse: [self error: 'A Metaclass should only have one instance!!']! ! !Metaclass methodsFor: 'instance variables'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." | fullString | fullString _ aString. self instVarNames do: [:aString2 | fullString _ aString2 , ' ' , fullString]. self instanceVariableNames: fullString! removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables." | newArray newString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newArray _ self instVarNames copyWithout: aString. newString _ ''. newArray do: [:aString2 | newString _ aString2 , ' ' , newString]. self instanceVariableNames: newString! ! !Metaclass methodsFor: 'class variables'! addClassVarName: aString ^thisClass addClassVarName: aString! classPool "Answer the dictionary of class variables." ^thisClass classPool! ! !Metaclass methodsFor: 'class hierarchy'! instHasMultipleSuperclasses ^false! name: newName inEnvironment: environ subclassOf: sup and: others instanceVariableNames: instVarString variable: v words: w pointers: p classVariableNames: classVarString poolDictionaries: poolString category: categoryName comment: commentString changed: changed "Create a new metaclass from the information provided in the arguments. Create an error if the name does not begin with an uppercase letter or if a class of the same name already exists." | wasPresent oldClass newClass invalidFields invalidMethods | newName first isUppercase ifFalse: [self error: 'Class names must be capitalized'. ^false]. (wasPresent _ environ includesKey: newName) ifTrue: [oldClass _ environ at: newName. (oldClass isKindOf: Behavior) ifFalse: [self error: newName , ' already exists!! Proceed will store over it'. wasPresent _ false. oldClass _ self newNamed: newName otherSupers: others]] ifFalse: [oldClass _ self newNamed: newName otherSupers: others]. newClass _ oldClass copy. invalidFields _ changed | (newClass subclassOf: sup oldClass: oldClass instanceVariableNames: instVarString variable: v words: w pointers: p ifBad: [^false]). invalidFields ifFalse: [newClass obsolete. newClass _ oldClass]. invalidMethods _ invalidFields | (newClass declare: classVarString) | (newClass sharing: poolString). commentString == nil ifFalse: [newClass comment: commentString]. (environ includesKey: newName) ifFalse: [environ declare: newName from: Undeclared. environ at: newName put: newClass]. SystemOrganization classify: newClass name under: categoryName asSymbol. newClass validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods. "update subclass lists" newClass superclasses do: [:newSup | newSup removeSubclass: oldClass; addSubclass: newClass]. "Update Changes" wasPresent ifTrue: [Smalltalk changes changeClass: newClass] ifFalse: [Smalltalk changes addClass: newClass]. "Now check for possible conflicting definitions in superclasses" invalidFields ifTrue: [newClass copyMethods. newClass class copyMethods]. ^newClass! name: newName inEnvironment: environ subclassOf: sup instanceVariableNames: instVarString variable: v words: w pointers: p classVariableNames: classVarString poolDictionaries: poolString category: categoryName comment: commentString changed: changed "Create a new metaclass from the information provided in the arguments. Create an error if the name does not begin with an uppercase letter or if a class of the same name already exists." | wasPresent oldClass newClass invalidFields invalidMethods | newName first isUppercase ifFalse: [self error: 'Class names must be capitalized'. ^false]. (wasPresent _ environ includesKey: newName) ifTrue: [oldClass _ environ at: newName. (oldClass isKindOf: Behavior) ifFalse: [self error: newName , ' already exists!! Proceed will store over it'. wasPresent _ false. oldClass _ self newNamed: newName]] ifFalse: [oldClass _ self newNamed: newName]. newClass _ oldClass copy. invalidFields _ changed | (newClass subclassOf: sup oldClass: oldClass instanceVariableNames: instVarString variable: v words: w pointers: p ifBad: [^false]). invalidFields ifFalse: [newClass obsolete. newClass _ oldClass]. invalidMethods _ invalidFields | (newClass declare: classVarString) | (newClass sharing: poolString). commentString == nil ifFalse: [newClass comment: commentString]. (environ includesKey: newName) ifFalse: [environ declare: newName from: Undeclared. environ at: newName put: newClass]. SystemOrganization classify: newClass name under: categoryName asSymbol. newClass validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods. "update subclass lists" newClass superclass removeSubclass: oldClass. newClass superclass addSubclass: newClass. "Update Changes" wasPresent ifTrue: [Smalltalk changes changeClass: newClass] ifFalse: [Smalltalk changes addClass: newClass]. ^newClass! subclasses "Answer the receiver's subclasses." | temp | self == Class class ifTrue: ["Meta-Object is exceptional subclass of Class" temp _ thisClass subclasses copy. temp remove: Object class. ^temp collect: [:aSubClass | aSubClass class]]. thisClass == nil ifTrue: [^Set new] ifFalse: [^thisClass subclasses collect: [:aSubClass | aSubClass class]]! ! !Metaclass methodsFor: 'compiling'! scopeHas: name ifTrue: assocBlock ^thisClass scopeHas: name ifTrue: assocBlock! ! !Metaclass methodsFor: 'printing'! definition "Answer with a string that defines me" | aStream names | aStream _ WriteStream on: (String new: 300). self printOn: aStream. aStream nextPutAll: ' instanceVariableNames: '''. names _ self instVarNames. 1 to: names size do: [:i | aStream nextPutAll: (names at: i); space]. aStream nextPut: $'. ^ aStream contents! ! !Metaclass methodsFor: 'fileIn/Out'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "File me out on aFileStream." super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. (methodDict includesKey: #initialize) ifTrue: [aFileStream cr. aFileStream cr. aFileStream nextChunkPut: thisClass name , ' initialize'. aFileStream cr]! nonTrivial ^self instVarNames size > 0 or: [methodDict size > 0 or: [self comment size > 0]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Metaclass class instanceVariableNames: ''! !Metaclass class methodsFor: 'instance creation'! subclassOf: superMeta "Answer a metaclass that is a subclass of metaclass superMeta." ^self new subclassOf: superMeta! ! Metaclass subclass: #MetaclassForMultipleInheritance instanceVariableNames: 'otherSuperclasses ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! MetaclassForMultipleInheritance comment: 'This metaclass has an additional field and protocol to support multiple inheritance. Instance Variable: otherSuperclasses The field, otherSuperclasses, contains a collection of additional superclasses (other than the normal dynamic one) from which traits are to be inherited. Since the otherSuperclasses appears in the metaclass, classes must ask their metas for other supers (sort of the way metas ask their thisClasses for subs). It would have been more natural to put otherSuperclasses into a class ClassWithMultSupers, but this would have had to inherit both the multiple supers AND the normal metaclass inheritance, thus posing a bootstrapping need for multiple inheritance.'! !MetaclassForMultipleInheritance methodsFor: 'class hierarchy'! instHasMultipleSuperclasses ^true! otherSuperclasses ^ otherSuperclasses! setOtherSuperclasses: others otherSuperclasses _ others! superclasses ^ (Array with: superclass) , (otherSuperclasses collect: [:sup | sup class])! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetaclassForMultipleInheritance class instanceVariableNames: ''! !MetaclassForMultipleInheritance class methodsFor: 'superclass access'! subclassOf: sup and: others | newMeta | newMeta _ super subclassOf: sup. newMeta setOtherSuperclasses: others. ^newMeta! ! ClassRelatedChange subclass: #MethodChange instanceVariableNames: 'selector category ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! MethodChange comment: 'Class MethodChange represents a change to a method (new definition or removal). Instance Variables: selector for method selector category for name of a method category'! !MethodChange methodsFor: 'accessing'! category ^category! category: aSymbol category _ aSymbol asSymbol! parameters ^Array with: className with: selector! selector ^selector! selector: aSymbol selector _ aSymbol asSymbol! ! ContextPart variableSubclass: #MethodContext instanceVariableNames: 'method receiverMap receiver ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! MethodContext comment: 'Instances of class MethodContext hold all the dynamic state associated with the execution of a CompiledMethod. In addition to their inherited state, this includes the receiver, a method, and temporary space in the variable part of the context. MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed. Instance Variables: *indexed* method receiverMap unused (planned for use later for further development of multiple inheritance) receiver '! !MethodContext methodsFor: 'initialize-release'! restart "Reinitialize the receiver so that it is in the state it was at its creation." pc _ method initialPC. stackp _ method numTemps! restartWith: aCompiledMethod "Reinitialize the receiver as though it had been for a different method. Used by a Debugger when one of the methods to which it refers is recompiled." method _ aCompiledMethod. ^self restart! ! !MethodContext methodsFor: 'accessing'! home ^self! method ^method! receiver ^receiver! removeSelf "Nil the receiver pointer and answer the former value." | tempSelf | tempSelf _ receiver. receiver _ nil. ^tempSelf! ! !MethodContext methodsFor: 'temporaries'! tempAt: index ^self at: index! tempAt: index put: value ^self at: index put: value! ! !MethodContext methodsFor: 'private'! setSender: s receiver: r method: m arguments: args "Create the receiver's initial state." sender _ s. receiver _ r. method _ m. pc _ method initialPC. stackp _ method numTemps. 1 to: args size do: [:i | self at: i put: (args at: i)]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodContext class instanceVariableNames: ''! !MethodContext class methodsFor: 'instance creation'! sender: s receiver: r method: m arguments: args ^(self new: m frameSize) setSender: s receiver: r method: m arguments: args! ! MethodChange subclass: #MethodDefinitionChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! MethodDefinitionChange comment: 'Class MethodDefinitionChange represents a change to the text of a method (as opposed to a category change or a removal).'! !MethodDefinitionChange methodsFor: 'accessing'! accept: newText notifying: requestor "Check to make sure the current definition is valid" | methodNode | methodNode _ Compiler new compile: newText in: (Smalltalk at: className ifAbsent: [^nil]) notifying: requestor ifFail: [^nil]. methodNode generate. ^self class new text: self text; className: className; selector: methodNode selector; category: category! name ^className, ' ', selector! ! !MethodDefinitionChange methodsFor: 'file accessing'! fileName file isNil ifTrue: [^'current system'] ifFalse: [^super fileName]! ! !MethodDefinitionChange methodsFor: 'source code'! getSource "Get the source code for this method from information currently in the system." self sourceFileAndPosition: [:aFile :aPosition | file _ aFile. position _ aPosition]! sourceFileAndPosition: aBlock "Get the source code for this method from information currently in the system." | class method fileIndex pos | (class _ self classObject) isNil ifTrue: [^nil]. (class includesSelector: selector) ifFalse: [^nil]. method _ class compiledMethodAt: selector. SourceFiles isNil ifTrue: [^nil]. (fileIndex _ method fileIndex) > SourceFiles size ifTrue: [^nil]. pos _ method getSourcePosition. pos = 0 ifTrue: [^nil]. ^aBlock value: (SourceFiles at: fileIndex) value: pos! text | aStream numArgs | file == nil ifTrue: [aStream _ WriteStream on: (String new: 60). (numArgs _ selector numArgs) = 0 ifTrue: [aStream nextPutAll: selector] ifFalse: [selector keywords with: (1 to: numArgs) do: [:word :i | aStream nextPutAll: word; nextPutAll: ' t'; print: i; space]]. aStream cr; tab; nextPutAll: '"Source code not available"'. ^aStream contents]. ^super text! ! !MethodDefinitionChange methodsFor: 'checking'! checkWith: aChecker | systemVersion oldChanges | aChecker changesAt: self name add: self. aChecker checkSystem ifTrue: [self isInSystem ifFalse: [systemVersion _ self class new className: className; category: category; selector: selector. systemVersion sourceFileAndPosition: [:aFile :aPosition | systemVersion file: aFile position: aPosition. (aChecker equalWithoutComments: self text and: systemVersion text) ifFalse: [oldChanges _ aChecker changesAt: self name. oldChanges size > 1 ifTrue: [oldChanges do: [:c | c isInSystem ifTrue: [^self]]]. aChecker changesAt: self name add: systemVersion]]]]! isInSystem self sourceFileAndPosition: [:aFile :aPosition | (file = aFile and: [position = aPosition]) ifTrue: [^true]]. ^false! ! !MethodDefinitionChange methodsFor: 'fileIn/Out'! fileIn | class | class _ self classObject. class isNil ifTrue: [self error: 'Class ', className, ' does not exist in this system'] ifFalse: [class compile: self text classified: category. Transcript show: className , '<' , category , ' ']! fileOutHeaderOn: aStream aStream nextPut: $!!; nextPutAll: className; nextPutAll: ' methodsFor: '; store: category asString; nextPut: $!!; cr; cr! fileOutOn: aStream self fileOutHeaderOn: aStream. aStream nextChunkPut: self text; space; nextPut: $!!; cr; cr! fileOutOn: aStream previous: previousChange next: nextChange ((previousChange isKindOf: MethodDefinitionChange) and: [previousChange className == className and: [previousChange category == category]]) ifFalse: [self fileOutHeaderOn: aStream]. aStream nextChunkPut: self text. ((nextChange isKindOf: MethodDefinitionChange) and: [nextChange className == className and: [nextChange category == category]]) ifFalse: [aStream space; nextPut: $!!]. aStream cr; cr! ! Object subclass: #MethodDescription instanceVariableNames: 'status whichClass selector ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! MethodDescription comment: 'Class MethodDescription models the result of looking up a selector name. Usually the class simply identifies an existing method in some class in the system. However, the lookup may fail, in which case it knows the message would not be understood. Also, in multiple inheritance situations, the lookup may yield conflicting results, in which case it will know that as well. Instance Variables: status indicating whether the method is implemented or not and whether their are conflicting methods whichClass selector '! !MethodDescription methodsFor: 'accessing'! method ^whichClass compiledMethodAt: selector! selector ^selector! sourceCode ^whichClass sourceCodeAt: selector! whichClass ^whichClass! ! !MethodDescription methodsFor: 'comparing'! = descr "Answer whether the receiver and the argument represent the same object." self isConflictingMethods ifTrue: [^descr isConflictingMethods]. self isMethodNotImplemented ifTrue: [^descr isMethodNotImplemented]. ^(whichClass == descr whichClass) & (selector == descr selector)! ! !MethodDescription methodsFor: 'testing'! isBad ^status == #conflictingMethods or: [status == #methodNotImplemented]! isConflictingMethods ^status == #conflictingMethods! isMethodNotImplemented ^status == #methodNotImplemented! ! !MethodDescription methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." status==#methodNotImplemented ifTrue: [aStream nextPutAll: 'MethodDescription(methodNotImplemented)'. ^self]. status==#conflictingMethods ifTrue: [aStream nextPutAll: 'MethodDescription(conflictingMethods)'. ^self]. aStream nextPutAll: 'MethodDescription('; nextPutAll: whichClass name; nextPut: $, ; nextPutAll: selector; nextPut: $)! ! !MethodDescription methodsFor: 'private'! setStatus: aSymbol status _ aSymbol! setWhichClass: aClass setSelector: aSymbol whichClass _ aClass. selector _ aSymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodDescription class instanceVariableNames: ''! !MethodDescription class methodsFor: 'instance creation'! makeConflictingMethods ^self new setStatus: #conflictingMethods! makeMethodNotImplemented ^self new setStatus: #methodNotImplemented! whichClass: c selector: s ^self new setWhichClass: c setSelector: s! ! IdentityDictionary variableSubclass: #MethodDictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Support'! MethodDictionary comment: 'MethodDictionaries behave just the same as IdentityDictionaries, except that removal is implemented as an atomic operation. This allows the interpreter to access methodDictionaries removal without getting confused. Instance Variables: *indexed*'! !MethodDictionary methodsFor: 'dictionary removing'! methodArray ^valueArray! removeKey: key ifAbsent: errorBlock "Remove the key from a copy and then use become: to effect and atomic update." self become: (self copy removeDangerouslyKey: key ifAbsent: [^errorBlock value])! ! Browser subclass: #MethodListBrowser instanceVariableNames: 'methodList methodName ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Browser'! MethodListBrowser comment: 'I represent a list of methods to be browsed.'! !MethodListBrowser methodsFor: 'initialization'! on: aList methodList _ aList! ! !MethodListBrowser methodsFor: 'method list'! methodList ^ methodList! methodMenu selector == nil ifTrue: [^ nil]. ^ super selectorMenu! methodName ^ methodName! methodName: selection | aStream aSymbol | methodName _ selection. selection == nil ifTrue: [selector _ nil. ^ self textMode: #unclassified]. aStream _ ReadStream on: selection. className _ (aStream upTo: $ ) asSymbol. aSymbol _ (aStream upTo: $ ) asSymbol. (meta _ (aSymbol == #class) & aStream atEnd not) ifTrue: [aSymbol _ (aStream upTo: $ ) asSymbol]. protocol _ self selectedClass organization categoryOfElement: aSymbol. self selector: aSymbol! ! !MethodListBrowser methodsFor: 'method functions'! removeMethod (super removeMethod) ifTrue: [methodList _ methodList copyWithout: methodName. self changed: #methodName]! ! !MethodListBrowser methodsFor: 'menu messages'! spawnEdits: aText from: aController "Open a method browser with aController for the code controller." | newController | selector == 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]! ! !MethodListBrowser methodsFor: 'doIt/accept/explain'! acceptText: aText from: aController textMode == #unclassified ifTrue: [self notify: 'A method must be selected to suggest class and protocol'. ^ false]. ^ super acceptText: aText from: aController! ! ParseNode subclass: #MethodNode instanceVariableNames: 'selectorOrFalse precedence arguments block literals primitive encoder temporaries ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! MethodNode comment: 'I am the root of the parse tree.'! !MethodNode methodsFor: 'initialize-release'! selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim encoder _ anEncoder. selectorOrFalse _ selOrFalse. precedence _ p. arguments _ args. temporaries _ temps. block _ blk. primitive _ prim! ! !MethodNode methodsFor: 'code generation'! generate ^self generateAt: RemoteString empty! generateAt: aRemoteString "I am the root of a parse tree; answer with an instance of CompiledMethod." | blkSize method nLits stack strm nArgs primn | self generateIfQuick: [:meth | meth setSourcePosition: aRemoteString. meth cacheTempNames: self tempNames. ^meth]. nArgs _ arguments size. blkSize _ block sizeForEvaluatedValue: encoder. primn _ (primitive < 256) & (primitive > -256) ifTrue: [primitive] ifFalse: [0]. literals _ encoder literals: primn nArgs: nArgs. encoder maxTemp > 31 ifTrue: [^self error: 'Too many temporary variables']. (nLits _ literals size) > 255 ifTrue: [^self error: 'Too many literals referenced']. method _ CompiledMethod "Dummy to allocate right size" newBytes: blkSize + CompiledMethod bytesForSource flags: ((nArgs <= 4 and: [primn = 0]) ifTrue: [nArgs] ifFalse: [7]) nTemps: encoder maxTemp nStack: 0 nLits: nLits. strm _ ReadWriteStream with: method. strm position: method initialPC - 1. stack _ ParseStack new init. block emitForEvaluatedValue: stack on: strm. stack position ~= 1 ifTrue: [^self error: 'Compiler stack discrepancy']. strm position ~= (method size - CompiledMethod bytesForSource) ifTrue: [^self error: 'Compiler code size discrepancy']. 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. method needsStack: stack size encoder: encoder. method setSourcePosition: aRemoteString.. method cacheTempNames: self tempNames. ^method! generateIfQuick: methodBlock | v | (primitive = 0 and: [arguments size = 0 and: [block isQuick]]) ifTrue: [v _ block code. v < 0 ifTrue: [^self]. v = LdSelf ifTrue: [^methodBlock value: (CompiledMethod toReturnSelf)]. v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType)) ifTrue: [^methodBlock value: (CompiledMethod toReturnField: v)]. (v // 256 = 1 and: [v \\ 256 < 32]) ifTrue: [^methodBlock value: (CompiledMethod toReturnField: v \\ 256)]]! generateNoQuick "Assumes would have been quick. Forces numArgs > 0 so will compile real code. The debugger needs this to look simulate a quick return" arguments _ Array new: 1. ^ self generate! selector (selectorOrFalse isMemberOf: Symbol) ifTrue: [^selectorOrFalse]. ^selectorOrFalse key! sourceMap "I am the root of a parse tree; answer with a sorted collection of associations of the form: pc (byte offset in me) -> sourceRange (an Interval) in source text. Because the number of my literals may grow during generation and therefore the pc's may be off, I must pass my generated number of literals to the encoder." | numLits | numLits _ self generate numLiterals. ^encoder sourceMap: numLits! ! !MethodNode methodsFor: 'converting'! decompileString | aStream | aStream _ WriteStream on: (String new: 1000). self printOn: aStream. ^aStream contents! ! !MethodNode methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." | args | precedence = 1 ifTrue: [aStream nextPutAll: self selector] ifFalse: [args _ ReadStream on: arguments. self selector keywords do: [:s | aStream nextPutAll: s. aStream space; nextPutAll: args next key. aStream space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1. aStream cr]. temporaries size > 0 ifTrue: [aStream crtab: 1. aStream nextPutAll: '| '. temporaries do: [:s | aStream nextPutAll: s key. aStream space]. aStream nextPut: $|]. primitive == 0 ifFalse: [aStream crtab: 1. aStream nextPutAll: '']. aStream crtab: 1. ^block printStatementsOn: aStream indent: 1! tempNames ^encoder tempNames! ! MethodChange subclass: #MethodOtherChange instanceVariableNames: 'type ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! MethodOtherChange comment: 'Class MethodOtherChange represents a change to a method other than new definition or removal. Instance Variable: type '! !MethodOtherChange methodsFor: 'accessing'! name ^type, ' ', className, ' ', selector! type ^type! type: aSymbol type _ aSymbol! ! !MethodOtherChange methodsFor: 'checking'! checkWith: aChecker aChecker changesAt: self name add: self. aChecker addDoIt: self! ! Object subclass: #Model instanceVariableNames: 'dependents ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! Model comment: 'Class Model represents an object that may have dependents that must receive notification of any change to the object. Instance Variable: dependents nil or of Objects'! !Model methodsFor: 'copying'! copy "Answer another instance just like the receiver. Do not copy the dependents list." ^super copy breakDependents! ! !Model methodsFor: 'dependents access'! addDependent: anObject "Add anObject as one of the receiver's dependents." dependents == nil ifTrue: [dependents _ OrderedCollection new]. dependents add: anObject. ^anObject! dependents "Answer an OrderedCollection of the objects that are dependent on the receiver, that is, the objects that should be notified if the receiver changes." dependents == nil ifTrue: [^OrderedCollection new]. ^dependents! removeDependent: anObject "Remove the argument, anObject, as one of the receiver's dependents." dependents == nil ifTrue: [^anObject]. dependents remove: anObject ifAbsent: []. dependents isEmpty ifTrue: [self breakDependents]. ^anObject! ! !Model methodsFor: 'changing'! changed: anAspectSymbol with: 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, and aParameter is additional information. Inform all of the dependents." dependents == nil ifFalse: [dependents do: [:aDependent | aDependent update: anAspectSymbol with: aParameter from: self]]! changeRequest "Receiver wants to change; check with all dependents that it is OK." dependents == nil ifFalse: [dependents do: [:aDependent | aDependent updateRequest ifFalse: [^false]]]. ^true! changeRequest: anAspectSymbol "Receiver wants to change this aspect; check with all dependents that it is OK." dependents == nil ifFalse: [dependents do: [:aDependent | (aDependent updateRequest: anAspectSymbol) ifFalse: [^false]]]. ^true! changeRequestFrom: aRequestorObject "Receiver wants to change; check with all dependents (other than aRequestor) that it is OK." dependents == nil ifFalse: [dependents do: [:aDependent | (aDependent == aRequestorObject or: [aDependent updateRequest]) ifFalse: [^false]]]. ^true! ! !Model methodsFor: 'updating'! broadcast: aSymbol "Send the argument, aSymbol, as a unary message to all of the receiver's dependents." dependents == nil ifFalse: [dependents do: [:aDependent | aDependent perform: aSymbol]]! broadcast: aSymbol with: anObject "Send the argument, aSymbol, as a keyword message with argument anObject to all of the receiver's dependents." dependents == nil ifFalse: [dependents do: [:aDependent | aDependent perform: aSymbol with: anObject]]! ! !Model methodsFor: 'private'! breakDependents "Deallocate the receiver's dependents." dependents _ nil! setDependents: aCollection "Replace the dependents list of the receiver with an OrdredCollection of elements from aCollection." aCollection isEmpty ifTrue: [dependents _ nil] ifFalse: [dependents _ OrderedCollection new. aCollection do: [:anObject | dependents add: anObject]]! ! Controller subclass: #MouseMenuController instanceVariableNames: 'redButtonMenu redButtonMessages yellowButtonMenu yellowButtonMessages blueButtonMenu blueButtonMessages ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Support'! MouseMenuController comment: 'A MouseMenuController is a Controller that modifies the scheduling of user activities so that the three mouse buttons can be used to make selections or display menus. The menu items are unary messages to the value of sending an instance of class MouseMenuController the message menuMessageReceiver. Instance Variables: redButtonMenu redButtonMessages of Symbols, unary messages yellowButtonMenu yellowButtonMessages of Symbols, unary messages blueButtonMenu blueButtonMessages of Symbols, unary messages '! !MouseMenuController methodsFor: 'initialize-release'! release super release. redButtonMenu release. yellowButtonMenu release. blueButtonMenu release! reset "Eliminate references to all mouse button menus." redButtonMenu _ nil. redButtonMessages _ nil. yellowButtonMenu _ nil. yellowButtonMessages _ nil. blueButtonMenu _ nil. blueButtonMessages _ nil! ! !MouseMenuController methodsFor: 'control defaults'! controlActivity sensor redButtonPressed & self viewHasCursor ifTrue: [^self redButtonActivity]. sensor yellowButtonPressed & self viewHasCursor ifTrue: [^self yellowButtonActivity]. sensor blueButtonPressed & self viewHasCursor ifTrue: [^self blueButtonActivity]. super controlActivity! isControlActive ^view containsPoint: sensor cursorPoint! ! !MouseMenuController methodsFor: 'menu setup'! blueButtonMenu: aSystemMenu blueButtonMessages: anArray "Initialize the pop-up menu that should appear when the user presses the blue mouse button to be aSystemMenu. The corresponding messages that should be sent are listed in the array, anArray." blueButtonMenu release. blueButtonMenu _ aSystemMenu. blueButtonMessages _ anArray! redButtonMenu: aSystemMenu redButtonMessages: anArray "Initialize the pop-up menu that should appear when the user presses the red mouse button to be aSystemMenu. The corresponding messages that should be sent are listed in the array, anArray." redButtonMenu release. redButtonMenu _ aSystemMenu. redButtonMessages _ anArray! yellowButtonMenu: aSystemMenu yellowButtonMessages: anArray "Initialize the pop-up menu that should appear when the user presses the yellow mouse button to be aSystemMenu. The corresponding messages that should be sent are listed in the array, anArray." yellowButtonMenu release. yellowButtonMenu _ aSystemMenu. yellowButtonMessages _ anArray! ! !MouseMenuController methodsFor: 'menu messages'! blueButtonActivity "Determine which item in the blue button pop-up menu is selected. If one is selected, then send the corresponding message to the object designated as the menu message receiver." | index | blueButtonMenu ~~ nil ifTrue: [index _ blueButtonMenu startUp. index ~= 0 ifTrue: [self menuMessageReceiver perform: (blueButtonMessages at: index)]] ifFalse: [super controlActivity]! menuMessageReceiver "Answer the object that should be sent a message when a menu item is selected." ^ self! redButtonActivity "Determine which item in the red button pop-up menu is selected. If one is selected, then send the corresponding message to the object designated as the menu message receiver." | index | redButtonMenu ~~ nil ifTrue: [index _ redButtonMenu startUp. index ~= 0 ifTrue: [self menuMessageReceiver perform: (redButtonMessages at: index)]] ifFalse: [super controlActivity]! yellowButtonActivity "Determine which item in the yellow button pop-up menu is selected. If one is selected, then send the corresponding message to the object designated as the menu message receiver." | index | yellowButtonMenu ~~ nil ifTrue: [index _ yellowButtonMenu startUp. index ~= 0 ifTrue: [self menuMessageReceiver perform: (yellowButtonMessages at: index)]] ifFalse: [super controlActivity]! ! Controller subclass: #NoController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Framework'! NoController comment: 'Class NoController represents a controller that never wants control. It is the controller for views that are non-interactive.'! !NoController methodsFor: 'basic control sequence'! startUp "I do nothing." ^self! ! !NoController methodsFor: 'control defaults'! isControlActive ^false! isControlWanted ^false! ! StandardSystemController subclass: #NotifierController instanceVariableNames: '' classVariableNames: 'NotifierYellowButtonMenu NotifierYellowButtonMessages ' poolDictionaries: '' category: 'Interface-Debugger'! NotifierController comment: 'I am a kind of MouseMenuController that creates a yellow button menu for proceeding an interrupted process or for creating and scheduling a debugger on the interrupted machine state. I give up control if a blue button is pressed or if the cursor is not inside the view.'! !NotifierController methodsFor: 'initialize-release'! initialize super initialize. self initializeYellowButtonMenu! ! !NotifierController methodsFor: 'menu messages'! correct "Attempt to correct the spelling of the not-understood message and resend." self controlTerminate. model correct: self. self controlInitialize! debug "Open a Debugger on the receiver's model." self controlTerminate. view erase. Debugger openFullViewOn: model label: view label. self closeAndUnscheduleNoErase. Processor terminateActive! proceed "Proceed execution of the receiver's model." self controlTerminate. model proceed. self controlInitialize! ! !NotifierController methodsFor: 'model access'! model: aDebugger "Intercept to possible enable spelling correction." super model: aDebugger. model interruptedContext selector == #doesNotUnderstand: ifTrue: [self yellowButtonMenu: (PopUpMenu labels: 'proceed debug correct' lines: #(2)) yellowButtonMessages: #(proceed debug correct)]! ! !NotifierController methodsFor: 'private'! initializeYellowButtonMenu self yellowButtonMenu: NotifierYellowButtonMenu yellowButtonMessages: NotifierYellowButtonMessages. self redButtonMenu: NotifierYellowButtonMenu redButtonMessages: NotifierYellowButtonMessages! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NotifierController class instanceVariableNames: ''! !NotifierController class methodsFor: 'class initialization'! initialize NotifierYellowButtonMenu _ PopUpMenu labels: 'proceed debug'. NotifierYellowButtonMessages _ #(proceed debug ) "NotifierController initialize."! ! NotifierController initialize! StandardSystemView subclass: #NotifierView instanceVariableNames: 'contents ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Debugger'! NotifierView comment: 'I am a view of interrupted machine state. The interruption occurred in order to notify the user that some action to be taken is dangerous, perhaps because it is not recoverable. I contain one subView in which the notification information is displayed. My default controller is NotifierController. Instance Variables: contents the notification information'! !NotifierView methodsFor: 'initialize-release'! initialize super initialize. self insideColor: Form white! ! !NotifierView methodsFor: 'accessing'! contents "Answer the information displayed in the receiver." ^contents! contents: aString "Set aString to be the information that is displayed in the receiver." contents _ aString asParagraph. self centerContents! ! !NotifierView methodsFor: 'controller access'! defaultControllerClass ^NotifierController! ! !NotifierView methodsFor: 'window access'! defaultWindow (contents == nil or: [self isCollapsed]) ifTrue: [^super defaultWindow] ifFalse: [^contents boundingBox expandBy: 6]! window: aWindow super window: aWindow. self centerContents! ! !NotifierView methodsFor: 'displaying'! displayView self isCollapsed ifFalse: [contents displayOn: Display transformation: self displayTransformation clippingBox: self insetDisplayBox fixedPoint: contents boundingBox center]. super displayView! ! !NotifierView methodsFor: 'private'! centerContents contents ~~ nil ifTrue: [contents align: contents boundingBox center with: self getWindow center]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NotifierView class instanceVariableNames: ''! !NotifierView class methodsFor: 'instance creation'! openContext: haltContext label: aString contents: contentsString "Create and schedule an instance of me viewing a Debugger on haltContext. The view will be labeled with aString, and shows a short sender stack." | displayPoint | ErrorRecursion ifTrue: [ErrorRecursion _ false. self primitiveError: aString]. ErrorRecursion _ true. displayPoint _ ScheduledControllers activeController == nil ifTrue: [Display boundingBox center] ifFalse: [ScheduledControllers activeController view displayBox center]. ScrollController haltScrollBar. ScheduledControllers saveActiveViewsBits. self openDebugger: (Debugger context: haltContext) contents: contentsString label: aString displayAt: displayPoint. ErrorRecursion _ false. Processor activeProcess suspend! openInterrupt: aString onProcess: interruptedProcess "Create and schedule an instance of me whose model is a Debugger on interruptedProcess. Sent to notify the user that the system is low in space or that the user typed ctrl c. The label of the scheduled view is aString." | debugger topView | debugger _ Debugger interruptProcess: interruptedProcess. topView _ self openDebugger: debugger contents: debugger interruptedContext shortStack label: aString displayAt: Display boundingBox center. ^topView! ! !NotifierView class methodsFor: 'private'! openDebugger: aDebugger contents: aString1 label: aString2 displayAt: aPoint | notifierView | Cursor normal show. Cursor cursorLink: true. notifierView _ self new model: aDebugger. notifierView contents: aString1. notifierView label: aString2. notifierView borderWidth: 2. notifierView minimumSize: notifierView defaultWindow width @ notifierView defaultWindow height. notifierView controller openNoTerminateDisplayAt: aPoint. ^notifierView! ! Magnitude subclass: #Number instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Numeric-Numbers'! Number comment: 'The abstract class Number is at the top of the number hierarchy. Its subclasses are Float, Fraction, and Integer. Subclasses must implement methods for arithmetic messages * + - / coercing messages coerce: generality'! !Number methodsFor: 'arithmetic'! * aNumber "Answer the result of multiplying the receiver by the argument, aNumber." self subclassResponsibility! + aNumber "Answer the sum of the receiver and the argument, aNumber." self subclassResponsibility! - aNumber "Answer the difference between the receiver and aNumber." self subclassResponsibility! / aNumber "Answer the result of dividing receiver by aNumber." self subclassResponsibility! // aNumber "Integer quotient defined by division with truncation toward negative infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder from this division." ^(self / aNumber) floor! abs "Answer a Number that is the absolute value (positive magnitude) of the receiver." self < 0 ifTrue: [^self negated] ifFalse: [^self]! negated "Answer a Number that is the negation of the receiver." ^0 - self! quo: aNumber "Integer quotient defined by division with truncation toward zero. -9 quo: 4 = -2, -0.9 quo: 0.4 = -2. rem: answers the remainder from this division." ^(self / aNumber) truncated! reciprocal "Answer 1 divided by the receiver. Provide an error notification if the receiver is 0." self = 0 ifTrue: [^self error: 'zero has no reciprocal'] ifFalse: [^1 / self]! rem: aNumber "Remainder defined in terms of quo:. Answer a Number with the same sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1" ^self - ((self quo: aNumber) * aNumber)! sqrtTruncated "Answer the receivers square root truncated to an integer." ^self sqrt truncated! \\ aNumber "modulo. Remainder defined in terms of //. Answer a Number with the same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1" ^self - (self // aNumber * aNumber)! ! !Number methodsFor: 'mathematical functions'! arcCos "Answer the angle in radians." ^self asFloat arcCos! arcSin "Answer the angle in radians." ^self asFloat arcSin! arcTan "Answer the angle in radians." ^self asFloat arcTan! cos "Answer the angle in radians." ^self asFloat cos! exp "Answer the exponential of the receiver as a floating point number." ^self asFloat exp! floorLog: radix "Answer the floor of the log base radix of the receiver." ^self asFloat floorLog: radix! ln "Answer the natural log of the receiver." ^self asFloat ln! log: aNumber "Answer the log base aNumber of the receiver." ^self ln / aNumber ln! raisedTo: aNumber "Answer the receiver raised to the power of the argument, aNumber." aNumber isInteger ifTrue: ["Do the special case of integer power" ^self raisedToInteger: aNumber]. aNumber = 0 ifTrue: [^1]. "Special case of exponent=0" aNumber = 1 ifTrue: [^self]. "Special case of exponent=1" ^(aNumber * self ln) exp "Otherwise raise it to the power using logarithms"! raisedToInteger: anInteger "Answer the receiver raised to the power anInteger where the argument must be a kind of Integer. This is a special case of raisedTo:." |count tmp int| anInteger isInteger ifFalse: [^self error: 'raisedToInteger: only works for integral arguments']. anInteger = 0 ifTrue: [^1]. anInteger = 1 ifTrue: [^self]. count _ 1. tmp _ self. anInteger > 1 ifTrue: [[(count _ count + 1) <= anInteger] whileTrue: [tmp _ tmp * self]. ^tmp]. int _ anInteger negated. [(count _ count + 1) <= int] whileTrue: [tmp _ tmp * self]. ^1.0 / tmp asFloat! sin "Answer the angle in radians." ^self asFloat sin! sqrt "Answer the square root of the receiver." ^self asFloat sqrt! squared "Answer the receiver multiplied by itself." ^self * self! tan "Answer the ratio of the sine to cosine of the receiver in radians." ^self asFloat tan! ! !Number methodsFor: 'testing'! even "Answer whether the receiver is an even number." ^self \\ 2 = 0! negative "Answer whether the receiver is less than 0." ^self < 0! odd "Answer whether the receiver is an odd number." ^self even == false! positive "Answer whether the receiver is greater than or equal to 0." ^self >= 0! sign "Answer 1 if the receiver is greater than 0, answer -1 if less than 0, else answer 0." self > 0 ifTrue: [^1]. self < 0 ifTrue: [^-1]. ^0! strictlyPositive "Answer whether the receiver is greater than 0." ^self > 0! ! !Number methodsFor: 'truncation and round off'! ceiling "Answer the integer nearest the receiver toward positive infinity." self <= 0.0 ifTrue: [^self truncated] ifFalse: [^self negated floor negated]! floor "Answer the integer nearest the receiver toward negative infinity." | truncation | truncation _ self truncated. self >= 0 ifTrue: [^truncation]. self = truncation ifTrue: [^truncation] ifFalse: [^truncation - 1]! rounded "Answer the integer nearest the receiver." ^(self + (self sign / 2)) truncated! roundTo: aNumber "Answer the integer that is a multiple of the argument, aNumber, that is nearest the receiver." ^(self / aNumber) rounded * aNumber! truncated "Answer an integer nearest the receiver toward zero." ^self quo: 1! truncateTo: aNumber "Answer the next multiple of the argument, aNumber, that is nearest the receiver toward zero." ^(self quo: aNumber) * aNumber! ! !Number methodsFor: 'coercing'! coerce: aNumber "Answer a number representing the argument, aNumber, that is the same kind of Number as the receiver. Must be defined by all Number classes." self subclassResponsibility! generality "Answer the number representing the ordering of the receiver in the generality hierarchy. A number in this hierarchy coerces to numbers higher in hierarchy (i.e., with larger generality numbers)." self subclassResponsibility! retry: aSymbol coercing: aNumber "Arithmetic represented by the symbol, aSymbol, could not be performed with the receiver and the argument, aNumber, because of the differences in representation. Coerce either the receiver or the argument, depending on which has higher generality, and try again. If the symbol is the equals sign, answer false if the argument is not a Number. If the generalities are the same, then this message should not have been sent so an error notification is provided." (aSymbol == #= and: [(aNumber isKindOf: Number) == false]) ifTrue: [^false]. self generality < aNumber generality ifTrue: [^(aNumber coerce: self) perform: aSymbol with: aNumber]. self generality > aNumber generality ifTrue: [^self perform: aSymbol with: (self coerce: aNumber)]. self error: 'coercion attempt failed'! ! !Number methodsFor: 'converting'! @ y "Answer a new Point whose x value is the receiver and whose y value is the argument. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^Point x: self y: y! asInteger "Answer an Integer nearest the receiver toward zero." ^self truncated! asPoint "Answer a new Point with the receiver as both coordinates; often used to supply the same value in two dimensions, as with symmetrical gridding or scaling." ^self @ self! degreesToRadians "Answer the conversion to radians. The receiver is assumed to represent degrees." ^self asFloat degreesToRadians! radiansToDegrees "Answer the conversion to degrees. The receiver is assumed to represent radians." ^self asFloat radiansToDegrees! ! !Number methodsFor: 'intervals'! to: stop "Answer an Interval from the receiver up to the argument, stop, with each next element computed by incrementing the previous one by 1." ^Interval from: self to: stop by: 1! to: stop by: step "Answer an Interval from the receiver up to the argument, stop, with each next element computed by incrementing the previous one by step." ^Interval from: self to: stop by: step! to: stop by: step do: aBlock "For each number in the interval from the receiver up to the argument, stop, incrementing by step, evaluate the block, aBlock." | nextValue | nextValue _ self. step < 0 ifTrue: [[stop <= nextValue] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + step]] ifFalse: [[stop >= nextValue] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + step]]! to: stop do: aBlock "For each number in the interval from the receiver up to the argument, stop, incrementing by 1, evaluate the block, aBlock." | nextValue | nextValue _ self. [nextValue <= stop] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + 1]! ! !Number methodsFor: 'printing'! storeOn: aStream "Print the receiver on the stream, aStream. Numbers print in a form recognized by the compiler." self printOn: aStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Number class instanceVariableNames: ''! !Number class methodsFor: 'instance creation'! readFrom: aStream "Answer an instance of me as described on the stream, aStream" | value radix fraction fracpos numberIsNegative | radix _ 10. numberIsNegative _ aStream peekFor: $-. value _ Integer readFrom: aStream. (aStream peekFor: $r) ifTrue: ["r" (radix _ value) < 2 ifTrue: [^self error: 'Invalid Radix']. numberIsNegative _ aStream peekFor: $-. value _ Integer readFrom: aStream radix: radix]. (aStream peekFor: $.) ifTrue: ["." (aStream atEnd not and: [aStream peek digitValue between: 0 and: radix - 1]) ifTrue: [fracpos _ aStream position. fraction _ Integer readFrom: aStream radix: radix. radix _ radix asFloat. fraction _ fraction asFloat / (radix raisedTo: aStream position - fracpos). value _ value asFloat + fraction] ifFalse: ["oops - just ." aStream skip: -1. value _ numberIsNegative ifTrue: [value negated] ifFalse: [value]. ^value "un-gobble the period" "Number readFrom: (ReadStream on: '3r-22.2')."]]. value _ numberIsNegative ifTrue: [value negated] ifFalse: [value]. (aStream peekFor: $e) ifTrue: ["e" ^value * (radix raisedTo: (Integer readFrom: aStream))]. ^value! ! nil subclass: #Object instanceVariableNames: '' classVariableNames: 'DependentsFields ErrorRecursion ' poolDictionaries: '' category: 'Kernel-Objects'! Object comment: 'Object is the superclass of all classes. It thus provides default behavior common to all objects, such as class access, copying and printing. Class Variables: DependentsFields of associations, where each association pair is an object and an ordered collection of objects that depend on that object ErrorRecursion flags whether error notification is recursively infinite'! !Object methodsFor: 'initialize-release'! release "Remove references to objects that may refer to the receiver. Answers self. This message should be overidden by subclasses with any cycles, in which case the subclass should also include the expression super release." self breakDependents! ! !Object methodsFor: 'accessing'! at: index "Answer the value of an indexable field in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See documentation in Object metaclass." index isInteger ifTrue: [self errorSubscriptBounds: index]. (index isKindOf: Number) ifTrue: [^self at: index truncated] ifFalse: [self errorNonIntegerIndex]! at: index put: value "Store the argument value in the indexable field of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. See documentation in Object metaclass." index isInteger ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. (index isKindOf: Number) ifTrue: [^self at: index truncated put: value] ifFalse: [self errorNonIntegerIndex]! basicAt: index "Answer the value of an indexable field in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See documentation in Object metaclass. Do not override this message in any subclass." (index isKindOf: Integer) ifTrue: [self errorSubscriptBounds: index]. (index isKindOf: Number) ifTrue: [^self basicAt: index truncated] ifFalse: [self errorNonIntegerIndex]! basicAt: index put: value "Store the second argument value in the indexable field of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. See documentation in Object metaclass. Do not override in a subclass." (index isKindOf: Integer) ifTrue: [(index >= 1 and: [index <= self basicSize]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. (index isKindOf: Number) ifTrue: [^self basicAt: index truncated put: value] ifFalse: [self errorNonIntegerIndex]! basicSize "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See documentation in Object metaclass. Do not override in any subclass." "The number of indexable fields of fixed-length objects is 0" ^0! readFromString: aString "Create an object based on the contents of aString." ^self readFrom: (ReadStream on: aString)! size "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See documentation in Object metaclass. " "The number of indexable fields of fixed-length objects is 0" ^0! yourself "Answer self."! ! !Object methodsFor: 'testing'! isInteger "Coerces Integers to true and everything else to false. Integer overrides with ^true" ^false! isNil "Coerces nil to true and everything else to false. UndefinedObject overrides with ^true" ^false! notNil "Coerces nil to false and everything else to true. UndefinedObject overrides with ^false" ^true! ! !Object methodsFor: 'comparing'! = anObject "Answer whether the receiver and the argument represent the same object. If = is redefined in any subclass, consider also redefining the message hash." ^self == anObject! == anObject "Answer true if the receiver and the argument are the same object (have the same object pointer) and false otherwise. Do not redefine the message == in any other class!! Essential. No Lookup. See documentation in Object metaclass." self primitiveFailed! hash "Answer with a SmallInteger unique to the receiver. Fail if the receiver is a SmallInteger. Essential. See documentation in Object metaclass." self primitiveFailed! identityHash "Answer a SmallInteger whose value reflects the identity, not the contents, of the receiver. Essential. See documentation in Object metaclass." self primitiveFailed! ~= anObject "Answer whether the receiver and the argument do not represent the same object." ^self = anObject == false! ~~ anObject "Answer true if the receiver and the argument are not the same object (have the same object pointer) and false otherwise." ^(self == anObject) not! ! !Object methodsFor: 'copying'! copy "Answer another instance just like the receiver. Subclasses typically override this method; they typically do not override shallowCopy" ^self shallowCopy! deepCopy "Answer a copy of the receiver with its own copy of each instance variable." | newObject class index | class _ self class. (class == Object) ifTrue: [^self]. class isVariable ifTrue: [index _ self basicSize. newObject _ class basicNew: index. [index > 0] whileTrue: [newObject basicAt: index put: (self basicAt: index) deepCopy. index _ index - 1]] ifFalse: [newObject _ class basicNew]. index _ class instSize. [index > 0] whileTrue: [newObject instVarAt: index put: (self instVarAt: index) deepCopy. index _ index - 1]. ^newObject! shallowCopy "Answer a copy of the receiver which shares the receiver's instance variables. " | class newObject index | class _ self class. "I don't understand why the following check is here. Object is not supposed to have any instances at all." class == Object ifTrue: [^self]. class isVariable ifTrue: [index _ self basicSize. newObject _ class basicNew: index. [index > 0] whileTrue: [newObject basicAt: index put: (self basicAt: index). index _ index - 1]] ifFalse: [newObject _ class basicNew]. index _ class instSize. [index > 0] whileTrue: [newObject instVarAt: index put: (self instVarAt: index). index _ index - 1]. ^newObject! ! !Object methodsFor: 'dependents access'! addDependent: anObject "Add anObject as one of the receiver's dependents." (DependentsFields at: self ifAbsent: [self setDependents]) add: anObject. ^anObject! dependents "Answer an OrderedCollection of the objects that are dependent on the receiver, that is, the objects that should be notified if the receiver changes." ^ DependentsFields at: self ifAbsent: [OrderedCollection new]! removeDependent: anObject "Remove the argument, anObject, as one of the receiver's dependents." | dependents | dependents _ DependentsFields at: self ifAbsent: [^ anObject]. dependents remove: anObject ifAbsent: []. dependents isEmpty ifTrue: [self breakDependents]. ^anObject! ! !Object methodsFor: 'updating'! broadcast: aSymbol "Send the argument, aSymbol, as a unary message to all of the receiver's dependents." self dependents == nil ifFalse: [self dependents do: [:aDependent | aDependent perform: aSymbol]]! broadcast: aSymbol with: anObject "Send the argument, aSymbol, as a keyword message with argument anObject to all of the receiver's dependents." self dependents == nil ifFalse: [self dependents do: [:aDependent | aDependent perform: aSymbol with: anObject]]! update: anAspectSymbol "Receive a change notice from an object of whom the receiver is a dependent. The argument anAspectSymbol is typically a Symbol that indicates what change has occurred. The default behavior is to do nothing; a subclass might want to change itself in some way." ^self! update: anAspectSymbol with: aParameter "Receive a change notice from an object of whom the receiver is a dependent. The argument anAspectSymbol is typically a Symbol that indicates what change has occurred and aParameter is additional information. The default behavior is to do nothing; a subclass might want to change itself in some way." ^self update: anAspectSymbol "Note that in this implementation, assumption is that the object does not respond to this protocol but an attempt should be made to try a simpler message."! update: anAspectSymbol with: aParameter from: aSender "Receive a change notice from an object, denoted by aSender, of whom the receiver is a dependent. The argument anAspectSymbol is typically a Symbol that indicates what change has occurred and aParameter is additional information. The default behavior is to do nothing; a subclass might want to change itself in some way." ^self update: anAspectSymbol with: aParameter "Note that in this implementation, assumption is that the object does not respond to this protocol but an attempt should be made to try a simpler message."! updateRequest "Default behavior is to grant update requests; a subclass might want to override this behavior if it is in the middle of making another change." ^ true! updateRequest: anAspectSymbol "Default behavior is to grant update requests; a subclass might want to override this behavior if it is in the middle of making another change." ^self updateRequest! ! !Object methodsFor: 'printing'! isLiteral "Answer whether the receiver has a literal text form recognized by the compiler." ^false! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." | title | title _ self class name. aStream nextPutAll: ((title at: 1) isVowel ifTrue: ['an '] ifFalse: ['a ']) , title! printString "Answer a String whose characters are a description of the receiver." | aStream | aStream _ WriteStream on: (String new: 16). self printOn: aStream. ^aStream contents! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver. The general format for objects is (class-name basicNew instVarAt: index put: variable; basicAt: index put: element; yourself) or ((class-name basicNew: size ) instVarAt: index put: variable; basicAt: index put: element; yourself) " aStream nextPut: $(. self class isVariable ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: '; store: self basicSize; nextPutAll: ') '] ifFalse: [aStream nextPutAll: self class name, ' basicNew']. 1 to: self class instSize do: [:i | aStream nextPutAll: ' instVarAt: '; store: i; nextPutAll: ' put: '; store: (self instVarAt: i); nextPut: $;]. 1 to: self basicSize do: [:i | aStream nextPutAll: ' basicAt: '; store: i; nextPutAll: ' put: '; store: (self basicAt: i); nextPut: $;]. aStream nextPutAll: ' yourself)'! storeString "Answer a String representation of the receiver from which the receiver can be reconstructed." | aStream | aStream _ WriteStream on: (String new: 16). self storeOn: aStream. ^aStream contents! ! !Object methodsFor: 'class membership'! class "Answer the object which is the receiver's class. Essential. See documentation in Object metaclass." self primitiveFailed! isKindOf: aClass "Answer a Boolean as to whether the class, aClass, is a superclass or class of the receiver." self class == aClass ifTrue: [^true] ifFalse: [^self class inheritsFrom: aClass]! isMemberOf: aClass "Answer a Boolean as to whether the receiver is an instance of the class, aClass." ^self class == aClass! respondsTo: aSymbol "Answer a Boolean as to whether the method dictionary of the receiver's class contains aSymbol as a message selector." ^self class canUnderstand: aSymbol! ! !Object methodsFor: 'message handling'! perform: aSymbol "Send the receiver the unary message indicated by the argument. The argument is the selector of the message. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not zero. Optional. See documentation in Object metaclass." ^self perform: aSymbol withArguments: (Array new: 0)! perform: aSymbol with: anObject "Send the receiver the keyword message indicated by the arguments. The first argument is the selector of the message. The other argument is the argument of the message to be sent. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not one. Optional. See documentation in Object metaclass." ^self perform: aSymbol withArguments: (Array with: anObject)! perform: aSymbol with: firstObject with: secondObject "Send the receiver the keyword message indicated by the arguments. The first argument is the selector of the message. The other arguments are the arguments of the message to be sent. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not two. Optional. See documentation in Object metaclass." ^self perform: aSymbol withArguments: (Array with: firstObject with: secondObject)! perform: aSymbol with: firstObject with: secondObject with: thirdObject "Send the receiver the keyword message indicated by the arguments. The first argument is the selector of the message. The other arguments are the arguments of the message to be sent. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not three. Optional. See documentation in Object metaclass." ^self perform: aSymbol withArguments: (Array with: firstObject with: secondObject with: thirdObject)! perform: selector withArguments: anArray "Send the receiver the keyword message indicated by the arguments. The argument selector is the selector of the message. The arguments of the message are the elements of anArray. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not the same as the length of anArray. Essential. See documentation in Object metaclass." self primitiveFailed! ! !Object methodsFor: 'error handling'! confirm: aString "Create and start up a BinaryChoice menu with the argument as the message in order to determine true or false. Answers true or false." | answer | answer _ false. BinaryChoice message: aString displayAt: Sensor cursorPoint centered: true ifTrue: [answer _ true] ifFalse: [answer _ false]. ^answer! conflictingInheritanceError "Browse to the method which called this, redefine it appropriately, and then restart that calling method. " self error: 'Conflicting methods due to multiple inheritance'! doesNotUnderstand: aMessage "First check for a compound selector. If found, try copying down code into the receiver's class. If this is unsuccessful, announce that the receiver does not understand the argument, aMessage, as a message. The default behavior is to create a Notifier containing the appropriate message and to allow the user to open a Debugger. Subclasses can override this message in order to modify this behavior." | status gripe | status _ self class tryCopyingCodeFor: aMessage selector. status==#OK ifTrue: [^self perform: aMessage selector withArguments: aMessage arguments]. gripe _ status==#HierarchyViolation ifTrue: [aMessage selector classPart , ' is not one of my superclasses: '] ifFalse: ['Message not understood: ']. NotifierView openContext: thisContext label: gripe , aMessage selector contents: thisContext shortStack. "Try the message again if the programmer decides to proceed." ^self perform: aMessage selector withArguments: aMessage arguments "3 zork."! error: aString "The default behavior for error: is the same as halt:. This additional message is the one a subclass should override in order to change the handling of errors." NotifierView openContext: thisContext label: aString contents: thisContext shortStack "nil error: 'error message'."! halt "This is a simple message to use for inserting breakpoints during debugging." NotifierView openContext: thisContext label: 'Halt encountered.' contents: thisContext shortStack "nil halt."! halt: aString "This message can be used for inserting breakpoints during debugging. It creates and schedules a Debugger with the argument, aString, as the label." NotifierView openContext: thisContext label: aString contents: thisContext shortStack "nil halt: 'Test of halt:.'."! notify: aString "Create and schedule a Notifier with the argument as the message in order to request confirmation before a process can proceed." NotifierView openContext: thisContext label: 'Notifier' contents: aString "nil notify: 'confirmation message'."! primitiveFailed "Announce that a primitive has failed and there is no appropriate Smalltalk code to run." self error: 'a primitive has failed'! shouldNotImplement "Announce that although the receiver inherits this message, it should not implement it." self error: 'This message is not appropriate for this object'! subclassResponsibility "This message sets up a framework for the behavior of the class' subclasses. Announce that the subclass should have implemented this message." self error: 'My subclass should have overridden one of my messages.'! ! !Object methodsFor: 'changing'! changed "Receiver changed in a general way; inform all the dependents by sending each dependent an update: message." self changed: nil! changed: anAspectSymbol "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 changed: anAspectSymbol with: nil! changed: anAspectSymbol with: 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, and aParameter is additional information. Inform all of the dependents." self dependents do: [:aDependent | aDependent update: anAspectSymbol with: aParameter from: self]! changeRequest "Receiver wants to change; check with all dependents that it is OK." self dependents do: [:aDependent | aDependent updateRequest ifFalse: [^false]]. ^true! changeRequest: anAspectSymbol "Receiver wants to change this aspect; check with all dependents that it is OK." self dependents do: [:aDependent | (aDependent updateRequest: anAspectSymbol) ifFalse: [^false]]. ^true! changeRequestFrom: aRequestorObject "Receiver wants to change; check with all dependents (other than requestor) that it is OK." self dependents do: [:aDependent | (aDependent == aRequestorObject or: [aDependent updateRequest]) ifFalse: [^false]]. ^true! ! !Object methodsFor: 'user interface'! basicInspect "Create and schedule an Inspector in which the user can examine the receiver's variables. This method should not be overwritten." InspectorView open: (Inspector inspect: self)! browse "like inspect, all objects can be sent the message browse." Browser newOnClass: self class! inspect "Create and schedule an Inspector in which the user can examine the receiver's variables." self basicInspect! ! !Object methodsFor: 'system primitives'! asOop "Answer an Integer which is unique to me. See below. Essential. See also documentation in Object metaclass." self primitiveFailed " Non-Stretch mapping between objects and asOop value: oops 0...16K-1 --> 0...16K-1 oops 16K...32K-1 --> -16K...-1 SmallIntegers 0...16K --> 32K...48K-1 SmallIntegers -16K...0 --> 48K...64K-1 Stretch mapping between objects and asOop value: oops 0...48K-1 --> 0...48K-1 SmallIntegers -8K...-1 --> -16K...-2 even SmallIntegers 0...8K-1 --> -(16K-1)...-1 odd Non-Stretch Consistency check: | obj | -16384 to: 16383 do: [:i | obj _ i asObject. (obj == #NonExistentObject or: [obj asOop = i]) ifFalse: [self error: 'inconsistency']]. 32768 to: 65536 do: [:i | obj _ i asObject. (obj == #NonExistentObject or: [obj asOop = i]) ifFalse: [self error: 'inconsistency']]. Stretch Consistency check: | obj | -16384 to: 49151 do: [:i | obj _ i asObject. (obj == #NonExistentObject or: [obj asOop = i]) ifFalse: [self error: 'inconsistency']]. "! become: otherObject "Swap the instance pointers of the receiver and the argument, otherObject. All variables in the entire system that used to point to the receiver now point to the argument, and vice-versa. Fail if either object is a SmallInteger. Answer with the argument which is now the same instance pointer that formerly denoted the receiver. Essential. See documentation in Object metaclass." self primitiveFailed! firstOwner "Answer some object which points at self. This primitive can be used with 'ownerAfter: ' to enumerate all the objects which point at self. For example see SystemDictionary>quickPointersTo:do:. Optional. See also documentation in Object metaclass." ^nil! instVarAt: index "Answer with a fixed variable in an object. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Essential. See documentation in Object metaclass." "Access beyond fixed variables." ^self basicAt: index - self class instSize! instVarAt: anInteger put: anObject "Store a value into a fixed variable in the receiver. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Answer with the value stored as the result. (Using this message violates the principle that each object has sovereign control over the storing of values into its instance variables.) Essential. See documentation in Object metaclass. " "Access beyond fixed fields" ^self basicAt: anInteger - self class instSize put: anObject! nextInstance "Answer with the next instance after the receiver in the enumeration of all instances of this class. Fail if all instances have been enumerated. Essential. See documentation in Object metaclass." ^nil! ownerAfter: anObject "Answer the next object after anObject which points at self (in some hidden ordering). This primitive can be used with 'firstOwner' to enumerate all the objects which point at self. For example see SystemDictionary>quickPointersTo:do:. Optional. See also documentation in Object metaclass. " ^nil! refCt "Answer my reference count." ^nil! ! !Object methodsFor: 'system simulation'! tryPrimitive0 "Warning!!!! This is not a real primitive. This method is a template that the Smalltalk simulator uses to execute primitives with no arguments. See ContextPart class initPrimitives and ContextPart doPrimitive:receiver:args:." ^#primitiveFail! tryPrimitive1: arg1 "Warning!!!! This is not a real primitive. This method is a template that the Smalltalk simulator uses execute primitives with one argument. See ContextPart class|initPrimitives and ContextPart|doPrimitive:receiver:args:." ^#primitiveFail! tryPrimitive2: arg1 with: arg2 "Warning!!!! This is not a real primitive. This method is a template that the Smalltalk simulator uses execute primitives with two arguments. See ContextPart class|initPrimitives and ContextPart|doPrimitive:receiver:args:." ^#primitiveFail! tryPrimitive3: arg1 with: arg2 with: arg3 "Warning!!!! This is not a real primitive. This method is a template that the Smalltalk simulator uses execute primitives with three arguments. See ContextPart class|initPrimitives and ContextPart|doPrimitive:receiver:args:." ^#primitiveFail! tryPrimitive4: arg1 with: arg2 with: arg3 with: arg4 "Warning!!!! This is not a real primitive. This method is a template that the Smalltalk simulator uses execute primitives with four arguments. See ContextPart class|initPrimitives and ContextPart|doPrimitive:receiver:args:." ^#primitiveFail! ! !Object methodsFor: 'private'! acquireOop: anOop | other ownersOfAnOop ownersOfOther j myOop c | other _ anOop asSafeObject. myOop _ self asOop. other asOop = anOop ifFalse: [c _ OrderedCollection new. 1000 timesRepeat: [ c add: String new ]. ^self acquireOop: anOop]. other class = CompiledMethod ifTrue: [ other who first compileAll. other _ nil. ^self acquireOop: anOop ]. self become: other. ownersOfAnOop _ self allOwners. ownersOfOther _ other allOwners. ownersOfOther removeAllSuchThat: [:i | ownersOfAnOop includes: i]. ownersOfAnOop do: [:i | j _ 0. [(j _ j + 1) <= i basicSize] whileTrue: [(i basicAt: j) asOop = myOop ifTrue: [i basicAt: j put: anOop asObject] ifFalse: [(i basicAt: j) asOop = anOop ifTrue: [i basicAt: j put: myOop asObject]]]. j _ 0. [(j _ j + 1) <= i class instSize] whileTrue: [(i instVarAt: j) asOop = myOop ifTrue: [i instVarAt: j put: anOop asObject] ifFalse: [(i instVarAt: j) asOop = anOop ifTrue: [i instVarAt: j put: myOop asObject]]]]. ownersOfOther do: [:i | j _ 0. [(j _ j + 1) <= i basicSize] whileTrue: [(i basicAt: j) asOop = anOop ifTrue: [i basicAt: j put: myOop asObject]]. j _ 0. [(j _ j + 1) <= i class instSize] whileTrue: [(i instVarAt: j) asOop = anOop ifTrue: [i instVarAt: j put: myOop asObject]]]. Set allInstancesDo: [ :i | i rehash]. Set allSubInstancesDo: [ :i | i rehash ].! allOwners | owners last | owners _ OrderedCollection with: (last _ self firstOwner). [ (last _ self ownerAfter: last) == nil ] whileFalse: [ owners add: last ]. ^owners! breakDependents "Deallocate the soft field for the receiver's dependents." DependentsFields removeKey: self ifAbsent: []! errorImproperStore "Create an error notification that an improper store was attempted." self error: 'Improper store into indexable object'! errorNonIntegerIndex "Create an error notification that an improper object was used as an index." self error: 'only integers should be used as indices'! errorSubscriptBounds: index "Create an error notification that an improper integer was used as an index." self error: 'subscript is out of bounds: ' , index printString! forkEmergencyEvaluatorAt: priority "Fork a process running a simple Smalltalk evaluator using as little of the system as possible. Used for desperate debugging. may be invoked by control-shift-C." | stream char | [Display white: (0@0 extent: 1024@36). 'EMERGENCY EVALUATOR (priority ', priority printString, ') -- type an expression terminated by ESC' displayAt: 50@0. Display reverse: (0@0 extent: 1024@36). stream _ WriteStream on: String new. [[Sensor keyboardPressed] whileFalse. (char _ Sensor keyboard) = Character esc] whileFalse: [char = Character backspace ifTrue: [stream skip: -1. Display black: (0@18 extent: 1024@18)] ifFalse: [stream nextPut: char]. stream contents displayAt: 50@18]. Display black: (0@0 extent: 1024@18). (Compiler evaluate: stream contents) printString displayAt: 50@0] forkAt: priority! mustBeBoolean "Catches attempts to test truth of non-Booleans. This message is sent from the interpreter." self error: 'NonBoolean receiver--proceed for truth.'. ^true! nilFields "Store nil into all pointer fields of the receiver." self class isPointers ifFalse: [^self]. 1 to: self basicSize do: [:index | self basicAt: index put: nil]. 1 to: self class instSize do: [:index | self instVarAt: index put: nil].! primitiveError: aString "This method is called when the error handling results in a recursion in calling on error: or halt or halt:." | context key | Transcript cr. Transcript show: '**System Error Handling Failed** '. Transcript show: aString. Transcript cr. context _ thisContext sender sender. 3 timesRepeat: [context == nil ifFalse: [Transcript print: (context _ context sender); cr]]. [Transcript show: '**type for more stack; anything else restarts scheduler**'. Transcript cr. key _ Sensor keyboard. key = $s | (key = $S)] whileTrue: [5 timesRepeat: [context == nil ifFalse: [Transcript print: (context _ context sender); cr]]]. ScheduledControllers searchForActiveController! setDependents "Allocate the soft field for the receiver's dependents." | dependents | dependents _ OrderedCollection new. DependentsFields add: (Association key: self value: dependents). ^ dependents! species "Answer the preferred class for reconstructing the receiver. For example, collections create new collections whenever enumeration messages such as collect: or select: are invoked. The new kind of collection is determined by the species of the original collection. Species and class are not always the same. For example, the species of Interval is Array." ^self class! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Object class instanceVariableNames: ''! !Object class methodsFor: 'class initialization'! initialize "Reset all the dependents of all objects." "Object initialize" (self confirm: 'Do you really want to initialize class Object? It will reset all dependents.') ifTrue: [self initializeDependentsFields. self initializeErrorRecursion]! ! !Object class methodsFor: 'instance creation'! readFrom: aStream "Create an object based on the contents of aStream." | object | object _ Compiler evaluate: aStream. (object isKindOf: self) ifFalse: [self error: self name, ' expected']. ^object! ! !Object class methodsFor: 'documentation'! howToModifyPrimitives "You are allowed to write methods which specify primitives, but please use caution. If you make a subclass of a class which contains a primitive method, the subclass inherits the primitive. The message which is implemented primitively may be overridden in the subclass (E.g., see at:put: in String's subclass Symbol). The primitive behavior can be invoked using super (see Symbol string:). A class which attempts to mimic the behavior of another class without being its subclass may or may not be able to use the primitives of the original class. In general, if the instance variables read or written by a primitive have the same meanings and are in the same fields in both classes, the primitive will work. For certain frequently used 'special selectors', the compiler emits a send-special-selector bytecode instead of a send-message bytecode. Special selectors were created because they offer two advantages. Code which sends special selectors compiles into fewer bytes than normal. For some pairs of receiver classes and special selectors, the interpreter jumps directly to a primitive routine without looking up the method in the class. This is much faster than a normal message lookup. A selector which is a special selector solely in order to save space has a normal behavior. Methods whose selectors are special in order to gain speed contain the comment, 'No Lookup'. When the interpreter encounters a send-special-selector bytecode, it checks the class of the receiver and the selector. If the class-selector pair is a no-lookup pair, then the interpreter swiftly jumps to the routine which implements the corresponding primitive. (A special selector whose receiver is not of the right class to make a no-lookup pair, is looked up normally). The pairs are listed below. No-lookup methods contain a primitive number specification, , which is redundant. Since the method is not normally looked up, deleting the primitive number specification cannot prevent this primitive from running. If a no-lookup primitive fails, the method is looked up normally, and the expressions in it are executed. No Lookup pairs of (class, selector) SmallInteger with any of + - * / \\ bitOr: bitShift: bitAnd: // SmallInteger with any of = ~= > < >= <= Any class with == Any class with @ Point with either of x y ContextPart with blockCopy: BlockContext with either of value value: " self error: 'comment only'! whatIsAPrimitive "Some messages in the system are responded to primitively. A primitive response is performed directly by the interpreter rather than by evaluating expressions in a method. The methods for these messages indicate the presence of a primitive response by including before the first expression in the method. Primitives exist for several reasons. Certain basic or 'primitive' operations cannot be performed in any other way. Smalltalk without primitives can move values from one variable to another, but cannot add two SmallIntegers together. Many methods for arithmetic and comparison between numbers are primitives. Some primitives allow Smalltalk to communicate with I/O devices such as the disk, the display, and the keyboard. Some primitives exist only to make the system run faster; each does the same thing as a certain Smalltalk method, and its implementation as a primitive is optional. When the Smalltalk interpreter begins to execute a method which specifies a primitive response, it tries to perform the primitive action and to return a result. If the routine in the interpreter for this primitive is successful, it will return a value and the expressions in the method will not be evaluated. If the primitive routine is not successful, the primitive 'fails', and the Smalltalk expressions in the method are executed instead. These expressions are evaluated as though the primitive routine had not been called. The Smalltalk code that is evaluated when a primitive fails usually anticipates why that primitive might fail. If the primitive is optional, the expressions in the method do exactly what the primitive would have done (See Number @). If the primitive only works on certain classes of arguments, the Smalltalk code tries to coerce the argument or appeals to a superclass to find a more general way of doing the operation (see SmallInteger +). If the primitive is never supposed to fail, the expressions signal an error (see SmallInteger asFloat). Each method that specifies a primitive has a comment in it. If the primitive is optional, the comment will say 'Optional'. An optional primitive that is not implemented always fails, and the Smalltalk expressions do the work instead. If a primitive is not optional, the comment will say, 'Essential'. Some methods will have the comment, 'No Lookup'. See Object howToModifyPrimitives for an explanation of special selectors which are not looked up. For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated in Float, the primitive constructs and returns a 16-bit LargePositiveInteger when the result warrants it. Returning 16-bit LargePositiveIntegers from these primitives instead of failing is optional in the same sense that the LargePositiveInteger arithmetic primitives are optional. The comments in the SmallInteger primitives say, 'Fails if result is not a SmallInteger', even though the implementor has the option to construct a LargePositiveInteger. For further information on primitives, see the 'Primitive Methods' part of the chapter on the formal specification of the interpreter in the Smalltalk book." self error: 'comment only'! ! !Object class methodsFor: 'private'! initializeDependentsFields DependentsFields _ IdentityDictionary new: 4 "Object initializeDependentsFields"! initializeErrorRecursion ErrorRecursion _ false "Object initializeErrorRecursion"! ! Object initialize! Switch subclass: #OneOnSwitch instanceVariableNames: 'connection ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! OneOnSwitch comment: 'I am a kind of Switch that can be connected to some related object, typically to a collection of my instances. When my instance is created, its connection is set to a particular object. When the object changes because an instance is turned on, an update message is broadcasted. All the connected OneOnSwitches, except the changed one, turn off. This allows OneOnSwitches to maintain the constraint that at most one of them will be on at any time. OneOnSwitches can thus be made to act like "car radio" switches. Instance Variables: connection any object '! !OneOnSwitch methodsFor: 'initialize-release'! release super release. self isConnectionSet ifTrue: [connection removeDependent: self]! ! !OneOnSwitch methodsFor: 'state'! turnOn "Does nothing if it is already on. If it is not, it is set to 'on', its dependents are notified of the change, its connection is notified, and its action is executed." self isOff ifTrue: [on _ true. self changed. self notifyConnection. self doAction: onAction]! ! !OneOnSwitch methodsFor: 'connection'! connection "Answer the object that connects the receiver to other Switches." ^connection! connection: anObject "Set anObject to be the connection among two or more Switches." connection _ anObject. connection addDependent: self! isConnectionSet "Answer whether the receiver is connected to an object that coordinates updates among switches." connection == nil ifTrue: [^false] ifFalse: [^true]! notifyConnection "Send the receiver's connection (if it exists) the message 'changed: self' in order for the connection to broadcast the change to other objects connected by the connection. " self isConnectionSet ifTrue: [self connection changed: self]! ! !OneOnSwitch methodsFor: 'updating'! update: aOneOnSwitch "Does nothing if aOneOnSwitch is identical to this object. If it is not, this object is turned off. Is sent by the connection (an Object) when some related OneOnSwitch (possibly this one) has changed. This allows a group of related OneOnSwitches to maintain the constraint that at most one will be on at any time. " self ~~ aOneOnSwitch ifTrue: [self turnOff]! ! CodeController subclass: #OnlyWhenSelectedCodeController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! OnlyWhenSelectedCodeController comment: 'I am a code controller that will not take control unless my model has some selection.'! !OnlyWhenSelectedCodeController methodsFor: 'control defaults'! isControlWanted view isSelected ifFalse: [sensor yellowButtonPressed ifTrue: [view flash]. self deselect. ^false]. ^self viewHasCursor! ! CodeView subclass: #OnlyWhenSelectedCodeView instanceVariableNames: 'selectionMsg ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! OnlyWhenSelectedCodeView comment: 'I am a code view for an OnlyWhenSelectedCodeController.'! !OnlyWhenSelectedCodeView methodsFor: 'initialization'! selectionMsg: selMsg selectionMsg _ selMsg! ! !OnlyWhenSelectedCodeView methodsFor: 'controller access'! defaultControllerClass ^OnlyWhenSelectedCodeController! ! !OnlyWhenSelectedCodeView methodsFor: 'control'! isSelected ^model perform: selectionMsg! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OnlyWhenSelectedCodeView class instanceVariableNames: ''! !OnlyWhenSelectedCodeView class methodsFor: 'instance creation'! on: anObject aspect: m1 change: m3 menu: m4 initialSelection: sel selection: selMsg "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) selectionMsg: selMsg! ! DisplayObject subclass: #OpaqueForm instanceVariableNames: 'figure shape ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! OpaqueForm comment: 'OpaqueForms include a shape as well as a figure form. The shape indicates what part of the background should get occluded in displaying, so that patterns other than black in the figure form will still appear opaque. Instance Variables: figure the actual image shape the mask for displaying'! !OpaqueForm methodsFor: 'accessing'! figure "Answer the visible image of the receiver." ^ figure! offset "Answer the offset for displaying the image." ^ figure offset! shape "Answer the form that indicates what part of the background should get occluded in displaying the receiver." ^ shape! valueAt: aPoint "Answer the bit of the form image at position aPoint. The value is either 0, 1 or 2 where 0 is white, 1 is black, 2 is transparent." (shape valueAt: aPoint) = 1 ifTrue: [^ figure valueAt: aPoint] "opaque" ifFalse: [^ 2 + (figure valueAt: aPoint)] "background shows through"! valueAt: aPoint put: value "Store a bit of the form image at position aPoint. The value is either 0, 1 or 2 where 0 is white, 1 is black, 2 is transparent." shape valueAt: aPoint put: 1 - (value//2). figure valueAt: aPoint put: value\\2! ! !OpaqueForm methodsFor: 'copying'! deepCopy "Answer a copy of the receiver with its own copy of each instance variable." ^ self shallowCopy setFigure: figure deepCopy shape: shape deepCopy! ! !OpaqueForm methodsFor: 'displaying'! copyBits: copyRect from: sourceForm at: destPoint clippingBox: clipRect rule: rule mask: mask "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." | sourceFigure sourceShape | (sourceForm isMemberOf: OpaqueForm) ifTrue: [sourceFigure _ sourceForm figure. sourceShape _ sourceForm shape] ifFalse: [sourceFigure _ sourceShape _ sourceForm]. figure copyBits: copyRect from: sourceFigure at: destPoint clippingBox: clipRect rule: rule mask: mask. shape copyBits: copyRect from: sourceShape at: destPoint clippingBox: clipRect rule: rule mask: mask! 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. " shape displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: Form erase mask: nil. figure displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: Form under mask: aForm! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger mask: aForm "See comment in Form." shape displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: Form erase mask: nil. figure displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: Form under mask: aForm! ! !OpaqueForm methodsFor: 'display box access'! computeBoundingBox "Answer the minimum enclosing rectangle around the image." ^figure boundingBox! ! !OpaqueForm methodsFor: 'editing'! bitEdit "Create and schedule a view located in an area designated by the user that contains a view of the receiver magnified by 8@8 that can be modified using the Bit Editor. It also contains a view of the original form." BitEditor openOnForm: self "OpaqueForm makeStar bitEdit."! ! !OpaqueForm 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. The general format for OpaqueForm is OpaqueForm figure: ( figure ) shape: ( shape )." aStream nextPutAll: 'OpaqueForm figure: ('. figure storeOn: aStream. aStream nextPutAll: ') shape: ('. shape storeOn: aStream. aStream nextPutAll: ')'! ! !OpaqueForm methodsFor: 'private'! setFigure: figureForm shape: shapeForm "Initialize the instance variables." figure _ figureForm. shape _ shapeForm! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OpaqueForm class instanceVariableNames: ''! !OpaqueForm class methodsFor: 'instance creation'! figure: figureForm shape: shapeForm "Answer a new instance of the receiver whose figure and shape forms are defined by the arguments." ^ self new setFigure: figureForm shape: shapeForm! shape: aSolidForm "Answer a new instance of the receiver that is black where aSolidForm is black and transparent where aSolidForm is white." ^ self new setFigure: aSolidForm shape: aSolidForm! ! !OpaqueForm class methodsFor: 'examples'! makeStar "Answer a new OpaqueForm in the shape of a five-pointed star filled with black." "OpaqueForm makeStar." "OpaqueForm makeStar bitEdit" | figure shape pen formRect | formRect_ 0@0 extent: 50@50. pen _ Pen new. pen defaultNib: 2. Display fill: formRect mask: Form white. pen north; place: formRect center; spiral: 45 angle: 144. shape _ Form fromDisplay: formRect. pen white; north; place: formRect center; spiral: 30 angle: 144. figure _ Form fromDisplay: formRect. ^ OpaqueForm figure: figure shape: shape! starCursor "Make the cursor track a five-pointed star." "OpaqueForm starCursor" Cursor blank showWhile: [self makeStar follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]! ! SequenceableCollection variableSubclass: #OrderedCollection instanceVariableNames: 'firstIndex lastIndex ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! OrderedCollection comment: 'Class OrderedCollection represents a collection of elements explicitly ordered by the sequence in which objects are added and removed. Elements are accessible by external keys that are indices. OrderedCollections can act as stacks or queues. A stack is a sequential list for which all additions and deletions are made at one end of the list; a queue is a sequential list for which all additions are made at one end, but all deletions are made from the other end. Instance Variables: *indexed* firstIndex external key referring to the first element of the collection lastIndex external key referring to the last element of the collection'! !OrderedCollection methodsFor: 'accessing'! after: oldObject "Answer the element after oldObject. If the receiver does not contain oldObject or if the receiver contains no elements after oldObject, provide an error notification." | index | index _ self find: oldObject. index = lastIndex ifTrue: [^self errorLastObject] ifFalse: [^self basicAt: index + 1]! at: anInteger "Answer the element at index anInteger. at: is used by a knowledgeable client to access an existing element" (anInteger < 1 or: [anInteger + firstIndex - 1 > lastIndex]) ifTrue: [self errorNoSuchElement] ifFalse: [^super at: anInteger + firstIndex - 1]! at: anInteger put: anObject "Put anObject at element index anInteger. at:put: can not be used to append, front or back, to an ordered collection; it is used by a knowledgeable client to replace an element." | index | index _ anInteger truncated. (index < 1 or: [index + firstIndex - 1 > lastIndex]) ifTrue: [self errorNoSuchElement] ifFalse: [^super at: index + firstIndex - 1 put: anObject]! before: oldObject "Answer the element before oldObject. If the receiver does not contain oldObject or if the receiver contains no elements before oldObject, provide an error notification." | index | index _ self find: oldObject. index = firstIndex ifTrue: [^self errorFirstObject] ifFalse: [^self basicAt: index - 1]! first "Answer the first element. If the receiver is empty, provide an error notification." "This is a little faster than the implementation in the superclass." self emptyCheck. ^self basicAt: firstIndex! last "Answer the last element. If the receiver is empty, create an error notification." "This is a little faster than the implementation in the superclass" self emptyCheck. ^self basicAt: lastIndex! size "Answer how many elements the receiver contains." ^lastIndex - firstIndex + 1! ! !OrderedCollection methodsFor: 'copying'! copyEmpty "Answer a copy of the receiver that contains no elements." ^self species new! copyFrom: startIndex to: endIndex "Answer a copy of the receiver that contains elements from position startIndex to endIndex." | targetCollection | endIndex < startIndex ifTrue: [^self species new: 0]. targetCollection _ self species new: endIndex + 1 - startIndex. startIndex to: endIndex do: [:index | targetCollection add: (self at: index)]. ^targetCollection! copyReplaceFrom: start to: stop with: replacementCollection "Answer a copy of the receiver with replacementCollection's elements in place of the receiver's start'th to stop'th elements. This does not expect a 1-1 map from replacementCollection to the start to stop elements, so it will do an insert or append." | newOrderedCollection delta startIndex stopIndex | "if start is less than 1, ignore stop and assume this is inserting at the front. if start greater than self size, ignore stop and assume this is appending. otherwise, it is replacing part of me and start and stop have to be within my bounds. " delta _ 0. startIndex _ start. stopIndex _ stop. start < 1 ifTrue: [startIndex _ stopIndex _ 0] ifFalse: [startIndex > self size ifTrue: [startIndex _ stopIndex _ self size + 1] ifFalse: [(stopIndex < (startIndex - 1) or: [stopIndex > self size]) ifTrue: [self errorOutOfBounds]. delta _ stopIndex - startIndex + 1]]. newOrderedCollection _ self species new: self size + replacementCollection size - delta. 1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)]. 1 to: replacementCollection size do: [:index | newOrderedCollection add: (replacementCollection at: index)]. stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)]. ^newOrderedCollection! copyWith: newElement "Answer a copy of the receiver that is 1 bigger than the receiver and includes the argument, newElement, at the end." | newCollection | newCollection _ self copy. newCollection add: newElement. ^newCollection! copyWithout: oldElement "Answer a copy of the receiver that does not contain any elements equal to oldElement." | newCollection | newCollection _ self species new: self size. self do: [:each | oldElement = each ifFalse: [newCollection add: each]]. ^newCollection! ! !OrderedCollection methodsFor: 'adding'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." ^self addLast: newObject! add: newObject after: oldObject "Add the argument, newObject, as an element of the receiver. Put it in the position just succeeding oldObject. Answer newObject." | index | index _ self find: oldObject. self insert: newObject before: index + 1. ^newObject! add: newObject before: oldObject "Add the argument, newObject, as an element of the receiver. Put it in the position just preceding oldObject. Answer newObject." | index | index _ self find: oldObject. self insert: newObject before: index. ^newObject! add: anObject beforeIndex: spot "Add the argument, newObject, as an element of the receiver. Put it in the position just preceding the indexed position spot. Answer newObject." self insert: anObject before: spot + firstIndex - 1! addAll: anOrderedCollection "Add each element of anOrderedCollection at my end. Answer anOrderedCollection. " ^self addAllLast: anOrderedCollection! addAllFirst: anOrderedCollection "Add each element of anOrderedCollection at the beginning of the receiver. Answer anOrderedCollection." anOrderedCollection reverseDo: [:each | self addFirst: each]. ^anOrderedCollection! addAllLast: anOrderedCollection "Add each element of anOrderedCollection at the end of the receiver. Answer anOrderedCollection." anOrderedCollection do: [:each | self addLast: each]. ^anOrderedCollection! addFirst: newObject "Add newObject to the beginning of the receiver. Add newObject." firstIndex = 1 ifTrue: [self makeRoomAtFirst]. firstIndex _ firstIndex - 1. self basicAt: firstIndex put: newObject. ^newObject! addLast: newObject "Add newObject to the end of the receiver. Answer newObject." lastIndex = self basicSize ifTrue: [self makeRoomAtLast]. lastIndex _ lastIndex + 1. self basicAt: lastIndex put: newObject. ^newObject! grow "Increase the number of elements of the collection." "Typically, a subclass has to override this if the subclass adds instance variables." | newSelf index| newSelf _ self species new: self size + self growSize. newSelf setIndicesFrom: self growSize // 2 + 1. index _ firstIndex. [index <= lastIndex] whileTrue: [newSelf addLastNoCheck: (self basicAt: index). index _ index + 1]. self become: newSelf! ! !OrderedCollection methodsFor: 'removing'! 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." | index | index _ firstIndex. [index <= lastIndex] whileTrue: [oldObject = (self basicAt: index) ifTrue: [self removeIndex: index. ^oldObject] ifFalse: [index _ index + 1]]. ^anExceptionBlock value! removeAllSuchThat: aBlock "Evaluate aBlock for each element of the receiver. Remove each element for which aBlock evaluates to true. A subclass might have to override this message to initialize additional instance variables for newCollection." | index element newCollection | newCollection _ self species new. index _ firstIndex. [index <= lastIndex] whileTrue: [element _ self basicAt: index. (aBlock value: element) ifTrue: [newCollection add: element. self removeIndex: index] ifFalse: [index _ index + 1]]. ^newCollection! removeAtIndex: anIndex "Remove the element of the collection at position anIndex. Answer the object removed." | obj | obj _ self at: anIndex. self removeIndex: anIndex + firstIndex - 1. ^obj! removeFirst "Remove the first element of the receiver. If the receiver is empty, provide an error notification." | firstObject | self emptyCheck. firstObject _ self basicAt: firstIndex. self basicAt: firstIndex put: nil. firstIndex _ firstIndex + 1. ^firstObject! removeLast "Remove the last element of the receiver. If the receiver is empty, provide an error notification." | lastObject | self emptyCheck. lastObject _ self basicAt: lastIndex. self basicAt: lastIndex put: nil. lastIndex _ lastIndex - 1. ^lastObject! ! !OrderedCollection 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." "Override superclass in order to use add:, not at:put:." | newCollection | newCollection _ self species new. self do: [:each | newCollection add: (aBlock value: each)]. ^newCollection! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." | index | index _ firstIndex. [index <= lastIndex] whileTrue: [aBlock value: (self basicAt: index). index _ index + 1]! reverse "Answer a new collection like the receiver with its elements in the opposite order." "Override superclass in order to use add:, not at:put:." | newCollection | newCollection _ self species new. self reverseDo: [:each | newCollection add: each]. ^newCollection! reverseDo: aBlock "Evaluate aBlock with each of the receiver's elements as the argument, starting with the last element and taking each in sequence up to the first." "Override the superclass for performance" | index | index _ lastIndex. [index >= firstIndex] whileTrue: [aBlock value: (self basicAt: index). index _ index - 1]! select: aBlock "Evaluate aBlock with each of my elements as the argument. Collect into a new collection like me, only those elements for which aBlock evaluates to true. Override superclass in order to use add:, not at:put:." | newCollection | newCollection _ self copyEmpty. self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^newCollection! ! !OrderedCollection methodsFor: 'user interface'! inspect "Create and schedule a OrderedCollectionInspector in which the user can examine the receiver's variables." InspectorView open: (OrderedCollectionInspector inspect: self)! ! !OrderedCollection methodsFor: 'private'! addLastNoCheck: newObject "Add newObject to the end of the receiver." lastIndex _ lastIndex + 1. self basicAt: lastIndex put: newObject. ^newObject! errorFirstObject self error: 'specified object is first object'! errorLastObject self error: 'specified object is last object'! errorNoSuchElement self error: 'attempt to index non-existent element in an ordered collection'! errorNotFound self error: 'element not found'! find: oldObject | index | index _ firstIndex. [index <= lastIndex and: [oldObject ~= (self basicAt: index)]] whileTrue: [index _ index + 1]. index <= lastIndex ifTrue: [^index] ifFalse: [self errorNotFound]! insert: anObject before: spot | index delta spotIndex| spotIndex _ spot. delta _ spotIndex - firstIndex. firstIndex = 1 ifTrue: [self makeRoomAtFirst. spotIndex _ firstIndex + delta]. index _ firstIndex _ firstIndex - 1. [index < (spotIndex - 1)] whileTrue: [self basicAt: index put: (self basicAt: index + 1). index _ index + 1]. self basicAt: index put: anObject. ^anObject! makeRoomAtFirst | delta index | delta _ self basicSize - self size. delta = 0 ifTrue: [^self grow]. "Assume that grow leaves room at first" lastIndex = self basicSize ifTrue: [^self]. "just in case we got lucky" index _ self basicSize. [index > delta] whileTrue: [self basicAt: index put: (self basicAt: index - delta + firstIndex - 1). self basicAt: index - delta + firstIndex - 1 put: nil. index _ index - 1]. firstIndex _ delta + 1. lastIndex _ self basicSize! makeRoomAtLast | index newLast | newLast _ self size. self basicSize - self size = 0 ifTrue: [^self grow]. "assume that grow always leaves room at the end" firstIndex = 1 ifTrue: [^self]. "we might be here under false premises" index _ 1. [index <= newLast] whileTrue: [self basicAt: index put: (self basicAt: index + firstIndex - 1). self basicAt: index + firstIndex - 1 put: nil. index _ index + 1]. firstIndex _ 1. lastIndex _ newLast! removeIndex: removedIndex "Remove the element of the collection at position anIndex." | index | index _ removedIndex. [index < lastIndex] whileTrue: [self basicAt: index put: (self basicAt: index + 1). index _ index + 1]. self basicAt: lastIndex put: nil. lastIndex _ lastIndex - 1! setIndices firstIndex _ self basicSize // 2 max: 1. lastIndex _ firstIndex - 1 max: 0! setIndicesFrom: initialIndex firstIndex _ initialIndex max: 1. lastIndex _ firstIndex -1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OrderedCollection class instanceVariableNames: ''! !OrderedCollection class methodsFor: 'instance creation'! new "Answer a new empty instance of OrderedCollection." ^self new: 10! new: anInteger "Answer a new empty instance of OrderedCollection. The size of an OrderedCollection is determined by the actual number of stored elements. Creating an instance using new: results in an empty collection, regardless of the size declared." "If a subclass adds fields, then it is necessary for that subclass to reimplement new: " ^(super new: anInteger) setIndices! ! Inspector subclass: #OrderedCollectionInspector instanceVariableNames: '' classVariableNames: 'OrderedCollectionMenu ' poolDictionaries: '' category: 'Interface-Inspector'! !OrderedCollectionInspector methodsFor: 'menu commands'! addField field == nil ifTrue: [object addLast: nil] "nothing selected" ifFalse: [self fieldIndex isNil ifTrue: [object addFirst: nil] "self selected" ifFalse: [object add: nil beforeIndex: self fieldIndex]]. self changed: #field! removeField self fieldIndex isNil ifTrue: [^self]. object removeAtIndex: self fieldIndex. self changed: #field! ! !OrderedCollectionInspector methodsFor: 'field'! acceptText: aText from: aController | val | self fieldIndex isNil ifTrue: [^false]. val _ self evaluateText: aText string from: aController ifFail: [^false]. object at: self fieldIndex put: val. self changed: #text. ^true! fieldIndex "Answer the index of the currently selected field, or nil if no index is selected." field isNil ifTrue: [^nil]. field = 'self' ifTrue: [^nil]. ^Integer readFromString: field! fieldList "Answer a collection of strings with 'self' and the indices of the inspected OrderedOollection." ^ (Array with: 'self'), ((1 to: object size) collect: [:i | i printString])! fieldMenu "OrderedCollectionInspector flushMenus" self fieldIndex isNil ifTrue: [^ActionMenu labels: 'add' selectors: #(addField)]. OrderedCollectionMenu == nil ifTrue: [OrderedCollectionMenu _ ActionMenu labels: 'inspect\insert\remove' withCRs lines: #(1) selectors: #(inspectField addField removeField)]. ^OrderedCollectionMenu! fieldValue field = 'self' ifTrue: [^object]. ^object at: self fieldIndex! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OrderedCollectionInspector class instanceVariableNames: ''! !OrderedCollectionInspector class methodsFor: 'initialization'! flushMenus OrderedCollectionMenu _ nil! ! Change subclass: #OtherChange instanceVariableNames: 'text ' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! OtherChange comment: 'Class OtherChange represents a non-classifiable change, i.e. a doIt. It caches text to reduce disk accesses. Instance Variable: text '! !OtherChange methodsFor: 'accessing'! name ^self defaultName: ' doIt '! parameters ^self text! text text == nil ifTrue: [text _ super text]. ^text! text: aString text _ aString. file _ nil! ! !OtherChange methodsFor: 'checking'! checkWith: aChecker "Discard comments and 'From ...' messages if from the current system" | myText aStream first | myText _ self text. myText isEmpty ifTrue: [^self]. aStream _ ReadStream on: myText. first _ aStream next. first = $" ifTrue: [aStream skipTo: $"; skipSeparators. aStream atEnd ifTrue: [^self]]. first = $' ifTrue: [first _ 'From ', Smalltalk version, ' on '. myText size > first size ifTrue: [(aStream next: first size) = first ifTrue: [^self]]]. aChecker addDoIt: self! ! DisplayText subclass: #Paragraph instanceVariableNames: 'clippingRectangle compositionRectangle destinationForm rule mask marginTabsLevel firstIndent restIndent rightIndent lines lastLine outputMedium ' classVariableNames: 'DefaultCompositionRectangle ' poolDictionaries: 'TextConstants ' category: 'Graphics-Display Objects'! Paragraph comment: 'Class Paragraph provides the support for creating, modifying and displaying text that has characteristics such as margin indenting and tabbing. The font and emphasis changes for text are fundamentally more complex than for such graphical entities as a bar chart or pie chart. Hence many of the methods associated with Paragraph tend to be, stylistically, longer and more complex than those in most other system classes. Instance Variables: clippingRectangle A Rectangle in CurrentDisplay coordinates. Its intersection with the compositionRectangle in turn intersected with the destinationForm is the area in which characters are constrained to display. compositionRectangle Its offset serves as a relative offset similar to the offset field in Form. The width of the compositionRectangle is the dimension, modified by indents and tabsLevels, against which line wraparound is measured. The height of the compositionRectangle is reset each time recomposition is required. This happens when the stylizedString is initially composed and whenever a replacement (copyReplaceFrom:to:with:) occurs. destinationForm The Form into which the characters are scanned. Typically CurrentDisplay. rule The rule according to which character display behaves. For example, rule may equal over, under, reverse, etc. mask The form with which each character is combined by the scanner before applying the rule for display. marginTabsLevel The margin tabs give the left and right indent values for a specified marginTabsLevel. The marginTabsLevel is sometimes referred to as the nesting level and is an index into the marginTabsArray of the stringStyle. firstIndent Amount to inset from the left margin for the first line of a paragraph. Initialized to value in the textStyle. restIndent Amount to inset from the left margin for all but the first line of a paragraph. Initialized to value in the textStyle. rightIndent Amount to inset from the right margin for all the lines of the paragraph. Initialized to value in the textStyle. lines This array is built during composition and modified when the stylizedString is modified (copyReplaceFrom:to:with:). Each of its fields from 1 to lastLine contains a TextLineInterval which in turn contains the starting index and stopping index of a given line as well as its internal spaces and padding width, the latter two being used to support the management of padded spaces, tabs and changing margin alignments. lastLine The index of the last validly composed line in the lines array. outputMedium Either #Display, #PressPrinter or #DisplayPrinterWidths as of 1/20/80. 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. Also used for some margin and grid computations. Class Variable: DefaultCompositionRectangle a rectangle that will be used for composition unless otherwise specified.'! !Paragraph methodsFor: 'accessing'! baseline "Answer the baseline of the receiver's text style." ^textStyle baseline! clippingRectangle "Answer the rectangle, defined in absolute coordinates, whose intersection with the destinationForm is the area in which the characters are constrained to display." ^clippingRectangle! clippingRectangle: aRectangle "Set the rectangle, defined in absolute coordinates, whose intersection with the destinationForm is the area in which the characters are constrained to display." clippingRectangle _ aRectangle.! compositionRectangle "Answer the rectangle whose width is the dimension, modified by indents and tabs levels, against which line wraparound is measured. The height of the compositionRectangle is reset each time recomposition is required." ^compositionRectangle! compositionRectangle: compRectangle "Set the rectangle whose width is the dimension, modified by indents and tabs levels, against which line wraparound is measured." compositionRectangle _ compRectangle. self composeAll! destinationForm "Answer the Form into which the characters are scanned." ^destinationForm! destinationForm: aFormOrRectangle "Set the Form or Rectangle into which the characters are scanned. " destinationForm _ aFormOrRectangle! form "Answer the form or caching the bit representation of the receiver's composed text." ^form! height "Answer the height of the composition rectangle." ^compositionRectangle height! lineGrid "Answer the line grid of the receiver's text style." ^textStyle lineGrid! mask "Answer the form with which each character is combined by the scanner before applying the rule for display." ^mask! mask: maskForm "Set the argument, maskForm, to be the form with which each character is combined by the scanner before applying the rule for display." mask _ maskForm.! numberOfLines "Answer the number of lines of text in the receiver." ^lastLine! outputMedium "Answer the output medium for the receiver." ^outputMedium! outputMedium: aSymbol "Set the argument to be the output medium for the receiver." outputMedium _ aSymbol. "Changing the outputMedium means that the text must be recomposed." textStyle outputMedium: aSymbol. self composeAll! replaceFrom: start to: stop with: aText displaying: displayBoolean "Replace the receiver's text starting at position start, stopping at stop, by the characters in aText." " It is expected that most requirements for modifications to the receiver will call this code. Certainly all cut's or paste's will do so." | compositionScanner obsoleteLines obsoleteLastLine firstLineIndex lastLineIndex startLine stopLine replacementRange visibleRectangle startIndex newLine done newStop obsoleteY newY upOrDown moveRectangle | text "Update the text." replaceFrom: start to: stop with: aText. lastLine = 0 ifTrue: ["if lines have never been set up, measure them and display all the lines falling in the visibleRectangle" self composeAll. displayBoolean ifTrue: [self clearVisibleRectangle. self displayLines: (1 to: lastLine)]. ^self]. "save -- things get pretty mashed as we go along" obsoleteLines _ lines copy. obsoleteLastLine _ lastLine. "find the starting and stopping lines" firstLineIndex _ startLine _ self lineIndexOfCharacterIndex: start. stopLine _ self lineIndexOfCharacterIndex: stop. "how many characters being inserted or deleted -- negative if aText size is < characterInterval size." replacementRange _ aText size - (stop - start + 1). "Give ourselves plenty of elbow room." compositionRectangle height: textStyle lineGrid * 8196. "max Vector length" "build a boundingBox of the actual screen space in question -- we'll need it later" visibleRectangle _ (clippingRectangle intersect: compositionRectangle) intersect: destinationForm boundingBox. "Initialize a scanner." compositionScanner _ CompositionScanner new in: self. "If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears. For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line." startIndex _ (lines at: firstLineIndex) first. startLine > 1 ifTrue: [newLine _ compositionScanner composeLine: startLine - 1 fromCharacterIndex: (lines at: startLine - 1) first inParagraph: self. (lines at: startLine - 1) = newLine ifFalse: ["start in line preceding the one with the starting character" startLine _ startLine - 1. self lineAt: startLine put: newLine. startIndex _ newLine last + 1]]. startIndex > text size ifTrue: ["nil lines after a deletion -- remeasure last line below" self trimLinesTo: (firstLineIndex - 1 max: 0). text size = 0 ifTrue: ["entire text deleted -- clear visibleRectangle and return." destinationForm fill: visibleRectangle rule: rule mask: Form white. self updateCompositionHeight. ^self]]. "Now we really get to it." done _ false. lastLineIndex _ stopLine. [done or: [startIndex > text size]] whileFalse: [self lineAt: firstLineIndex put: (newLine _ compositionScanner composeLine: firstLineIndex fromCharacterIndex: startIndex inParagraph: self). [(lastLineIndex > obsoleteLastLine or: ["no more old lines to compare with?" newLine last < (newStop _ (obsoleteLines at: lastLineIndex) last + replacementRange)]) or: [done]] whileFalse: [newStop = newLine last ifTrue: ["got the match" upOrDown _ replacementRange < 0 ifTrue: [0] ifFalse: [1]. "get source and dest y's for moving the unchanged lines" obsoleteY _ self topAtLineIndex: lastLineIndex + upOrDown. newY _ self topAtLineIndex: firstLineIndex + upOrDown. stopLine _ firstLineIndex. done _ true. "Fill in the new line vector with the old unchanged lines. Update their starting and stopping indices on the way." ((lastLineIndex _ lastLineIndex + 1) to: obsoleteLastLine) do: [:upDatedIndex | self lineAt: (firstLineIndex _ firstLineIndex + 1) put: ((obsoleteLines at: upDatedIndex) slide: replacementRange)]. "trim off obsolete lines, if any" self trimLinesTo: firstLineIndex] ifFalse: [lastLineIndex _ lastLineIndex + 1]]. startIndex _ newLine last + 1. firstLineIndex _ firstLineIndex + 1]. "Now the lines are up to date -- Whew!!. What remains is to move the 'unchanged' lines and display those which have changed." displayBoolean ifTrue: [ startIndex > text size ifTrue: ["If at the end of previous lines simply display lines from the line in which the first character of the replacement occured through the end of the paragraph." self updateCompositionHeight. self displayLines: (startLine to: (stopLine _ firstLineIndex min: lastLine))] ifFalse: ["Otherwise prepare to move the unchanged lines. moveRectangle defines the portion of the visibleRectangle containing the lines which may be moved en masse. Deletion -- moving 'up' the screen or ..." moveRectangle _ visibleRectangle left @ (obsoleteY max: visibleRectangle top) corner: visibleRectangle corner. "Insertion -- moving 'down' the screen. Shorten moveRectangle by height of insertion or ..." obsoleteY <= newY ifTrue: [moveRectangle corner: visibleRectangle corner + (0 @ (obsoleteY - newY))] ifFalse: ["Deletion, and top of moveRectangle will fall above top of visibleRectangle. Increase the origin of moveRectangle by the amount that would fall above (hence outside) the visibleRectangle." newY < visibleRectangle top ifTrue: [moveRectangle origin: visibleRectangle left @ (obsoleteY + visibleRectangle top - newY)]]. "Move'em." destinationForm copyBits: moveRectangle from: destinationForm at: visibleRectangle left @ (newY max: visibleRectangle top) clippingBox: visibleRectangle rule: Form over mask: Form black. "Display the new lines." self displayLines: (startLine to: stopLine). "A deletion may have 'pulled' previously undisplayed lines into the visibleRectangle. If so, display them." (newY < obsoleteY and: [(self topAtLineIndex: obsoleteLastLine + 1) > visibleRectangle bottom]) ifTrue: [self displayLines: ((self lineIndexOfTop: visibleRectangle bottom - (obsoleteY - newY)) to: (stopLine _ self lineIndexOfTop: visibleRectangle bottom))]]. "If we have done a deletion, obsolete material may remain at the bottom of the visibleRectangle. If so, clear it out." obsoleteLastLine >= lastLine ifTrue: [ newY _ self topAtLineIndex: lastLine + 1. newY < visibleRectangle top ifTrue: ["new lastLine is above visibleRectangle, clear entire visibleRectangle" destinationForm fill: visibleRectangle rule: rule mask: Form white] ifFalse: [destinationForm fill: ((visibleRectangle left @ newY extent: visibleRectangle extent) intersect: visibleRectangle) rule: rule mask: Form white]]]. self updateCompositionHeight.! rule "Answer the rule according to which character display behaves. For example, rule may equal over, under, reverse." ^rule! rule: ruleInteger "Set the rule according to which character display behaves." rule _ ruleInteger.! setCompositionRectangle: compRectangle "Set the rectangle whose width is the dimension, modified by indents and tabsLevels, against which line wraparound is measured." compositionRectangle _ compRectangle.! text: aText "Set the argument, aText, to be the text for the receiver." text _ aText. self composeAll! ! !Paragraph methodsFor: 'displaying'! displayAt: aPoint "Display the receiver located at aPoint within its clipping rectangle and according to the receiver's rule and mask." "Because Paragraphs cache so much information, computation is avoided and displayAt: 0@0 is not appropriate here" self displayOn: destinationForm at: aPoint clippingBox: clippingRectangle rule: rule mask: mask! displayOn: aDisplayMedium "Display on a new destination medium -- typically a form." self displayOn: aDisplayMedium at: compositionRectangle topLeft clippingBox: clippingRectangle rule: rule mask: mask! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Default display message when aDisplayPoint is in absolute screen coordinates. " destinationForm _ aDisplayMedium. clippingRectangle _ clipRectangle. rule _ ruleInteger. mask _ aForm. compositionRectangle moveTo: aDisplayPoint. (lastLine == nil or: [lastLine < 1]) ifTrue: [self composeAll]. self displayLines: (1 to: lastLine)! 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." self "Assumes offset has been set!!!!!!!!!!" displayOn: aDisplayMedium at: (offset + (displayTransformation applyTo: relativePoint) - alignmentPoint) rounded clippingBox: clipRectangle rule: ruleInteger mask: aForm.! ! !Paragraph methodsFor: 'display box access'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^offset extent: compositionRectangle extent! computeBoundingBox "Answer the minimum enclosing rectangle around the composed test of the paragraph." ^offset extent: compositionRectangle extent! ! !Paragraph methodsFor: 'composition'! composeAll "Compose a collection of characters into a collection of lines." | startIndex stopIndex lineIndex maximumRightX compositionScanner | lines _ Array new: 32. lastLine _ 0. maximumRightX _ 0. text size = 0 ifTrue: [compositionRectangle height: 0. ^maximumRightX]. startIndex _ lineIndex _ 1. stopIndex _ text size. compositionScanner _ CompositionScanner new in: self. [startIndex > stopIndex] whileFalse: [self lineAt: lineIndex put: (compositionScanner composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: self). maximumRightX _ compositionScanner rightX max: maximumRightX. startIndex _ (lines at: lineIndex) last + 1. lineIndex _ lineIndex + 1]. self updateCompositionHeight. self trimLinesTo: lineIndex - 1. ^maximumRightX! recomposeIn: compositionRect clippingBox: clippingRect "Set the composition rectangle for the receiver so that the lines wrap within the rectangle, compositionRect, and the display of the text is clipped by the rectangle, clippingRect." self compositionRectangle: compositionRect copy text: text style: textStyle offset: offset outputMedium: #Display fitWidth: false. clippingRectangle _ clippingRect copy! ! !Paragraph methodsFor: 'character location'! characterBlockAtPoint: aPoint "Answer a CharacterBlock for characters in the text at point aPoint. It is assumed that aPoint has been transformed into coordinates appropriate to the receiver's destinationForm rectangle and the compositionRectangle." ^CharacterBlockScanner new characterBlockAtPoint: aPoint in: self! characterBlockForIndex: targetIndex "Answer a CharacterBlock for character in the text at targetIndex. The coordinates in the CharacterBlock will be appropriate to the intersection of the destinationForm rectangle and the compositionRectangle." ^CharacterBlockScanner new characterBlockForIndex: targetIndex in: self! ! !Paragraph methodsFor: 'selecting'! displayCaretAt: aPoint "Display the caret form located at aPoint with default settings for rule and halftone." Cursor caret displayOn: destinationForm at: aPoint clippingBox: clippingRectangle rule: Form reverse mask: Form black! displayCaretForBlock: aCharacterBlock "Show caret at proper place for aCharacterBlock" self displayCaretAt: (aCharacterBlock topLeft + (0@textStyle baseline))! dyForPoint: pt "See if the argument pt is above or below clippingRectangle. Answer the scroll amount." | dy dyLim | ((dy _ pt y - clippingRectangle top) < 0 and: [(dyLim _ compositionRectangle top - clippingRectangle top) < 0]) ifTrue: [^(dy max: dyLim) - textStyle lineGrid]. ((dy _ pt y - clippingRectangle bottom) > 0 and: [(dyLim _ compositionRectangle bottom - clippingRectangle bottom) > 0]) ifTrue: [^(dy min: dyLim) + textStyle lineGrid]. ^0! mouseSelect: previousStartBlock to: previousStopBlock "Answer an Array of two CharacterBlocks that represent the text selection that the user makes. Allow for scrolling to extend selections." | pivotBlock startBlock stopBlock showingCaret dy pt okToScroll scrollDelay word | startBlock _ stopBlock _ pivotBlock _ self characterBlockAtPoint: Sensor cursorPoint. self displayCaretForBlock: pivotBlock. showingCaret _ true. okToScroll _ true. scrollDelay _ Delay forMilliseconds: 250. [Sensor redButtonPressed] whileTrue: [ pt _ Sensor cursorPoint. (okToScroll and: [(dy _ self dyForPoint: pt) ~= 0]) ifTrue: [ [okToScroll _ false. scrollDelay wait. okToScroll _ true] forkAt: Processor userInterruptPriority. showingCaret ifTrue: [ self displayCaretForBlock: pivotBlock. showingCaret _ false] ifFalse: [self reverseFrom: startBlock to: pivotBlock]. self scrollBy: dy. pt _ dy < 0 ifTrue: [clippingRectangle topLeft] ifFalse: [clippingRectangle bottomRight]. pivotBlock _ self characterBlockForIndex: pivotBlock stringIndex. startBlock _ pivotBlock ]. stopBlock _ self characterBlockAtPoint: pt. stopBlock = startBlock ifFalse: [ showingCaret ifTrue: [ self displayCaretForBlock: pivotBlock. showingCaret _ false]. self reverseFrom: startBlock to: stopBlock. startBlock _ stopBlock] ]. (showingCaret not and: [pivotBlock = stopBlock]) ifTrue: [self displayCaretForBlock: pivotBlock]. scrollDelay disable. (previousStartBlock = previousStopBlock and: [pivotBlock = stopBlock and: [stopBlock = previousStopBlock]]) ifTrue: "select a word or bracketed range" [word _ self selectWord: pivotBlock stringIndex. word first = word last ifFalse: [self displayCaretForBlock: pivotBlock. pivotBlock _ self characterBlockForIndex: word first. stopBlock _ self characterBlockForIndex: word last. self reverseFrom: pivotBlock to: stopBlock]]. stopBlock < pivotBlock ifTrue: [^Array with: stopBlock with: pivotBlock] ifFalse: [^Array with: pivotBlock with: stopBlock]! reverseFrom: characterBlock1 to: characterBlock2 "Reverse area between the two character blocks given as arguments." | start stop | characterBlock1 = characterBlock2 ifTrue: [^self]. characterBlock1 < characterBlock2 ifTrue: [start _ characterBlock1. stop _ characterBlock2] ifFalse: [start _ characterBlock2. stop _ characterBlock1]. start top = stop top ifTrue: [ ^self reverseRectangle: (start origin corner: stop bottomLeft)]. self reverseRectangle: (start origin corner: compositionRectangle right @ start bottom). self reverseRectangle: (compositionRectangle left@start bottom corner: compositionRectangle right@stop top). self reverseRectangle: (compositionRectangle left@stop top corner: stop bottomLeft).! reverseRectangle: aRectangle "Highlight the part of aRectangle that is visible." | rect | rect _ aRectangle intersect: self visibleRectangle. destinationForm fill: rect rule: Form reverse mask: mask.! selectWord: stringIndex "Select delimited text or word--the result of double-clicking." | openDelimiter closeDelimiter direction match level leftDelimiters rightDelimiters string here hereChar start stop | string _ text string. here _ stringIndex. (here between: 2 and: string size) ifFalse: ["if at beginning or end, select entire string" ^ 1 to: string size + 1]. leftDelimiters _ '([{<''" '. rightDelimiters _ ')]}>''" '. openDelimiter _ string at: here - 1. match _ leftDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on left -- match to the right" start _ here. direction _ 1. here _ here - 1. closeDelimiter _ rightDelimiters at: match] ifFalse: [openDelimiter _ string at: here. match _ rightDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on right -- match to the left" stop _ here - 1. direction _ -1. closeDelimiter _ leftDelimiters at: match] ifFalse: ["no delimiters -- select a token" direction _ -1]]. level _ 1. [level > 0 and: [direction > 0 ifTrue: [here < string size] ifFalse: [here > 1]]] whileTrue: [hereChar _ string at: (here _ here + direction). match = 0 ifTrue: ["token scan goes left, then right" hereChar tokenish ifTrue: [here = 1 ifTrue: [start _ 1. "go right if hit string start" direction _ 1]] ifFalse: [direction < 0 ifTrue: [start _ here + 1. "go right if hit non-token" direction _ 1] ifFalse: [level _ 0]]] ifFalse: ["bracket match just counts nesting level" hereChar = closeDelimiter ifTrue: [level _ level - 1"leaving nest"] ifFalse: [hereChar = openDelimiter ifTrue: [level _ level + 1"entering deeper nest"]]]]. level > 0 ifTrue: ["in case ran off string end" here _ here + direction]. direction > 0 ifTrue: [^ start to: here] ifFalse: [^ here + 1 to: stop + 1]! ! !Paragraph methodsFor: 'scrolling'! scrollBy: heightToMove "Change the composition rectangle such that the first line of text corresponds to the line at the current first line plus heightToMove, modulo the grid of the receiver's text style." self scrollBy: heightToMove grid: textStyle lineGrid.! scrollBy: height grid: grid "Change the composition rectangle such that the first line of text corresponds to the line at the current first line plus heightToMove, modulo the grid." | initialClippingRectangle heightToMove | "keep from scrolling out of clippingRectangle" heightToMove _ (height max: self compositionRectangleDelta). (heightToMove abs between: 0 and: grid) ifTrue: [heightToMove _ heightToMove sign * grid] ifFalse: [heightToMove _ heightToMove truncateTo: grid]. heightToMove abs >= clippingRectangle height ifTrue: [self clearVisibleRectangle. "adjust compositionRectangle behind clippingRectangle" compositionRectangle moveBy: (0 @ (0 - heightToMove)). "If heightToMove >= clippingRectangle, all lines to be displayed are not currently displayed." self displayLines: (1 to: lastLine). ^self]. "Adjust compositionRectangle behind clippingRectangle" compositionRectangle moveBy: (0 @ (0 - heightToMove)). "Need only to reshow part of clippingRectangle. Some of the lines are already on the display screen." initialClippingRectangle _ clippingRectangle copy. (clippingRectangle bottom > destinationForm boundingBox bottom) ifTrue:[clippingRectangle _ clippingRectangle bottom: destinationForm boundingBox bottom]. heightToMove < 0 "Box the lines to be moved." ifTrue: ["Moving down." clippingRectangle _ clippingRectangle insetOriginBy: (0 @ 0) cornerBy: (0 @ (0 - heightToMove ))] ifFalse: ["Moving up." clippingRectangle _ clippingRectangle insetOriginBy: (0 @ heightToMove ) cornerBy: (0 @ 0)]. destinationForm copyBits: clippingRectangle from: destinationForm at: clippingRectangle left @ (clippingRectangle top - heightToMove ) clippingBox: initialClippingRectangle rule: Form over mask: Form black. "Make room in clippingRectangle for lines 'pulled' into view." heightToMove < 0 ifTrue: ["On the top." (clippingRectangle bottomRight) y: clippingRectangle top - heightToMove ] ifFalse: ["At the bottom." (clippingRectangle topLeft) y: (((self topAtLineIndex: (self lineIndexOfTop: clippingRectangle bottom - heightToMove))) max: initialClippingRectangle topLeft y)]. "The reduced clippingRectangle informs the displayLines routine of what lines to actually display of those it is requested to display. It only displays those actually falling in the clippingRectangle." self displayLines: (1 to: lastLine). "If we've shortened so that bottom of compositionRectangle is < clippingRectangle, clear out the the potential garbage at the bottom of the clippingRectangle." compositionRectangle bottom < initialClippingRectangle bottom ifTrue: [destinationForm fill: (initialClippingRectangle left @ compositionRectangle bottom corner: initialClippingRectangle bottomRight) mask: Form white]. "And the clippingRectangle needs to be set to its original value." clippingRectangle _ initialClippingRectangle.! ! !Paragraph methodsFor: 'alignment'! centered "Set the alignment for the style with which the receiver displays its text so that text is centered in the composition rectangle." textStyle alignment: Centered.! justified "Set the alignment for the style with which the receiver displays its text so that the characters in each of text end on an even border in the composition rectangle." textStyle alignment: Justified.! leftFlush "Set the alignment for the style with which the receiver displays its text so that the characters in each of text begin on an even border in the composition rectangle. This is also known as ragged-right." textStyle alignment: LeftFlush.! rightFlush "Set the alignment for the style with which the receiver displays its text so that the characters in each of text end on an even border in the composition rectangle but the beginning of each line does not (ragged-left)." textStyle alignment: RightFlush! toggleAlignment "Set the alignment for the style with which the receiver displays its text so that it moves from centered to justified to left flush to right flush and back to centered again." textStyle alignment: textStyle alignment + 1.! ! !Paragraph methodsFor: 'tabs and margins'! clearIndents "Reset all the indention settings to be 0." self firstIndent: 0. self restIndent: 0. self rightIndent: 0! deltaMarginTabsLevel: anInteger "Delta the depth of 'nesting' for this paragraph ." self marginTabsLevel: anInteger + marginTabsLevel! firstIndent "Answer the horizontal indenting of the first line of a paragraph in the style of the receiver." ^firstIndent! firstIndent: anInteger "Set the horizontal indenting of the first line of a paragraph in the style of the receiver to be anInteger." firstIndent _ (anInteger max: 0) min: compositionRectangle width - DefaultSpace - rightIndent. self composeAll! marginTabsLevel "Answer the depth of 'nesting' for this paragraph." ^marginTabsLevel! marginTabsLevel: anInteger "Set the depth of 'nesting' for this paragraph ." marginTabsLevel _ (anInteger max: 0) min: textStyle nestingDepth. "Check if we've nested so far that there is no room between the effective margins." [(self leftMarginForCompositionForLine: 1) >= (self rightMarginForComposition) and: [marginTabsLevel > 0]] whileTrue: [marginTabsLevel _ (marginTabsLevel - 1 max: 0)]. [(self leftMarginForCompositionForLine: 2) >= (self rightMarginForComposition) and: [marginTabsLevel > 0]] whileTrue: [marginTabsLevel _ (marginTabsLevel - 1 max: 0)]. self composeAll.! restIndent "Answer the indent for all but the first line of a paragraph in the style of the receiver." ^restIndent! restIndent: anInteger "Set the indent for all but the first line of a paragraph in the style of the receiver to be anInteger." restIndent _ (anInteger max: 0) min: compositionRectangle width - DefaultSpace - rightIndent. self composeAll! rightIndent "Answer the right margin indent for the lines of a paragraph in the style of the receiver." ^rightIndent! rightIndent: anInteger "Set the right margin indent for the lines of a paragraph in the style of the receiver to be anInteger." | maxRightIndent | firstIndent > restIndent ifTrue: [maxRightIndent _ compositionRectangle width - DefaultSpace - firstIndent max: 1] ifFalse: [maxRightIndent _ compositionRectangle width - DefaultSpace - restIndent max: 1]. rightIndent _ anInteger min: maxRightIndent. self composeAll! ! !Paragraph methodsFor: 'indicating'! flash "Complement twice the visible area in which the receiver displays." Display flash: self visibleRectangle! outline "Display a border around the visible area in which the receiver presents its text." clippingRectangle bottom <= compositionRectangle bottom ifTrue: [Display border: (clippingRectangle intersect: compositionRectangle) width: 2] ifFalse: [Display border: (clippingRectangle intersect: destinationForm boundingBox) width: 2].! ! !Paragraph methodsFor: 'utilities'! clearVisibleRectangle "Display the area in which the receiver presents its text so that the area is all one tone--in this case, all white." destinationForm fill: self visibleRectangle rule: rule mask: Form white.! fit "Make the bounding rectangle of the receiver contain all the text without changing the width of the receiver's composition rectangle." [(self lineIndexOfTop: clippingRectangle top) = 1] whileFalse: [self scrollBy: (0-1)*textStyle lineGrid]. self updateCompositionHeight. clippingRectangle bottom: compositionRectangle bottom! gridWithLead: leadInteger "Set the line grid of the receiver's style for displaying text to the height of the first font in the receiver's style + the argument, leadInteger." textStyle gridForFont: (text emphasisAt: 1) withLead: leadInteger. "assumes only one font referred to by runs" self updateCompositionHeight.! ! !Paragraph methodsFor: 'converting'! asForm "Answer a new Form made up of the bits that represent the receiver's displayable text." | aForm saveDestinationForm | aForm _ Form new extent: compositionRectangle extent. saveDestinationForm _ destinationForm. self displayOn: aForm at: 0 @ 0 clippingBox: aForm boundingBox rule: Form over mask: Form black. aForm offset: offset. destinationForm _ saveDestinationForm. ^aForm! asString "Answer the string of characters of the receiver's text." ^text string! asText "Answer the receiver's text." ^text! ! !Paragraph methodsFor: 'private'! compositionRectangle: compositionRect text: aText style: aTextStyle offset: aPoint outputMedium: aSymbol fitWidth: aBoolean "Initialize the receiver." | paddingDelta | compositionRectangle _ compositionRect copy. text _ aText. textStyle _ aTextStyle. firstIndent _ textStyle firstIndent. restIndent _ textStyle restIndent. rightIndent _ textStyle rightIndent. marginTabsLevel _ 0. outputMedium _ aSymbol. lines _ Array new: 32. lastLine _ 0. rule _ DefaultRule. mask _ DefaultMask. destinationForm _ Display. clippingRectangle _ destinationForm boundingBox. offset _ aPoint. aBoolean ifTrue: [ "save initial width of compositionRectangle" paddingDelta _ compositionRectangle width. compositionRectangle width: (self composeAll "returns fitted right margin" - compositionRectangle left). paddingDelta _ paddingDelta - compositionRectangle width. "Have to shrink padding widths created when compositionRectangle was large." 1 to: lastLine do: [:i | (lines at: i) paddingWidth: (lines at: i) paddingWidth - paddingDelta]] ifFalse: ["Composition rectangle sent in is the one desired no matter what the maximum right struck by the text." self composeAll]! compositionRectangleDelta "Answer the composition rectangle offset, used mostly for scrolling." ^compositionRectangle top - clippingRectangle top! copyLines: anInterval ^lines copyFrom: anInterval first to: (anInterval last min: lastLine)! displayLines: linesInterval "This is the first level workhorse in the display portion of the TextForm routines. It checks to see which lines in the interval are actually visible, has the DisplayScanner display only those, clears out the areas in which display will occur, and clears any space remaining in the visibleRectangle following the space occupied by lastLine." | lineGrid visibleRectangle topY firstLineIndex lastLineIndex lastLineIndexBottom | lineGrid _ textStyle lineGrid. "Save some time by only displaying visible lines" visibleRectangle _ (clippingRectangle intersect: compositionRectangle) intersect: destinationForm boundingBox. firstLineIndex _ self lineIndexOfTop: visibleRectangle top. firstLineIndex < linesInterval first ifTrue: [firstLineIndex _ linesInterval first]. lastLineIndex _ self lineIndexOfTop: visibleRectangle bottom - 1. lastLineIndex > linesInterval last ifTrue: [linesInterval last > lastLine ifTrue: [lastLineIndex _ lastLine] ifFalse: [lastLineIndex _ linesInterval last]]. ((Rectangle origin: visibleRectangle left @ (topY _ self topAtLineIndex: firstLineIndex) corner: visibleRectangle right @ (lastLineIndexBottom _ (self topAtLineIndex: lastLineIndex) + lineGrid)) intersects: visibleRectangle) ifFalse: ["None of lines in interval visible." ^self]. "Set boundingBox containing the lines in linesInterval to color for space surrounding the characters." destinationForm fill: ((visibleRectangle left @ topY extent: visibleRectangle width @ (lastLineIndexBottom - topY)) intersect: visibleRectangle) rule: rule mask: Form white. DisplayScanner new displayLines: (firstLineIndex to: lastLineIndex) in: self clippedBy: visibleRectangle. lastLineIndex = lastLine ifTrue: [destinationForm fill: (visibleRectangle left @ lastLineIndexBottom extent: visibleRectangle width @ (visibleRectangle bottom - lastLineIndexBottom)) rule: rule mask: Form white]! leftMarginForCompositionForLine: lineIndex "Build the left margin for composition of a line." "Depends upon marginTabsLevel and the indent." | scale | scale _ 1. lineIndex = 1 ifTrue: [^(firstIndent + (textStyle leftMarginTabAt: marginTabsLevel)) * scale] ifFalse: [^(restIndent + (textStyle leftMarginTabAt: marginTabsLevel)) * scale].! leftMarginForDisplayForLine: lineIndex "Build the left margin for display of a line." "Depends upon leftMarginForComposition, compositionRectangle left, the outputMedium and the alignment." | pad scale| scale _ 1. (textStyle alignment = LeftFlush or: [textStyle alignment = Justified]) ifTrue: [^((compositionRectangle left * scale) + (self leftMarginForCompositionForLine: lineIndex))]. "When called from character location code and entire string has been cut, there are no valid lines, hence following nil check." ( lineIndex <= lines size and: [(lines at: lineIndex) ~~ nil]) ifTrue: [pad _ (lines at: lineIndex) paddingWidth] ifFalse: [pad _ compositionRectangle width - firstIndent - rightIndent]. textStyle alignment = Centered ifTrue: [^((compositionRectangle left * scale) + (self leftMarginForCompositionForLine: lineIndex)) + (pad // 2)]. textStyle alignment = RightFlush ifTrue: [^((compositionRectangle left * scale) + (self leftMarginForCompositionForLine: lineIndex)) + pad]. self error: ['no such alignment']! lineAt: lineIndex "Answer the textLineInterval for the specified line." ^ lines at: lineIndex! lineAt: indexInteger put: aTextLineInterval "Store a line, track last, and grow lines if necessary." indexInteger > lastLine ifTrue: [lastLine _ indexInteger]. lastLine > lines size ifTrue: [lines grow]. ^lines at: indexInteger put: aTextLineInterval! lineIndexOfCharacterIndex: characterIndex "line index for a given characterIndex" 1 to: lastLine do: [:lineIndex | (lines at: lineIndex) last >= characterIndex ifTrue: [^lineIndex]]. ^lastLine! lineIndexOfTop: top "Answer the line index at a given top y." ^(top - compositionRectangle top // textStyle lineGrid + 1 max: 1) min: lastLine! lines ^lines! lines: anArray "Install a new set of lines in the paragraph, a tricky way to avoid recomposing when a press paragraph overflows a page." lines _ anArray. (lastLine _ (anArray indexOf: nil) - 1) = -1 ifTrue: [^lastLine _ anArray size] ifFalse: [^lastLine]! removeFirstChars: numberOfChars "Remove a number of characters from the beginning of the receiver, adjusting the composition rectangle so the displayed text moves as little as possible. " | delta scrollDelta | delta _ (self lineIndexOfCharacterIndex: numberOfChars) - 1 * self lineGrid. scrollDelta _ self compositionRectangleDelta negated. delta > scrollDelta ifTrue: [delta _ scrollDelta. "deleting some visible lines" self clearVisibleRectangle]. self replaceFrom: 1 to: numberOfChars with: '' asText displaying: false. compositionRectangle moveBy: 0 @ delta. delta = scrollDelta ifTrue: [self display]! repositionAt: aPoint clippingBox: clippingBox compositionRectangle moveTo: aPoint. clippingRectangle _ clippingBox.! rightMarginForComposition "Build the right margin for a line." "Depends upon compositionRectangle width, marginTabsLevel, and right indent." | scale | scale _ 1. ^(compositionRectangle width - (textStyle rightMarginTabAt: marginTabsLevel) - rightIndent) * scale! rightMarginForDisplay "Build the right margin for a line." "Depends upon compositionRectangle rightSide, marginTabsLevel, and right indent." | scale | scale _ 1. ^(compositionRectangle right - rightIndent - (textStyle rightMarginTabAt: marginTabsLevel)) * scale! textAt: lineIndex "Answer the text for the specified line." ^ text! topAtLineIndex: lineIndex "Set the top y of the line given by the argument lineIndex." ^compositionRectangle top + (lineIndex - 1 * textStyle lineGrid)! trimLinesTo: lastLineInteger (lastLineInteger + 1 to: lastLine) do: [:i | lines at: i put: nil]. (lastLine _ lastLineInteger) < (lines size // 2) ifTrue: [lines _ lines copyFrom: 1 to: lines size - (lines size // 2)]! updateCompositionHeight "Mainly used to insure that intersections with compositionRectangle work." compositionRectangle height: textStyle lineGrid * lastLine. (text size ~= 0 and: [(text at: text size) = CR]) ifTrue: [compositionRectangle height: compositionRectangle height + textStyle lineGrid]! visibleRectangle ^ (clippingRectangle intersect: compositionRectangle) intersect: destinationForm boundingBox! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Paragraph class instanceVariableNames: ''! !Paragraph class methodsFor: 'instance creation'! initialize "Initialize the class variable." "Paragraph initialize." DefaultCompositionRectangle _ 0@0 corner: 10000@10000.! new "Do not allow an uninitialized view. Create with text that has no characters." ^self withText: '' asText! withText: aText "Answer an instance of the receiver with text set to aText and style set to the system's default text style." ^self withText: aText style: DefaultTextStyle copy! withText: aText style: aTextStyle "Answer an instance of the receiver with text set to aText and style set to aTextStyle." ^super new compositionRectangle: DefaultCompositionRectangle text: aText style: aTextStyle offset: (0@0) outputMedium: #Display fitWidth: true! withText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect "Answer an instance of the receiver with text set to aText , style set to aTextStyle, the composition rectangle set to compRect, and the clipping rectangle to clipRect." | para | para _ super new compositionRectangle: compRect text: aText style: aTextStyle offset: (0@0) outputMedium: #Display fitWidth: false. para clippingRectangle: clipRect. ^para! ! !Paragraph class methodsFor: 'examples'! paragraphSampler "This simple example illustrates how to display a few lines of text on the screen at the current cursor point." "Paragraph paragraphSampler." | para point | point _ Sensor waitButton. para _ 'this is the first line of characters and this is the second line comprising this Paragraph.' asParagraph. para displayOn: Display at: point. para displayOn: Display at: point + (0 @ para height) clippingBox: Display boundingBox rule: Form over mask: Form gray! ! Paragraph initialize! ScrollController subclass: #ParagraphEditor instanceVariableNames: 'paragraph startBlock stopBlock beginTypeInBlock emphasisHere initialText selectionShowing ' classVariableNames: 'CurrentEvent CurrentSelection Keyboard PreviousSelections TextEditorYellowButtonMenu TextEditorYellowButtonMessages UndoSelection ' poolDictionaries: 'TextConstants ' category: 'Interface-Text'! ParagraphEditor comment: 'I contain the main handling of text editing. I ought to be used only on smallish paragraphs. Instance Variables paragraph A pointer to the text form being edited. The Paragraph is optimized for managing replacements in it''s stylized string and for scrolling. startBlock stopBlock These variables contain the string indices, characters, and bounding boxes of the starting and stopping characters in the stylized string which will be operated upon by the next command. beginTypeInBlock Used to manage typing and to distinguish selection arising from the last characters typed in from selection with the mouse or which is the result of some special keystroke. emphasisHere Used to denote the emphasis change at the current startBlock. initialText A copy of the string held by the Paragraph at the time the text editor was instantiated. It is currently used to manage the editing of Smalltalk code, and is reinstalled in the Paragraph when a "cancel" is executed and is overwritten when an "accept" is executed. selectionShowing true = on, false = off. Since selection involves raw modification of the bits in the destinationForm of the Paragraph, it must be monitored closely and with care. Class Variables: CurrentEvent CurrentSelection Keyboard PreviousSelections TextEditorYellowButtonMenu TextEditorYellowButtonMessages UndoSelection '! !ParagraphEditor methodsFor: 'initialize-release'! changeParagraph: aParagraph "Install aParagraph as the one to be edited by the receiver." paragraph _ aParagraph. self resetState! initialize super initialize. self initializeYellowButtonMenu! resetState "Establish the initial conditions for editing the paragraph: place caret before first character, set the emphasis to that of the first character, and save the paragraph for purposes of canceling." | insetDisplayBox | insetDisplayBox _ paragraph compositionRectangle. startBlock _ CharacterBlock stringIndex: 1 character: nil boundingRectangle: (insetDisplayBox topLeft extent: 0 @ 0). stopBlock _ startBlock copy. beginTypeInBlock _ startBlock copy. self setEmphasisHere. selectionShowing _ false. initialText _ paragraph text copy! ! !ParagraphEditor methodsFor: 'basic control sequence'! controlInitialize super controlInitialize. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. self initializeSelection. beginTypeInBlock _ nil.! controlTerminate super controlTerminate. self closeTypeIn ifTrue: [startBlock _ stopBlock copy]. "so leaving and entering window won't select last type-in"! ! !ParagraphEditor methodsFor: 'control defaults'! controlActivity self scrollBarContainsCursor ifTrue: [self scroll] ifFalse: [self processKeyboard. self processMouseButtons].! isControlActive ^super isControlActive & sensor blueButtonPressed not! processKeyset "clever trick to remove this method after it is called for the last time" ParagraphEditor removeSelector: #processKeyset! ! !ParagraphEditor methodsFor: 'scrolling'! canScroll ^true! scroll self updateMarker. super scroll! scrollAmount ^sensor cursorPoint y - scrollBar top! scrollBy: heightToMove "Move the paragraph by the amount, heightToMove, and reset the text selection." self deselect. paragraph scrollBy: heightToMove. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. self select! scrollToTop "Scroll so that the paragraph is at the top of the view." self scrollView: (paragraph clippingRectangle top - paragraph compositionRectangle top)! scrollView: anInteger | maximumAmount minimumAmount amount | maximumAmount _ paragraph clippingRectangle top - paragraph compositionRectangle top max: 0. minimumAmount _ paragraph clippingRectangle top + paragraph lineGrid - paragraph compositionRectangle bottom min: 0. amount _ (anInteger min: maximumAmount) max: minimumAmount. amount ~= 0 ifTrue: [self deselect. self scrollBy: amount negated. self select].! viewDelta ^paragraph clippingRectangle top - paragraph compositionRectangle top - ((marker top - scrollBar inside top) asFloat / scrollBar inside height asFloat * self scrollRectangleHeight asFloat) roundTo: paragraph lineGrid! ! !ParagraphEditor methodsFor: 'marker adjustment'! computeMarkerRegion paragraph compositionRectangle height = 0 ifTrue: [^0@0 extent: 10 @ scrollBar inside height] ifFalse: [^0@0 extent: 10 @ ((paragraph clippingRectangle height asFloat / self scrollRectangleHeight * scrollBar inside height) rounded min: scrollBar inside height)]! markerDelta ^marker top - scrollBar top - ((paragraph clippingRectangle top - paragraph compositionRectangle top) asFloat / (self scrollRectangleHeight max: 1) asFloat * scrollBar height asFloat) rounded! updateMarker "A variation of moveMarker--only redisplay the marker in the scrollbar if an actual change has occurred in the positioning of the paragraph." | newMarkerRegion | newMarkerRegion _ self computeMarkerRegion. newMarkerRegion extent ~= marker region extent ifTrue: [self markerRegion: newMarkerRegion. self moveMarker]! ! !ParagraphEditor methodsFor: 'sensor access'! processBlueButton "The user pressed the blue button on the mouse. Determine what action to take." ^self! processKeyboard "Determine whether the user pressed the keyboard. If so, read the keys." sensor keyboardPressed ifTrue: [self readKeyboard]! processMouseButtons "Determine whether the user pressed any mouse button. For each possible button, determine what actions to take." sensor redButtonPressed ifTrue: [self processRedButton]. sensor yellowButtonPressed ifTrue: [self processYellowButton]. sensor blueButtonPressed ifTrue: [self processBlueButton]! processRedButton "The user pressed a red mouse button, meaning create a new text selection. Highlighting the selection is carried out by the paragraph itself. Double clicking causes a selection of the area between the nearest enclosing delimitors; extension is based on both ends if different." | selectionBlocks | self deselect. self closeTypeIn. selectionBlocks _ paragraph mouseSelect: startBlock to: stopBlock. selectionShowing _ true. startBlock _ selectionBlocks at: 1. stopBlock _ selectionBlocks at: 2. self updateMarker. self setEmphasisHere! processYellowButton "User pressed the yellow button on the mouse. Determine what actions to take." self yellowButtonActivity! ! !ParagraphEditor methodsFor: 'accessing'! copySelection: aText CurrentSelection _ UndoSelection _ aText! text "Answer the text of the paragraph being edited." ^paragraph text! ! !ParagraphEditor methodsFor: 'displaying'! display "Redisplay the receiver's paragraph." | selectionState | selectionState _ selectionShowing. self deselect. paragraph displayOn: Display. selectionState ifTrue: [self select]! displayAt: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Redisplay the paragraph starting at aDisplayPoint, clipped by the rectangle, clipRectangle. The characters are displayed with respect to the rule, ruleInteger, and the mask, aForm." self deselect. paragraph displayOn: Display at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm. self select! ! !ParagraphEditor methodsFor: 'menu messages'! accept "Save the current text of the text being edited as the current acceptable version for purposes of canceling." initialText _ paragraph text copy! again "Text subsititution. If the left shift key is down, the substitution is made throughout the entire Paragraph. Otherwise, only the next possible subsitution is made." | many | many _ sensor leftShiftDown. self deselect. self closeTypeIn. self select. many ifTrue: [[self againOnce] whileTrue] ifFalse: [self againOnce ifFalse: [self flash]]. self moveMarker! align "Align text according to the next greater alignment value--cycling among left flush, right flush, center, justified." self deselect. paragraph toggleAlignment. paragraph displayOn: Display. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. self select! cancel "Restore the text of the paragraph to be the text saved since initialization or the last accept." self controlTerminate. UndoSelection _ paragraph text. view clearInside. self changeParagraph: (paragraph text: initialText). paragraph displayOn: Display. self scrollToTop. self controlInitialize! changeFont "Display menu of fonts and change selection to the choice." | choice | choice _ (PopUpMenu labelList: (Array with: (paragraph textStyle fontArray collect: [:f | f fontName]))) startUp. choice = 0 ifTrue: [^self]. self deselect. startBlock stringIndex = stopBlock stringIndex ifTrue: [emphasisHere _ choice. ^self select]. self replaceSelectionWith: (Text string: self selection asString emphasis: choice). self closeTypeIn. self select! changeTextStyle "Display menu of text styles and change to the choice." |styles choice| styles _ TextStyle styles asSortedCollection. choice _(PopUpMenu labelList: (Array with: styles)) startUp. choice = 0 ifTrue: [^self]. paragraph textStyle: (TextStyle styleNamed: (styles at: choice)). paragraph recomposeIn: (view insetDisplayBox insetBy: view paragraphInset) clippingBox: view insetDisplayBox. self display! copySelection "Copy the current selection and store it in the shared buffer." CurrentSelection _ UndoSelection _ self selection. self addPreviousSelection: CurrentSelection! cut self deselect. self replaceSelectionWith: Text new. self selectAndScroll. self updateMarker. CurrentSelection _ UndoSelection copy. self addPreviousSelection: CurrentSelection! fit "Make the bounding rectangle of the paragraph contain all the text while not changing the width of the view of the paragraph." self deselect. paragraph clearVisibleRectangle. paragraph fit. paragraph displayOn: Display. paragraph outline. self select. self updateMarker! paste "Paste the text from the shared buffer over the current selection and redisplay if necessary. If the left shift key is down, present the user with a menu of the last few selections." | menuSelection textToPaste | sensor leftShiftDown ifTrue: [PreviousSelections isEmpty ifTrue: [^self]. menuSelection _ (PopUpMenu labelList: (Array with: (PreviousSelections collect: [:aText | (aText string contractTo: 40) collect: [:char | char isSeparator ifTrue: [$ ] ifFalse: [char]]]))) startUp. menuSelection = 0 ifTrue: [^self]. textToPaste _ CurrentSelection _ PreviousSelections at: menuSelection. self promotePreviousSelectionAt: menuSelection] ifFalse: [textToPaste _ CurrentSelection]. self performPasteAction: textToPaste "so subclasses can do other paste-like actions"! performPasteAction: aString "Here we perform the default paste action for paragraphs. Any subclass of us can choose to override this default in favor of some other paste-like action." self deselect. self closeTypeInAndSelectIf: false. self replaceSelectionWith: aString. self selectAndScroll. self updateMarker.! promotePreviousSelectionAt: index "Make the PreviousSelection at index be the first item on the PreviousSelections list." | aText | aText _ PreviousSelections at: index. PreviousSelections removeAtIndex: index. PreviousSelections addFirst: aText! undo "Reset the state of the paragraph prior to the previous cut or paste edit." self deselect. self closeTypeIn. self replaceSelectionWith: UndoSelection. self selectAndScroll. self updateMarker! ! !ParagraphEditor methodsFor: 'editing'! backspace: characterStream key: aChar "Backspace over the last character--i.e., cut the previous character." | startIndex | startBlock stringIndex < stopBlock stringIndex ifTrue: [self cut. ^true] ifFalse: [characterStream isEmpty ifTrue: [startIndex _ 1 max: startBlock stringIndex - 1. startBlock _ paragraph characterBlockForIndex: startIndex. beginTypeInBlock _ paragraph characterBlockForIndex: (beginTypeInBlock stringIndex min: startIndex). self cut. ^true] ifFalse: [characterStream skip: -1]. ^false]! backWord: characterStream key: aChar "Backspace over the last word--i.e., cut the last word. Initiated by ctrl w" | startIndex | characterStream isEmpty ifFalse: [self replaceSelectionWith: (Text string: characterStream contents emphasis: emphasisHere). startBlock _ stopBlock copy. characterStream reset]. startIndex _ 1 max: startBlock stringIndex - 1. [startIndex > 1 and: [(paragraph text at: startIndex - 1) asCharacter tokenish]] whileTrue: [startIndex _ startIndex - 1]. startBlock _ paragraph characterBlockForIndex: startIndex. beginTypeInBlock _ paragraph characterBlockForIndex: (beginTypeInBlock stringIndex min: startIndex). ^false! changeEmphasis: characterStream key: aChar "Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change." | oldCode newCode | oldCode _ paragraph text emphasisAt: startBlock stringIndex. ((newCode _ FontKeys indexOf: (aChar asciiValue)) = 0) ifTrue: [newCode _ self emphasisDefault: oldCode keyedTo: aChar]. (((paragraph textStyle isFontUnderlined: oldCode) and: [aChar ~= CtrlShiftMinus "--unUnderline"]) and: [aChar ~= Ctrlx "clear emphasis"]) ifTrue: ["If font being replaced was underlined, use underlined version of new font, unless unUnderline has just been struck" newCode _ paragraph textStyle underlinedFontFor: newCode]. startBlock stringIndex = stopBlock stringIndex ifTrue: "only change emphasisHere while typing" [emphasisHere _ newCode. self select. ^true]. self replaceSelectionWith: (Text string: self selection asString emphasis: (newCode max: 1)). self closeTypeIn. self select. ^true! cr: characterStream key: aChar ^self normalCharacter: characterStream key: aChar! cut: characterStream key: aChar "Cut out the current text selection." self cut. ^true! displayDate: characterStream key: aChar "Replace the current text selection with today's date--initiated by ctrl d." characterStream nextPutAll: Date today printString. ^false! displayIfFalse: characterStream key: aChar "Replace the current text selection with the text 'ifFalse:'--initiated by ctrl f." characterStream nextPutAll: 'ifFalse:'. ^false! displayIfTrue: characterStream key: aChar "Replace the current text selection with the text 'ifTrue:'--initiated by ctrl t." characterStream nextPutAll: 'ifTrue:'. ^false! enclose: characterStream key: aChar "Insert or remove bracket characters around the current selection. If null selection, then make a pair of brackets with cursor inside" | char left right startIndex stopIndex which text oldSelection | char _ aChar asciiValue. characterStream reset. self deselect. startIndex _ startBlock stringIndex. stopIndex _ stopBlock stringIndex. which _ EncloseKeys indexOf: char. left _ '([<{"''' at: which. right _ ')]>}"''' at: which. text _ paragraph text. ((startIndex > 1 and: [stopIndex <= text size]) and: [(text at: startIndex-1) = left and: [(text at: stopIndex) = right]]) ifTrue: ["already enclosed; strip off brackets" oldSelection _ self selection. self selectFrom: startIndex-1 to: stopIndex; deselect. self replaceSelectionWith: oldSelection. self selectFrom: stopIndex-1 to: stopIndex-2] ifFalse: ["not enclosed; enclose by matching brackets" self selectAt: startIndex; deselect. self setEmphasisHere. self replaceSelectionWith: (Text string: (String with: left) emphasis: emphasisHere). self selectAt: stopIndex+1; deselect. self setEmphasisHere. self replaceSelectionWith: (Text string: (String with: right) emphasis: emphasisHere). self selectFrom: stopIndex+1 to: stopIndex]. ^ true! leaveBrackets: characterStream key: aChar "Jump typing cursor over a close-bracket character" | stopIndex nextChar | stopBlock character notNil ifTrue: [stopIndex _ stopBlock stringIndex. nextChar _ paragraph text at: stopIndex. (')]>}"''' includes: nextChar) ifFalse: [^false]. self deselect. startBlock _ stopBlock _ paragraph characterBlockForIndex: stopIndex+1. self select] ifFalse: [self select]. ^ true! normalCharacter: characterStream key: aChar "A nonspecial character is to be added to the stream of characters." characterStream nextPut: aChar. ^false! paste: characterStream key: aChar "Replace the current text selection by the text in the shared buffer." self paste. ^true! readKeyboard | typeAhead currentCharacter| self deselect. typeAhead _ WriteStream on: (String new: 128). beginTypeInBlock == nil ifTrue: [UndoSelection _ self selection. beginTypeInBlock _ startBlock copy]. [sensor keyboardPressed] whileTrue: [CurrentEvent _ sensor keyboardEvent. currentCharacter _ CurrentEvent keyCharacter. (self perform: (Keyboard at: currentCharacter asciiValue + 1) with: typeAhead with: currentCharacter) ifTrue: [^self]]. self replaceSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere). startBlock _ stopBlock copy. self selectAndScroll! selectCurrentTypeIn: characterStream key: aChar "The user just finished typing in some text and then typed the esc key. The typed text becomes the current text selection." CurrentEvent hasCtrl ifTrue: [^self enclose: characterStream key: aChar]. characterStream isEmpty ifTrue: [self deselect] ifFalse: [self replaceSelectionWith: (Text string: characterStream contents emphasis: emphasisHere). startBlock _ stopBlock copy]. self closeTypeIn. startBlock = stopBlock ifFalse: [startBlock _ paragraph characterBlockForIndex: stopBlock stringIndex - CurrentSelection size]. self select. ^true! tab: characterStream key: aChar CurrentEvent hasCtrl ifTrue: [^self changeEmphasis: characterStream key: aChar] ifFalse: [^self normalCharacter: characterStream key: aChar]! ! !ParagraphEditor methodsFor: 'selecting'! deselect "If the text selection is visible on the screen, reverse its highlight." selectionShowing ifTrue: [self reverseSelection]! findAndSelect: aString | index | index _ paragraph text findString: aString startingAt: stopBlock stringIndex. index = 0 ifTrue: [^false]. self selectAndScrollFrom: index to: index + aString size-1. ^true! initializeSelection "Do the initial activity when starting up the receiver. For example, in the ParagraphEditor highlight the current selection." self select! recomputeSelection "eg after changing the composition rectangle of the paragraph" self deselect. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. selectionShowing_ false! reverseSelection "Reverse the valence of the current selection highlighting." selectionShowing _ selectionShowing not. startBlock = stopBlock ifTrue: [paragraph displayCaretAt: startBlock topLeft + (0 @ paragraph textStyle baseline)] ifFalse: [paragraph reverseFrom: startBlock to: stopBlock]! select "If the text selection is visible on the screen, highlight it." selectionShowing ifFalse: [self reverseSelection]! selectAndScroll "Scroll until the selection is in the view and then highlight it." | lineHeight deltaY clippingRectangle | lineHeight _ paragraph textStyle lineGrid. clippingRectangle _ paragraph clippingRectangle. deltaY _ stopBlock top - clippingRectangle top. deltaY >= 0 ifTrue: [deltaY _ stopBlock bottom - clippingRectangle bottom max: 0]. "check if stopIndex below bottom of clippingRectangle" deltaY ~= 0 ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight) * deltaY sign]. self select! selectAndScrollFrom: start to: stop self deselect. startBlock _ paragraph characterBlockForIndex: start. stopBlock _ paragraph characterBlockForIndex: stop + 1. self selectAndScroll! selectAt: characterIndex "Place the character before the character at position characterIndex. Make certain the selection is in the view." self deselect. startBlock _ paragraph characterBlockForIndex: characterIndex. stopBlock _ startBlock copy. self selectAndScroll! selectFrom: start to: stop "The text selection starts at the character at position start and ends at the character at position stop." self deselect. startBlock _ paragraph characterBlockForIndex: start. stopBlock _ paragraph characterBlockForIndex: stop+1. self selectAndScroll! selection "Answer the text in the paragraph that is currently selected." ^paragraph text copyFrom: startBlock stringIndex to: stopBlock stringIndex - 1! selectionAsStream "Answer a ReadStream on the text in the paragraph that is currently selected." ^ReadStream on: paragraph text asString from: startBlock stringIndex to: stopBlock stringIndex - 1! ! !ParagraphEditor methodsFor: 'indicating'! flash "Causes the view of he paragraph to complement twice in succession." paragraph flash! ! !ParagraphEditor methodsFor: 'copying'! copy "Answer a copy of the receiver that goes one level deeper into the paragraph. " | p c | p _ paragraph. paragraph _ paragraph copy. c _ super copy. paragraph _ p. ^c! ! !ParagraphEditor methodsFor: 'private'! addPreviousSelection: aText "Save away a selection for use by leftShift-paste. Don't save it if it's already on the list, or if it is all white space. Save only a few." (PreviousSelections includes: aText) ifTrue: [^self]. (aText detect: [:char | char isSeparator not] ifNone: [nil]) == nil ifTrue: [^self]. PreviousSelections size >= 5 ifTrue: [PreviousSelections removeLast]. PreviousSelections addFirst: aText! againOnce | nextStartIndex | nextStartIndex _ paragraph text findString: UndoSelection startingAt: stopBlock stringIndex. nextStartIndex = 0 ifTrue: [^false]. self deselect. startBlock _ paragraph characterBlockForIndex: nextStartIndex. stopBlock _ paragraph characterBlockForIndex: nextStartIndex + UndoSelection size. CurrentSelection = UndoSelection ifFalse: [self replaceSelectionWith: CurrentSelection]. self selectAndScroll. ^true! closeTypeIn ^ self closeTypeInAndSelectIf: true! closeTypeInAndSelectIf: aBoolean beginTypeInBlock ~~ nil ifTrue: [(beginTypeInBlock < startBlock) & aBoolean ifTrue: [CurrentSelection _ paragraph text copyFrom: beginTypeInBlock stringIndex to: startBlock stringIndex - 1. startBlock _ beginTypeInBlock copy. self addPreviousSelection: CurrentSelection]. beginTypeInBlock _ nil. ^true] ifFalse: [^false]! emphasisDefault: oldEmphasisCode keyedTo: keyboardCharacter "Some default ways to get common forms of emphasis -- returns a new emphasis code. Subroutine for changeEmphasis. If anyone else uses, please note here." keyboardCharacter = CtrlMinus "underline" ifTrue: [^ paragraph textStyle underlinedFontFor: oldEmphasisCode]. keyboardCharacter = CtrlShiftMinus "unUnderline" ifTrue: [^ paragraph textStyle unUnderlinedFontFor: oldEmphasisCode]. keyboardCharacter = Ctrlb "Bold" ifTrue: [^ paragraph textStyle boldFontFor: oldEmphasisCode]. keyboardCharacter = CtrlB "unBold" ifTrue: [^ paragraph textStyle basalFontFor: oldEmphasisCode]. keyboardCharacter = Ctrli "Italic" ifTrue: [^ paragraph textStyle italicFontFor: oldEmphasisCode]. keyboardCharacter = CtrlI "unItalic" ifTrue: [^ paragraph textStyle basalFontFor: oldEmphasisCode]. keyboardCharacter = Ctrlx "clear emphasis, go to basal font" ifTrue: [^ paragraph textStyle basalFontFor: oldEmphasisCode].! initializeYellowButtonMenu self yellowButtonMenu: TextEditorYellowButtonMenu yellowButtonMessages: TextEditorYellowButtonMessages! replaceSelectionWith: aText beginTypeInBlock == nil ifTrue: [UndoSelection _ self selection]. paragraph replaceFrom: startBlock stringIndex to: stopBlock stringIndex - 1 with: aText displaying: true. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: startBlock stringIndex + aText size! scrollRectangleHeight ^paragraph compositionRectangle height + paragraph clippingRectangle height - paragraph lineGrid! setEmphasisHere emphasisHere _ paragraph text emphasisAt: startBlock stringIndex! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ParagraphEditor class instanceVariableNames: ''! !ParagraphEditor class methodsFor: 'class initialization'! initialize "Initialize the yellow button menu information, the keyboard map for special control characters, and the shared buffers for copying text across views and managing undo." CurrentSelection _ UndoSelection _ Text new. PreviousSelections _ OrderedCollection new. TextEditorYellowButtonMenu _ PopUpMenu labels: 'again\undo\copy\cut\paste\accept\cancel\align\fit' withCRs lines: #(2 5 7). TextEditorYellowButtonMessages _ #(again undo copySelection cut paste accept cancel align fit ). self initializeDispatchTable! initializeDispatchTable "Initialize the keyboard dispatch table" "ParagraphEditor initializeDispatchTable." Keyboard _ Array new: 256. Keyboard atAllPut: #normalCharacter:key:. Keyboard at: Cut asciiValue + 1 put: #backspace:key:. Keyboard at: CR asciiValue + 1 put: #cr:key:. Keyboard at: Paste asciiValue + 1 put: #paste:key:. Keyboard at: BS asciiValue + 1 put: #backspace:key:. Keyboard at: Ctrlw asciiValue + 1 put: #backWord:key:. Keyboard at: Ctrlt asciiValue + 1 put: #displayIfTrue:key:. Keyboard at: Ctrlf asciiValue + 1 put: #displayIfFalse:key:. Keyboard at: Ctrld asciiValue + 1 put: #displayDate:key:. "ctrl-d" FontKeys do: [:i | Keyboard at: i + 1 put: #changeEmphasis:key:]. Keyboard at: CtrlMinus asciiValue + 1 put: #changeEmphasis:key:. Keyboard at: CtrlShiftMinus asciiValue + 1 put: #changeEmphasis:key:. Keyboard at: Ctrlb asciiValue + 1 put: #changeEmphasis:key:. Keyboard at: CtrlB asciiValue + 1 put: #changeEmphasis:key:. Keyboard at: CtrlI asciiValue + 1 put: #changeEmphasis:key:. Keyboard at: Ctrlx asciiValue + 1 put: #changeEmphasis:key:. Keyboard at: Tab asciiValue + 1 put: #tab:key:. EncloseKeys do: [:i | Keyboard at: i + 1 put: #enclose:key:]. "this must go after the enclose keys because of ^[ and ESC being the same thing" Keyboard at: ESC asciiValue + 1 put: #selectCurrentTypeIn:key:.! ! !ParagraphEditor class methodsFor: 'instance creation'! new "Answer a new instance of me with a null Paragraph to be edited." ^ self newParagraph: '' asParagraph! newParagraph: aParagraph "Answer an instance of me with aParagraph as the text to be edited. " | aParagraphEditor | aParagraphEditor _ super new. aParagraphEditor changeParagraph: aParagraph. ^aParagraphEditor! ! !ParagraphEditor class methodsFor: 'selection access'! currentSelection "Answer the current selection." ^CurrentSelection! ! !ParagraphEditor class methodsFor: 'dispatch table access'! dispatchTable "Return the keyboard dispatch table" ^Keyboard! ! ParagraphEditor initialize! Object subclass: #ParseNode instanceVariableNames: 'comment ' classVariableNames: 'Bfp CodeBases CodeLimits Dup EndMethod EndRemote Jmp JmpLimit JmpLong LdFalse LdInstLong LdInstType LdLitIndType LdLitType LdMinus1 LdNil LdSelf LdSuper LdTempType LdThisContext LdTrue NodeFalse NodeNil NodeSelf NodeSuper NodeThisContext NodeTrue Pop Send SendLimit SendLong SendPlus SendType ShortStoP StdLiterals StdSelectors StdVariables Store StorePop ' poolDictionaries: '' category: 'System-Compiler'! ParseNode comment: 'This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode, which is the last alphabetically.'! !ParseNode methodsFor: 'accessing'! comment ^comment! comment: newComment "self halt." comment _ newComment! ! !ParseNode methodsFor: 'testing'! canBeSpecialArgument "can I be an argument of (e.g.) ifTrue:?" ^false! canCascade ^false! isArg ^false! isReturningIf ^false! isReturnSelf ^false! isVariableReference ^false! ! !ParseNode methodsFor: 'code generation'! emitBranch: dist pop: stack on: strm stack pop: 1. dist = 0 ifTrue: [strm nextPut: Pop] ifFalse: [self emitShortOrLong: dist code: Bfp on: strm]! emitForEffect: stack on: strm self emitForValue: stack on: strm. strm nextPut: Pop. stack pop: 1! emitForReturn: stack on: strm self emitForValue: stack on: strm. strm nextPut: EndMethod! emitJump: dist on: strm dist = 0 ifFalse: [self emitShortOrLong: dist code: Jmp on: strm]! emitLong: dist code: longCode on: aStream "force a two-byte jump" | code distance | code _ longCode. distance _ dist. distance < 0 ifTrue: [distance _ distance + 1024] ifFalse: [distance > 1023 ifTrue: [distance _ -1] ifFalse: [code _ code + 4]]. distance < 0 ifTrue: [self error: 'A block compiles more than 1K bytes of code'] ifFalse: [aStream nextPut: distance // 256 + code. aStream nextPut: distance \\ 256]! emitLongJump: dist on: strm "force a two byte jump" self emitLong: dist code: JmpLong on: strm! emitShortOrLong: dist code: shortCode on: strm (1 <= dist and: [dist <= JmpLimit]) ifTrue: [strm nextPut: shortCode + dist - 1] ifFalse: [self emitLong: dist code: shortCode + 16 on: strm]! emitTrueBranch: dist pop: stack on: strm stack pop: 1. "offset for dist>0 adds another 4, so will begin at JmpLong+8" self emitLong: dist code: JmpLong+4 on: strm! sizeBranch: dist dist = 0 ifTrue: [^1]. ^self sizeShortOrLong: dist! sizeForEffect: encoder ^(self sizeForValue: encoder) + 1! sizeForReturn: encoder ^(self sizeForValue: encoder) + 1! sizeJump: dist dist = 0 ifTrue: [^0]. ^self sizeShortOrLong: dist! sizeShortOrLong: dist (1 <= dist and: [dist <= JmpLimit]) ifTrue: [^1]. ^2! ! !ParseNode methodsFor: 'encoding'! encodeSelector: selector ^nil! ! !ParseNode methodsFor: 'printing'! printCommentOn: aStream indent: indent | thisComment | comment == nil ifTrue: [^self]. 1 to: comment size do: [:index | index > 1 ifTrue: [aStream crtab: indent]. aStream nextPut: $". thisComment _ comment at: index. self printSingleComment: thisComment on: aStream indent: indent. aStream nextPut: $"]. comment _ nil! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." aStream nextPutAll: '{'. self printOn: aStream indent: 0. aStream nextPutAll: '}'! printOn: aStream indent: anInteger "If control gets here, avoid recursion loop" super printOn: aStream! printOn: aStream indent: level precedence: p self printOn: aStream indent: level! ! !ParseNode methodsFor: 'converting'! asReturnNode ^ReturnNode new expr: self! ! !ParseNode methodsFor: 'private'! nextWordFrom: aStream setCharacter: aBlock | outStream char | outStream _ WriteStream on: (String new: 16). [aStream atEnd or: [char _ aStream next. char = Character cr or: [char = Character space]]] whileFalse: [outStream nextPut: char]. aBlock value: char. ^outStream contents! printSingleComment: aString on: aStream indent: indent "Print the comment string, assuming it has been indented indent tabs. Break the string at word breaks, given the widths in the default font, at 450 points." | readStream word position lineBreak lastChar font wordWidth tabWidth spaceWidth | readStream _ ReadStream on: aString. font _ TextStyle default defaultFont. tabWidth _ TextConstants at: #DefaultTab. spaceWidth _ font widthOf: Character space. position _ indent * tabWidth. lineBreak _ 450. [readStream atEnd] whileFalse: [word _ self nextWordFrom: readStream setCharacter: [:lastCharx | lastChar _ lastCharx]. wordWidth _ 0. word do: [:char | wordWidth _ wordWidth + (font widthOf: char)]. position _ position + wordWidth. position > lineBreak ifTrue: [aStream crtab: indent. position _ indent * tabWidth + wordWidth + spaceWidth. lastChar = Character cr ifTrue: [[readStream peekFor: Character tab] whileTrue]. aStream nextPutAll: word; space] ifFalse: [aStream nextPutAll: word. readStream atEnd ifFalse: [position _ position + spaceWidth. aStream space]. lastChar = Character cr ifTrue: [aStream crtab: indent. position _ indent * tabWidth. [readStream peekFor: Character tab] whileTrue]]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ParseNode class instanceVariableNames: ''! !ParseNode class methodsFor: 'class initialization'! initialize "ParseNode initialize. VariableNode initialize." LdInstType _ 1. LdTempType _ 2. LdLitType _ 3. LdLitIndType _ 4. SendType _ 5. CodeBases _ #(0 16 32 64 208 ). CodeLimits _ #(16 16 32 32 16 ). LdSelf _ 112. LdTrue _ 113. LdFalse _ 114. LdNil _ 115. LdMinus1 _ 116. LdInstLong _ 128. Store _ 129. StorePop _ 130. ShortStoP _ 96. SendLong _ 131. LdSuper _ 133. Pop _ 135. Dup _ 136. LdThisContext _ 137. EndMethod _ 124. EndRemote _ 125. Jmp _ 144. Bfp _ 152. JmpLimit _ 8. JmpLong _ 160. SendPlus _ 176. Send _ 208. SendLimit _ 16! ! ParseNode initialize! Scanner subclass: #Parser instanceVariableNames: 'here hereType hereMark prevToken prevMark encoder requestor parseNode failBlock lastTempMark correctionDelta ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! Parser comment: 'I parse Smalltalk syntax and create a parse tree. I look one token ahead. Instance Variables: here the current token hereType the "type" of the current token hereMark position in source stream (mark) where this token began prevToken size in chars of the previous token parsed prevMark mark of previous token encoder which uses tables to decode tokens requestor object from which parsing was invoked. If not nil, this object will be sent -notify: prior to evaluating the failBlock parseNode result of current (recursive descent) parse failBlock to be evaluated in case of parse errors lastTempMark mark of last temp; points to vert bar, or last char of pattern if no temps declared correctionDelta offset of corrected code relative to source stream owing to interactive corrections so far'! !Parser methodsFor: 'public access'! parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock "Answer with a parse tree. noPattern is true for doIts (Compiler evaluate)" | meth | self init: sourceStream notifying: req failBlock: [^aBlock value]. encoder _ Encoder new init: class context: ctxt notifying: self. failBlock_ aBlock. meth _ self method: noPattern context: ctxt. encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow" ^meth! parseArgsAndTemps: aString notifying: req "(for debugger) parse the string and answer with a two-element Array containing Arrays of Strings (the arg and temp names)" aString == nil ifTrue: [^#()]. ^self initPattern: aString notifying: req return: [:pattern | (pattern at: 2) , self temporaries]! parseMethodComment: aString setPattern: aBlock "Answer with the method comment for this string" self initPattern: aString notifying: nil return: aBlock. currentComment == nil ifTrue: [^OrderedCollection new] ifFalse: [^currentComment]! parseSelector: aString "Answer with the selector for this method string" ^self initPattern: aString notifying: nil return: [:pattern | pattern at: 1]! ! !Parser methodsFor: 'expression types'! argumentName hereType == #word ifFalse: [^self expected: 'Argument name']. ^self advance! assignment "variable '_' expression => AssignmentNode" | varName var | varName _ self advance. (encoder cantStoreInto: varName) ifTrue: [^self notify: 'Cannot store into']. var _ encoder encodeVariable: varName. self advance. self expression ifFalse: [^self expected: 'Expression']. var isArg ifTrue: [^self notify: 'Cannot store into argument']. parseNode _ AssignmentNode new variable: var value: parseNode from: encoder! blockExpression " [ {:var} ( | statements) ] => BlockNode" | argNodes | argNodes _ OrderedCollection new. [self match: #colon "gather any arguments"] whileTrue: [argNodes addLast: (encoder autoBind: self argumentName)]. (argNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar']. self statements: argNodes innerBlock: true. (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']! cascade " {; message} => CascadeNode" | rcvr msgs | parseNode canCascade ifFalse: [^self expected: 'Cascading not']. rcvr _ parseNode cascadeReceiver. msgs _ OrderedCollection with: parseNode. [self match: #semicolon] whileTrue: [parseNode _ rcvr. (self messagePart: 3 repeat: false) ifFalse: [^self expected: 'Cascade']. parseNode canCascade ifFalse: [^self expected: '<- No special messages']. parseNode cascadeReceiver. msgs addLast: parseNode]. parseNode _ CascadeNode new receiver: rcvr messages: msgs! expression (hereType == #word and: [tokenType == #leftArrow]) ifTrue: [self assignment. ^true]. self primaryExpression ifFalse: [^false]. (self messagePart: 3 repeat: true) ifTrue: [hereType == #semicolon ifTrue: [self cascade]]. ^true! messagePart: level repeat: repeat | start receiver selector args precedence | [receiver _ parseNode. (hereType == #keyword and: [level >= 3]) ifTrue: [start _ self startOfNextToken. selector _ WriteStream on: (String new: 32). args _ OrderedCollection new. [hereType == #keyword] whileTrue: [selector nextPutAll: self advance. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 2 repeat: true. args addLast: parseNode]. selector _ self makeNewSymbol: selector contents startingAt: start. precedence _ 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start _ self startOfNextToken. selector _ self advance asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args _ Array with: parseNode. precedence _ 2] ifFalse: [hereType == #word ifTrue: [start _ self startOfNextToken. selector _ self makeNewSymbol: self advance startingAt: start. args _ #(). precedence _ 1] ifFalse: [^args notNil]]]. parseNode _ MessageNode new receiver: receiver selector: selector arguments: args precedence: precedence from: encoder sourceRange: (start to: self endOfLastToken). repeat] whileTrue: []. ^true! method: doit context: ctxt "pattern [ | temporaries ] block => MethodNode" | sap blk prim temps messageComment methodNode | sap _ self pattern: doit inContext: ctxt. "sap={selector, arguments, precedence}" (sap at: 2) do: [:argNode | argNode isArg: true]. temps _ self temporaries. messageComment _ currentComment. currentComment _ nil. prim _ doit ifTrue: [0] ifFalse: [self primitive]. self statements: #() innerBlock: doit. blk _ parseNode. doit ifTrue: [blk returnLast] ifFalse: [blk returnSelfIfNoOther]. hereType == #doIt ifFalse: [^self expected: 'Nothing more']. methodNode _ MethodNode new comment: messageComment. ^methodNode selector: (sap at: 1) arguments: (sap at: 2) precedence: (sap at: 3) temporaries: temps block: blk encoder: encoder primitive: prim! pattern: fromDoit inContext: ctxt "unarySelector | binarySelector arg | keyword arg {keyword arg} => {selector, arguments, precedence}" | args selector | fromDoit ifTrue: [ctxt == nil ifTrue: [^Array with: #DoIt with: #() with: 1] ifFalse: [^Array with: #DoItIn: with: (Array with: (encoder encodeVariable: 'homeContext')) with: 3]]. hereType == #word ifTrue: [^Array with: self advance asSymbol with: #() with: 1]. (hereType == #binary or: [hereType == #verticalBar]) ifTrue: [selector _ self advance asSymbol. args _ Array with: (encoder bindTemp: self argumentName). ^Array with: selector with: args with: 2]. hereType == #keyword ifTrue: [selector _ WriteStream on: (String new: 32). args _ OrderedCollection new. [hereType == #keyword] whileTrue: [selector nextPutAll: self advance. args addLast: (encoder bindTemp: self argumentName)]. ^Array with: selector contents asSymbol with: args with: 3]. ^self expected: 'Message pattern'! primaryExpression hereType == #word ifTrue: [parseNode _ encoder encodeVariable: self advance. ^true]. hereType == #leftBracket ifTrue: [self advance. self blockExpression. ^true]. hereType == #leftParenthesis ifTrue: [self advance. self expression ifFalse: [^self expected: 'expression']. (self match: #rightParenthesis) ifFalse: [^self expected: 'right parenthesis']. ^true]. (hereType == #string or: [hereType == #number or: [hereType == #literal]]) ifTrue: [parseNode _ encoder encodeLiteral: self advance. ^true]. (here == #- and: [tokenType == #number]) ifTrue: [self advance. parseNode _ encoder encodeLiteral: self advance negated. ^true]. ^false! primitive | n | (self matchToken: #<) ifFalse: [^0]. (self matchToken: 'primitive:') ifFalse: [^self expected: 'primitive:']. n _ here. (here == #- and: [tokenType == #number]) ifTrue: [self advance. n _ here negated]. ((self match: #number) and: [n isKindOf: Integer]) ifFalse: [^self expected: 'Integer']. (self matchToken: #>) ifFalse: [^self expected: '>']. ^n! statements: argNodes innerBlock: inner | stmts returns start more blockComment | stmts _ OrderedCollection new. "give initial comment to block, since others trail statements" blockComment _ currentComment. currentComment _ nil. returns _ false. more _ hereType ~~ #rightBracket. [more] whileTrue: [start _ self startOfNextToken. (returns _ self match: #upArrow) ifTrue: [self expression ifFalse: [^self expected: 'Expression to return']. self addComment. stmts addLast: (ReturnNode new expr: parseNode encoder: encoder sourceRange: (start to: self endOfLastToken))] ifFalse: [self expression ifTrue: [self addComment. stmts addLast: parseNode] ifFalse: [self addComment. stmts size = 0 ifTrue: [stmts addLast: (encoder encodeVariable: (inner ifTrue: ['nil'] ifFalse: ['self']))]]]. returns ifTrue: [(hereType == #rightBracket or: [hereType == #doIt]) ifFalse: [^self expected: 'End of block']]. more _ returns not and: [self match: #period]]. parseNode _ BlockNode new arguments: argNodes statements: stmts returns: returns from: encoder sourceEnd: self endOfLastToken+1. parseNode comment: blockComment. ^true! temporaries "[ '|' (variable) ] (variable, ..., variable)* " | vars | (self match: #verticalBar) ifFalse: [lastTempMark _ self bareEndOfLastToken. ^#()]. "no temps" (self match: #verticalBar) ifTrue: [lastTempMark _ self endOfLastToken. ^#()]. "empty temps" vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #verticalBar) ifTrue: [lastTempMark _ self endOfLastToken. ^vars]. ^self expected: 'Vertical bar'! xprimitive | n | (self matchToken: #<) ifFalse: [^0]. (self matchToken: 'primitive:') ifFalse: [^self expected: 'primitive:']. n _ here. ((self match: #number) and: [n isKindOf: Integer]) ifFalse: [^self expected: 'Integer']. (self matchToken: #>) ifFalse: [^self expected: '>']. ^n! ! !Parser methodsFor: 'comparing'! match: type "Answer with true if next tokens type matches" hereType == type ifTrue: [self advance. ^true]. ^false! matchToken: thing "matches the token, not its type" here = thing ifTrue: [self advance. ^true]. ^false! ! !Parser methodsFor: 'scanning'! advance | this | prevMark _ hereMark. prevToken _ "Now means prev size" (hereType == #number) | (hereType == #string) ifTrue: [mark - prevMark] ifFalse: [here size]. this _ here. here _ token. hereType _ tokenType. hereMark _ mark. self scanToken. ^this! bareEndOfLastToken ^ prevMark + prevToken - 1 + correctionDelta! endOfLastToken hereType == #doIt ifTrue: [^ prevMark + prevToken + 1 + correctionDelta]. tokenType == #doIt ifTrue: [^ prevMark + prevToken + correctionDelta]. ^ prevMark + prevToken - 1 + correctionDelta! startOfNextToken "return starting position in source of next token" hereType == #doIt ifTrue: [^source position + 1 + correctionDelta]. ^hereMark + correctionDelta! ! !Parser methodsFor: 'temporaries'! bindTemp: name ^name! ! !Parser methodsFor: 'error handling'! abort | exitBlock | encoder == nil ifFalse: [encoder release. encoder _ nil]. "break cycle" exitBlock _ failBlock. failBlock _ nil. ^exitBlock value! editor ^ requestor editor! expected: aString "Notify a problem at token 'here'" tokenType == #doIt ifTrue: [hereMark _ hereMark + 1]. hereType == #doIt ifTrue: [hereMark _ hereMark + 1]. ^ self notify: aString , ' expected' at: hereMark! notify: aString "Notify problem at token before 'here'" ^self notify: aString at: prevMark! notify: string at: location requestor == nil ifFalse: [requestor notify: string , ' ->' at: location + correctionDelta]. self abort! offEnd: aString " notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!" ^ self notify: aString at: mark! ! !Parser methodsFor: 'code view interaction'! pasteTemp: name | editor | editor _ self editor. (lastTempMark > 0 and: [(editor text at: lastTempMark) = $|]) ifTrue: "Paste in before vertical bar" [editor selectAt: lastTempMark. self replaceEditSelectionWith: name , ' '. lastTempMark _ lastTempMark + name size + 1] ifFalse: "No temp declarations yet; have to insert whole line" [editor selectAt: lastTempMark+1. self replaceEditSelectionWith: (String with: Character cr) , ' | ' , name , ' | '. lastTempMark _ lastTempMark + name size + 6]! replaceEditSelectionWith: aString | editor | editor _ self editor. correctionDelta _ correctionDelta + aString size - editor selection size. editor deselect; replaceSelectionWith: aString asText! selectVariable: name | lastP firstP | lastP _ self bareEndOfLastToken. firstP _ lastP - name size + 1. (firstP = lastP and: [ prevMark <= 0 or: [(String with: (source contents at: prevMark)) ~= name]]) ifTrue: [lastP _ firstP _ firstP + 1]. self editor selectFrom: firstP to: lastP! ! !Parser methodsFor: 'private'! addComment parseNode ~~ nil ifTrue: [parseNode comment: currentComment. currentComment _ nil]! init: sourceStream notifying: req failBlock: aBlock requestor _ req. failBlock _ aBlock. correctionDelta _ 0. super scan: sourceStream. prevMark _ hereMark _ mark. self advance! initPattern: aString notifying: req return: aBlock | result | self init: (ReadStream on: aString asString) notifying: req failBlock: [^nil]. encoder _ self. result _ aBlock value: (self pattern: false inContext: nil). encoder _ failBlock _ nil. "break cycles" ^result! makeNewSymbol: aString startingAt: start | editor index menu sym oldText newText oldStream oldKey | Symbol hasInterned: aString ifTrue: [:symbol | ^ symbol]. (editor _ self editor) isNil ifTrue: [^ aString asSymbol]. editor selectFrom: start to: self endOfLastToken. Cursor normal show. index _ (menu _ ActionMenu labels: 'proceed as is\correct it\abort' withCRs selectors: #(proceed correct abort)) startUp: #anyButton withHeading: ' ' , (aString contractTo: 20) , ' is a new message '. index = 0 ifTrue: [^ self notify: '']. (menu selectorAt: index) == #proceed ifTrue: [^ aString asSymbol]. (menu selectorAt: index) == #correct ifTrue: [sym _ Symbol correctMessage: aString. sym == false ifTrue: [self notify: 'Couldn''t correct'. self abort]. sym == nil ifTrue: [self abort]. oldText _ editor selection. sym isKeyword ifTrue: [newText _ oldText. oldStream _ ReadStream on: aString. sym keywords do: [:newKey | oldKey _ (oldStream upTo: $:) , ':'. oldKey = newKey ifFalse: [newText _ newText copyReplaceAll: oldKey asText with: newKey asText]]] ifFalse: [newText _ oldText copyReplaceAll: aString asText with: sym asText]. self replaceEditSelectionWith: newText. ^ sym]. self abort! ! Object subclass: #ParseStack instanceVariableNames: 'position length ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! ParseStack comment: 'I keep track of the current and high position of the stack that will be needed by code being compiled. I am only used during the code generation pass of the compiler (MethodNode generate:)'! !ParseStack methodsFor: 'initialize-release'! init length _ position _ 0! ! !ParseStack methodsFor: 'accessing'! max: otherSize "Set my max length (size) to be the max of mine and otherSize" length _ length max: otherSize! pop: n (position _ position - n) < 0 ifTrue: [self error: 'Parse stack underflow']! push: n (position _ position + n) > length ifTrue: [length _ position]! size "Answer how many elements the receiver contains." ^length! ! !ParseStack methodsFor: 'results'! position ^position! ! DisplayObject subclass: #Path instanceVariableNames: 'form collectionOfPoints ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! Path comment: 'Class Path is the basic superclass of the Graphic Spatial Primitives. Spatial Primitives are used to generate "trajactories" or paths like lines and circles. Instance Variables: form the "brush" used for displaying the path collectionOfPoints of Points along the path Paths can not implement accessing offset'! !Path methodsFor: 'adding'! add: aPoint "Include aPoint as one of the receiver's elements." collectionOfPoints add: aPoint! ! !Path methodsFor: 'removing'! removeAllSuchThat: aBlock "Evaluate aBlock with each of the collectionOfPoints's as the argument. Remove each point for which aBlock evaluates to true. Answer the new instance of receiver's class." | newCollection newPath | newPath _ self species new. newCollection _ collectionOfPoints removeAllSuchThat: aBlock. newCollection do: [:point | newPath add: point]. newPath form: self form. ^newPath! ! !Path methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of the collectionOfPoints's as the argument. Collect the resulting values into a new collectionOfPoints. Answer the new instance of receivers' class." | newCollection newPath | newPath _ self species new. newCollection _ collectionOfPoints collect: aBlock. newCollection do: [:point | newPath add: point]. newPath form: self form. ^newPath! select: aBlock "Evaluate aBlock with each of the collectionOfPoints's as the argument. Collect into a new collectionOfPoints, only those elements for which aBlock evaluates to true. Answer the new instance of receivers' class." | newCollection newPath | newPath _ self species new. newCollection _ collectionOfPoints select: aBlock. newCollection do: [:point | newPath add: point]. newPath form: self form. ^newPath! ! !Path methodsFor: 'testing'! isEmpty "Answer whether the receiver contains any elements." ^collectionOfPoints isEmpty! ! !Path methodsFor: 'accessing'! at: index "Answer the point on the receiver's path at position index." ^collectionOfPoints at: index! at: index put: aPoint "Store the argument, aPoint, as the point on the receiver's path at position index." ^collectionOfPoints at: index put: aPoint! first "Answer the first point on the receiver's path." ^collectionOfPoints first! firstPoint "Answer the first point on the receiver's path." ^collectionOfPoints first! firstPoint: aPoint "Answer the argument aPoint. Replace the first element of the receiver with the new value aPoint." collectionOfPoints at: 1 put: aPoint. ^aPoint! form "Answer the receiver's form. If form is nil then a 1 x 1 black form (a black dot) is answered." | aForm | form == nil ifTrue: [aForm _ Form new extent: 1 @ 1. aForm black. ^aForm] ifFalse: [^form]! form: aForm "Make the argument, aForm, the receiver's form." form _ aForm! last "Answer the last point on the receiver's path." ^collectionOfPoints last! offset "There are basically two kinds of display objects in the system: those that, when asked to transform themselves, create a new object; and those that side effect themselves by maintaining a record of the transformation request (typically an offset). Path, like Rectangle and Point, is a display object of the first kind." self shouldNotImplement! secondPoint "Answer the second element of the receiver." ^collectionOfPoints at: 2! secondPoint: aPoint "Answer the argument aPoint. Replace the second element of the receiver with the new value aPoint." collectionOfPoints at: 2 put: aPoint. ^aPoint! size "Answer how many elements the receiver contains." ^collectionOfPoints size! thirdPoint "Answer the third element of the receiver." ^collectionOfPoints at: 3! thirdPoint: aPoint "Answer the argument aPoint. Replace the third element of the receiver with the new value aPoint." collectionOfPoints at: 3 put: aPoint. ^aPoint! ! !Path methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Display this Path--offset by aDisplayPoint, clipped by clipRectangle and the form associated with this Path will be displayed according to one of the sixteen functions of two logical variables (ruleInteger). Also the source form will be first ANDed with aForm as a mask. Does not effect the state of the Path." collectionOfPoints do: [:element | self form displayOn: aDisplayMedium at: element + aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm]! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger mask: aForm "Displays this path, translated and scaled by aTransformation." "get the scaled and translated Path." | transformedPath | transformedPath _ displayTransformation applyTo: self. transformedPath displayOn: aDisplayMedium at: 0 @ 0 clippingBox: clipRectangle rule: ruleInteger mask: aForm! ! !Path methodsFor: 'display box access'! computeBoundingBox | box computedOrigin computedExtent | form == nil ifTrue: [computedOrigin _ 0@0. computedExtent _ 0@0] ifFalse: [computedOrigin _ form offset. computedExtent _ form extent]. box _ Rectangle origin: (self at: 1) + computedOrigin extent: computedExtent. collectionOfPoints do: [:aPoint | box _ box merge: (Rectangle origin: aPoint + computedOrigin extent: computedExtent)]. ^box! ! !Path methodsFor: 'transforming'! scaleBy: aPoint "Answers with a new Path scaled by aPoint. Does not effect the current data in this Path." | newPath | newPath _ self species new: self size. newPath form: self form. collectionOfPoints do: [:element | newPath add: (aPoint x * element x) truncated @ (aPoint y * element y) truncated]. ^newPath! translateBy: aPoint "Answers with a new instance of Path whose elements are translated by aPoint. Does not effect the elements of this Path." | newPath | newPath _ self species new: self size. newPath form: self form. collectionOfPoints do: [:element | newPath add: (element x + aPoint x) truncated @ (element y + aPoint y) truncated]. ^newPath! ! !Path methodsFor: 'private'! initializeCollectionOfPoints "Initialize the collection of points on the path to be empty." collectionOfPoints _ OrderedCollection new! initializeCollectionOfPoints: anInteger "Initialize the collection of points on the path to have potential anInteger elements." collectionOfPoints _ OrderedCollection new: anInteger! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Path class instanceVariableNames: ''! !Path class methodsFor: 'instance creation'! new "Answer a new instance of the receiver that is an empty sequence." ^self basicNew initializeCollectionOfPoints! new: anInteger "Answer a new instance of the receiver that has initially anInteger elements in its sequence." ^self basicNew initializeCollectionOfPoints: anInteger! ! !Path class methodsFor: 'examples'! pathSampler "Create a Path from mouse points and displays it several ways on the display screen. Side effects up the display. Each path displays using a different form. A path is indicated by pressing the red mouse button in sequence; press any other mouse button to terminate." "Path pathSampler" | aPath aForm p1 f1 flag | aForm _ Form new extent: 2 @ 40. "creates a form one inch long" aForm black. "turns it black" aPath _ Path new. aPath form: aForm. "use the long black form for display" flag _ true. [flag] whileTrue: [Sensor waitButton. Sensor redButtonPressed ifTrue: [aPath add: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: aPath last] ifFalse: [flag _ false]]. Display white. aPath displayOn: Display. "the original path" p1 _ aPath translateBy: 0 @ 300. f1 _ Form new extent: 40 @ 40. f1 gray. p1 form: f1. p1 displayOn: Display. "the translated path" Sensor waitNoButton! ! BitBlt subclass: #Pen instanceVariableNames: 'frame location direction penDown ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! Pen comment: 'Instances of class Pen can scribble on the screen, drawing and printing at any angle. Instance Variables: frame in which the pen can draw location current location of the pen direction angle in which the pen is heading, where 270 is the top of the display, 0 is to the right penDown true if the pen leaves marks when it moves, false otherwise '! !Pen methodsFor: 'initialize-release'! defaultNib: widthInteger "Nib is the tip of a pen. This is an easy way to set up a default pen in the shape of a dot whose diameter is widthInteger." self sourceForm: (Form dotOfSize: widthInteger)! ! !Pen methodsFor: 'accessing'! direction "Answer the receiver's current direction. 270 is towards the top of the screen." ^direction! frame "Answer the rectangle in which the receiver can draw." ^frame! frame: aRectangle "Set the rectangle in which the receiver can draw to be aRectangle." frame _ aRectangle. self clipRect: aRectangle! location "Answer the Point at which the receiver is currently located." ^location! sourceForm: aForm "Set the form of the marks left by the receiver to be aForm." sourceForm _ aForm. width _ aForm width. height _ aForm height.! width: anInteger "Provide an error notification that setting the receiver's width with this message is not allowed." self error: 'Pen widths cannot be reset this way; use defaultNib: or specify a new source form using sourceForm: '! ! !Pen methodsFor: 'coloring'! black "Set the receiver's mask to the black form." self mask: Form black! fillIn: aBlock "Draw an outline expressed by the algorithm in the argument aBlock." ^ aBlock value! white "Set the receiver's mask to the white form." self mask: Form white! ! !Pen methodsFor: 'moving'! down "Set the state of the receiver's pen to down (drawing)." penDown _ true! go: distance "Move the receiver in its current direction a number of bits equal to the argument, distance. If the pen is down, a line will be drawn using the receiver's form source as the shape of the drawing brush." | dir | direction = 0 ifTrue: [^self goto: location + (distance @ 0)]. direction = 90 ifTrue: [^self goto: location + (0 @ distance)]. direction = 180 ifTrue: [^self goto: location - (distance @ 0)]. direction = 270 ifTrue: [^self goto: location - (0 @ distance)]. dir _ direction degreesToRadians. dir _ dir cos @ dir sin. self goto: dir * distance + location! goto: aPoint "Move the receiver to position aPoint. If the pen is down, a line will be drawn from the current position to the new one using the receiver's form source as the shape of the drawing brush. The receiver's set direction does not change." | old | old _ location. location _ aPoint. penDown ifTrue: [self drawFrom: old to: location]! home "Place the receiver at the center of its frame." location _ frame center! north "Set the receiver's direction to facing toward the top of the display screen. " direction _ 270! place: aPoint "Set the receiver at position aPoint. No lines are drawn." location _ aPoint! turn: degrees "Change the direction that the receiver faces by an amount equal to the argument, degrees." direction _ direction + degrees \\ 360! up "Set the state of the receiver's pen to up (not drawing)." penDown _ false! ! !Pen methodsFor: 'geometric designs'! dragon: orderNumber "Draws a dragon curve of order orderNumber in the center of the screen. Writes directly into the display bitmap." " Pen new dragon: 8." orderNumber = 0 ifTrue: [self go: 10] ifFalse: [orderNumber > 0 ifTrue: [self dragon: orderNumber - 1; turn: 90; dragon: 1 - orderNumber] ifFalse: [self dragon: -1 - orderNumber; turn: -90; dragon: 1 + orderNumber]]! filberts: n side: s "Two Hilbert curve fragments back to back form a Hilbert tile. Draw four interlocking tiles of order n directly on the display. " "Pen new filberts: 3 side: 10." | n2 | n2 _ 1 bitShift: n - 1. self up; go: 0 - n2 * s; down. 1 to: 4 do: [:i | self fillIn: [self hilbert: n side: s. self go: s. self hilbert: n side: s. self go: s]. self black. self hilbert: n side: s. self go: s. self hilbert: n side: s. self go: s. self up. self go: n2 - 1 * s. self turn: -90. self go: n2 * s. self turn: 180. self down]! hilbert: n side: s "Draws an nth level Hilbert curve directly into the display bitmap. A Hilbert curve is a space-filling curve. " "(Pen new) hilbert: 3 side: 8. (Pen new sourceForm: Cursor wait) combinationRule: Form under; hilbert: 3 side: 25." | a m | n = 0 ifTrue: [^self turn: 180]. n > 0 ifTrue: [a _ 90. m _ n - 1] ifFalse: [a _ -90. m _ n + 1]. self turn: a. self hilbert: 0 - m side: s. self turn: a; go: s. self hilbert: m side: s. self turn: 0 - a; go: s; turn: 0 - a. self hilbert: m side: s. self go: s; turn: a. self hilbert: 0 - m side: s. self turn: a! hilberts: n "Demonstrates the space-filling nature of Hilbert curves by drawing n levels of nested curves on the screen." "Display white. Pen new hilberts: 4." | s | self up; go: 128; down. 1 to: n do: [:i | s _ 256 bitShift: 0 - i. self defaultNib: n - i + 1. self up; go: 0 - s // 2; turn: -90; go: s // 2; turn: 90; down. self hilbert: i side: s. self go: s. self hilbert: i side: s. self go: s]! mandala: npoints diameter: d "On a circle of diameter d, place n points. Draw all possible connecting lines directly on the display." "Pen new mandala: 30 diameter: 400." | l points | l _ (3.14 * d / npoints) rounded. self home; up; turn: -90; go: d // 2; turn: 90; go: 0 - l // 2. points _ Array new: npoints. 1 to: npoints do: [:i | points at: i put: location. self go: l; turn: 360 // npoints]. self down. npoints // 2 to: 1 by: -1 do: [:i | 1 to: npoints do: [:j | self place: (points at: j). self goto: (points at: j + i - 1 \\ npoints + 1)]]! spiral: n angle: a "Draw a double squiral directly on the display." "Display white. Pen new spiral: 200 angle: 89; home; spiral: 200 angle: -89." 1 to: n do: [:i | self go: i; turn: a]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Pen class instanceVariableNames: ''! !Pen class methodsFor: 'instance creation'! new "Answer a new Pen that can draw on the entire display screen, with a 1X1 black pen, starting from the center of the screen and heading towards the top." | quill | quill _ super new. quill destForm: Display. quill frame: Display boundingBox. quill sourceOrigin: 0 @ 0. quill mask: Form black. quill defaultNib: 1. quill combinationRule: Form under. quill down. quill home. quill north. ^quill! ! !Pen class methodsFor: 'examples'! penSampler "Draws a spiral in gray with a pen that is 4 pixels wide." "Pen penSampler" | bic | bic _ Pen new. bic mask: Form gray. bic defaultNib: 4. bic combinationRule: Form under. 1 to: 50 do: [:i | bic go: i*4. bic turn: 89]! ! Object subclass: #Point instanceVariableNames: 'x y ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! Point comment: 'Class Point represents an x-y pair of numbers usually designating a location on the screen. Instance Variables: x y '! !Point methodsFor: 'accessing'! x "Answer the x coordinate." ^x! x: xInteger "Set the x coordinate." x _ xInteger! y "Answer the y coordinate." ^y! y: yInteger "Set the y coordinate." y _ yInteger! ! !Point methodsFor: 'comparing'! < aPoint "Answer whether the receiver is 'above and to the left' of the argument, aPoint." ^x < aPoint x and: [y < aPoint y]! <= aPoint "Answer whether the receiver is 'neither below nor to the right' of aPoint." ^x <= aPoint x and: [y <= aPoint y]! = aPoint "Answer whether the receiver's species and coordinates match those of the argument, aRectangle." self species = aPoint species ifTrue: [^x = aPoint x and: [y = aPoint y]] ifFalse: [^false]! > aPoint "Answer whether the receiver is 'below and to the right' of aPoint." ^x > aPoint x and: [y > aPoint y]! >= aPoint "Answer whether the receiver is 'neither above nor to the left' of aPoint." ^x >= aPoint x and: [y >= aPoint y]! hash "Answer a SmallInteger unique to the receiver." ^(x hash bitShift: 2) bitXor: y hash! max: aPoint "Answer the lower right corner of the rectangle uniquely defined by the receiver and aPoint." ^Point x: (x max: aPoint x) y: (y max: aPoint y)! min: aPoint "Answer the upper left corner of the rectangle uniquely defined by the receiver and aPoint." ^Point x: (x min: aPoint x) y: (y min: aPoint y)! ! !Point methodsFor: 'arithmetic'! * scale "Answer a new Point that is the product of the receiver and scale (which is a Point or Number)." | scalePoint | scalePoint _ scale asPoint. ^x * scalePoint x @ (y * scalePoint y)! + delta "Answer a new Point that is the sum of the receiver and delta (which is a Point or Number)." | deltaPoint | deltaPoint _ delta asPoint. ^x + deltaPoint x @ (y + deltaPoint y)! - delta "Answer a new Point that is the difference of the receiver and delta (which is a Point or Number)." | deltaPoint | deltaPoint _ delta asPoint. ^x - deltaPoint x @ (y - deltaPoint y)! / scale "Answer a new Point that is the quotient of the receiver and scale (which is a Point or Number)." | scalePoint | scalePoint _ scale asPoint. ^x / scalePoint x @ (y / scalePoint y)! // scale "Answer a new Point that is the quotient of the receiver and scale (which is a Point or Number)." | scalePoint | scalePoint _ scale asPoint. ^x // scalePoint x @ (y // scalePoint y)! abs "Answer a new Point whose x and y are the absolute values of the receiver's x and y." ^Point x: x abs y: y abs! ! !Point methodsFor: 'truncation and round off'! rounded "Answer a new Point that is the receiver's x and y rounded." ^x rounded @ y rounded! truncateTo: grid "Answer a new Point that is the receiver's x and y truncated to grid x and grid y." (grid isKindOf: Point) ifTrue: [^(x truncateTo: grid x) @ (y truncateTo: grid y)] ifFalse: [^(x truncateTo: grid) @ (y truncateTo: grid)]! ! !Point methodsFor: 'polar coordinates'! r "Answer the receiver's radius in polar coordinate system." ^(self dotProduct: self) sqrt! theta "Answer the angle the receiver makes with origin in radians. right is 0; down is 90." | tan theta | x = 0 ifTrue: [y >= 0 ifTrue: [^1.5708"90.0 degreesToRadians"] ifFalse: [^4.71239"270.0 degreesToRadians"]] ifFalse: [tan _ y asFloat / x asFloat. theta _ tan arcTan. x >= 0 ifTrue: [y >= 0 ifTrue: [^theta] ifFalse: [^360.0 degreesToRadians + theta]] ifFalse: [^180.0 degreesToRadians + theta]]! ! !Point methodsFor: 'point functions'! dist: aPoint "Answer the distance between aPoint and the receiver." ^(aPoint - self) r! dotProduct: aPoint "Answer a Number that is the dot product of the receiver and the argument, aPoint. That is, the two points are multiplied and the coordinates of the result summed." ^(x* aPoint x) + (y * aPoint y)! grid: aPoint "Answer a new Point to the nearest rounded grid modules specified by aPoint." | newX newY | aPoint x = 0 ifTrue: [newX _ 0] ifFalse: [newX _ x roundTo: aPoint x]. aPoint y = 0 ifTrue: [newY _ 0] ifFalse: [newY _ y roundTo: aPoint y]. ^newX @ newY! normal "Answer a new Point representing the unit vector rotated 90 deg toward the y axis." ^(y negated @ x) unitVector! pointNearestLine: point1 to: point2 "Answer the closest integer point to the receiver on the line determined by (point1, point2)." "43@55 pointNearestLine: 10@10 to: 100@200" | relPoint delta | delta _ point2 - point1. "normalize coordinates" relPoint _ self - point1. delta x = 0 ifTrue: [^point1 x@y]. delta y = 0 ifTrue: [^x@point1 y]. delta x abs > delta y abs "line more horizontal?" ifTrue: [^x@(point1 y + (x * delta y // delta x))] ifFalse: [^(point1 x + (relPoint y * delta x // delta y))@y]! transpose "Answer a new Point whose x is the receiver's y and whose y is the receiver's x." ^y @ x! truncatedGrid: aPoint "Answer a new Point to the nearest truncated grid modules specified by aPoint." ^(x truncateTo: aPoint x) @ (y truncateTo: aPoint y)! unitVector "Answer the receiver scaled to unit length." ^self / self r! ! !Point methodsFor: 'converting'! asPoint "Answer the receiver itself." ^self! corner: aPoint "Answer a new Rectangle whose origin is the receiver and whose corner is aPoint. This is one of the infix ways of expressing the creation of a rectangle." ^Rectangle origin: self corner: aPoint! extent: aPoint "Answer a new Rectangle whose origin is the receiver and whose extent is aPoint. This is one of the infix ways of expressing the creation of a rectangle." ^Rectangle origin: self extent: aPoint! ! !Point methodsFor: 'coercing'! coerce: aNumber "Answer a new Point whose coordinates are the argument, aNumber." ^aNumber@aNumber! generality "Answer the number representing the ordering of the receiver in the generality hierarchy." ^90! ! !Point methodsFor: 'transforming'! scaleBy: factor "Answer a new Point scaled by factor (an instance of Point)." ^(factor x * x) @ (factor y * y)! translateBy: delta "Answer a new Point translated by delta (an instance of Point)." ^(delta x + x) @ (delta y + y)! ! !Point methodsFor: 'copying'! deepCopy "Answer a copy of the receiver with its own copy of each instance variable." "Implemented here for better performance." ^x deepCopy @ y deepCopy! shallowCopy "Implemented here for better performance." ^x @ y! ! !Point methodsFor: 'printing'! printOn: aStream "Append to the argument aStream in terms of infix notation." x printOn: aStream. aStream nextPut: $@. y printOn: aStream! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a point similar to the receiver. The general format for points is ( class-name x: aNumber y: aNumber)" aStream nextPut: $(; nextPutAll: self species name; nextPutAll: ' x: '; store: x; nextPutAll: ' y: '; store: y; nextPut: $).! ! !Point methodsFor: 'private'! setX: xPoint setY: yPoint "Initialize the instance variables." x _ xPoint. y _ yPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Point class instanceVariableNames: ''! !Point class methodsFor: 'instance creation'! x: xInteger y: yInteger "Answer a new instance of a Point with coordinates xInteger and yInteger." ^self new setX: xInteger setY: yInteger! ! Object subclass: #PopUpMenu instanceVariableNames: 'labelString font lineArray frame form marker selection origin ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! PopUpMenu comment: 'I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection. Instance Variables: labelString of menu items font for displaying the characters lineArray of integers indicating where lines should be drawn in the menu frame form containing the composed paragraph marker used to highlight selection selection index into menu items; if 0, no selection '! !PopUpMenu methodsFor: 'basic control sequence'! startUp "Show the receiver and give control to the user to make a selection." ^self startUp: #anyButton! ! !PopUpMenu methodsFor: 'accessing'! center "Answer the point at the center of the receiver's rectangular area." ^frame center! height "Answer the width of the receiver's rectangular area." ^frame height! labelAt: aNumber "Answer the label whose ordinal position in the menu is aNumber. If aNumber is out of range, answer nil." | cr count start next | aNumber <= 0 ifTrue: [^nil]. cr _ String with: Character cr. count _ aNumber. start _ 1. [next _ labelString findString: cr startingAt: start. "The current label extends from start through (next - 1 if next > 0, otherwise the end of labelString)." count > 1] whileTrue: [next = 0 ifTrue: [^nil]. "aNumber is too large" start _ next + 1. count _ count - 1]. ^ labelString copyFrom: start to: (next = 0 ifTrue: [labelString size] ifFalse: [next - 1])! reset marker _ marker align: marker topLeft with: frame topLeft + frame borderWidth origin. origin _ frame inside topLeft. selection _ 0.! topLeft "Answer the point at the topLeft of the receiver's rectangular area." ^frame topLeft! width "Answer the width of the receiver's rectangular area." ^frame width! ! !PopUpMenu methodsFor: 'bordering'! borderWidth "Answer the borderWidth of the receiver's rectangular area." ^frame borderWidth! ! !PopUpMenu methodsFor: 'displaying'! displayAt: aPoint during: aBlock "Display the receiver centered at aPoint while aBlock is evaluated. If necessary, translate so the view is completely on the screen." | delta savedArea | frame _ frame align: marker center with: aPoint. delta _ frame amountToTranslateWithin: Display boundingBox. frame moveBy: delta. frame _ frame intersect: Display boundingBox. frame _ frame adjustInsideHeightToMultipleOf: marker height. marker _ marker align: marker center with: aPoint + delta. savedArea _ Form fromDisplay: frame. "Display black: (frame origin + (1@1) corner: frame corner). Display black: (frame origin corner: frame corner - (1@1))." frame displayOn: Display. origin _ frame inside topLeft. self displayForm. Cursor normal showWhile: aBlock. savedArea displayOn: Display at: frame topLeft! displayAt: aPoint withHeading: aText during: aBlock "Display the receiver centered at aPoint while aBlock is evaluated. If necessary, translate so the view is completely on the screen." | delta savedArea heading headingBox headingSavedArea shiftPoint| frame _ frame align: marker center with: aPoint. heading _ aText asDisplayText. headingBox _ heading boundingBox expandBy: 2. headingBox _ headingBox align: headingBox bottomCenter with: frame topCenter + (0@2). delta _ (frame merge: headingBox) amountToTranslateWithin: Display boundingBox. frame moveBy: delta. headingBox moveBy: delta. frame top < headingBox height ifTrue:[ frame _ frame translateBy: (shiftPoint _ (0@(headingBox height - frame top - 2))). headingBox _ headingBox translateBy: shiftPoint]. frame _ frame intersect: Display boundingBox. frame _ frame adjustInsideHeightToMultipleOf: marker height. marker _ marker align: marker center with: aPoint + delta. savedArea _ Form fromDisplay: frame. headingSavedArea _ Form fromDisplay: headingBox. Display border: (headingBox) width: 2 mask: Form black. heading displayAt: headingBox origin + (2@2). "Display black: (frame origin + (1@1) corner: frame corner). Display black: (frame origin corner: frame corner - (1@1))." frame displayOn: Display. origin _ frame inside topLeft. self displayForm. Cursor normal showWhile: aBlock. savedArea displayOn: Display at: frame topLeft. headingSavedArea displayOn: Display at: headingBox topLeft! displayForm form displayOn: Display at: origin clippingBox: frame inside. (selection ~= 0 and: [selection notNil]) ifTrue: [Display reverse: marker].! ! !PopUpMenu methodsFor: 'marker adjustment'! manageMarker "If the cursor is inside the receiver's frame, then highlight the marked item. Otherwise no item is to be marked." | aPoint | aPoint _ self scrollIfNeeded. (frame inside containsPoint: aPoint) ifTrue: [self markerOn: aPoint] ifFalse: [self markerOff]! markerOff "No item is selected. Reverse the highlight if any item has been marked as selected." selection ~= 0 ifTrue: [Display reverse: marker. selection _ 0]! markerOn: aPoint "The item whose bounding area contains aPoint should be marked as selected. Highlight its area and set the selection to its index." selection = 0 | (marker containsPoint: aPoint) not ifTrue: [selection = 0 & (marker containsPoint: aPoint) ifTrue: [Display reverse: marker] ifFalse: [selection ~= 0 ifTrue: [Display reverse: marker]. marker _ marker align: marker topLeft with: marker left @ (self markerTop: aPoint). Display reverse: marker]]. selection _ marker top - origin y // marker height + 1! markerTop: aPoint "Answer aPoint, gridded to lines in the receiver." ^(aPoint y - frame inside top truncateTo: font height) + frame inside top! scrollIfNeeded "Scroll the menu if we need to" | aPoint | aPoint _ Sensor cursorPoint. ((frame inside top) >= aPoint y) & (origin y <= frame top) ifTrue: [ origin _ origin + (0@marker height). self displayForm ]. ((frame inside bottom) <= aPoint y) & "There is something to scroll" ((origin y + form height-2) > frame inside bottom) ifTrue: [ origin _ origin - (0@marker height). self displayForm ]. ^aPoint! ! !PopUpMenu methodsFor: 'selecting'! selection "Answer the current selection." ^selection! ! !PopUpMenu methodsFor: 'controlling'! anyButtonPressed ^Sensor anyButtonPressed! buttonPressed: aSymbol "The argument indicates which button should be tested. Answer whether it is pressed." aSymbol = #redButton ifTrue: [^Sensor redButtonPressed]. aSymbol = #yellowButton ifTrue: [^Sensor yellowButtonPressed]. aSymbol = #blueButton ifTrue: [^Sensor blueButtonPressed]. ^Sensor anyButtonPressed! startUp: t1 self displayAt: Sensor cursorPoint during: [Sensor cursorPoint: marker center. [self anyButtonPressed] whileFalse: [self scrollIfNeeded]. [self anyButtonPressed] whileTrue: [self manageMarker]. nil]. ^selection! startUp: aSymbol withHeading: aText "Display and make a selection from the receiver as long as the button denoted by the symbol, aSymbol, is pressed. Answer the current selection." self displayAt: Sensor cursorPoint withHeading: aText during: [Sensor cursorPoint: marker center. [self buttonPressed: aSymbol] whileFalse: [(frame containsPoint: Sensor cursorPoint) ifFalse: [Display flash: frame]]. [self buttonPressed: aSymbol] whileTrue: [self manageMarker]]. ^selection! startUpAndWaitForSelectionAt: aPoint "Display and make a selection from the receiver as long as the button denoted by the symbol, aSymbol, is pressed. Answer the current selection." self displayAt: aPoint during: [[(Sensor anyButtonPressed and: [frame inside containsPoint: Sensor cursorPoint])] whileFalse: []. [self buttonPressed: #anyButton] whileTrue: [self manageMarker]]. ^selection! startUpBlueButton "Display and make a selection from the receiver as long as the blue button is pressed." ^self startUp: #blueButton! startUpRedButton "Display and make a selection from the receiver as long as the red button is pressed." ^self startUp: #redButton! startUpYellowButton "Display and make a selection from the receiver as long as the yellow button is pressed." ^self startUp: #yellowButton! ! !PopUpMenu methodsFor: 'private'! labels: aString font: aFont lines: anArray | style labelPara | labelString _ aString. font _ aFont. style _ TextStyle fontArray: (Array with: font). style alignment: 2. "centered" style gridForFont: 1 withLead: 0. labelPara _ Paragraph withText: aString asText style: style. lineArray _ anArray. form _ labelPara asForm. frame _ Quadrangle new. frame region: (labelPara compositionRectangle expandBy: 2). frame borderWidth: (1@1 corner: 3@3). lineArray == nil ifFalse: [lineArray do: [:line | form fill: (0 @ (line * font height) extent: (frame width @ 1)) mask: Form black]]. marker _ frame inside topLeft extent: frame inside width @ labelPara lineGrid. selection _ 0! rescan "cause me to be recreated for system changes like fonts" labelString == nil ifFalse: [self labels: labelString font: font lines: lineArray] "PopUpMenu allInstancesDo: [:x | x rescan]."! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PopUpMenu class instanceVariableNames: ''! !PopUpMenu class methodsFor: 'instance creation'! labelList: labelArray "Create a menu with labels from those grouped in labelArray." | stream lines line i k label| stream _ WriteStream on: (String new: 50). lines _ OrderedCollection new: labelArray size-1. line _ 0. labelArray do: [:labels | k _ 1. [k <= labels size] whileTrue: [label _ labels at: k. i _ 1. [i <= label size] whileTrue: [stream nextPut: (label at: i). i _ i + 1.]. k _ k + 1. stream cr]. line _ line + labels size. lines add: line]. lines isEmpty ifFalse: [lines removeLast]. stream skip: -1. "remove the final cr" ^self new labels: stream contents font: (TextStyle default fontAt: 1) lines: lines! labels: aString "Answer an instance of me whose items are in aString." ^self labels: aString lines: nil! labels: aString lines: anArray "Answer an instance of me whose items are in aString, with lines drawn after each item indexed by anArray." ^ self new labels: aString font: (TextStyle default fontAt: 1) lines: anArray! ! Stream subclass: #PositionableStream instanceVariableNames: 'collection position readLimit ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! PositionableStream comment: 'Class PositionableStream assumes that its contents is an indexable collection and that, in support of accessing the elements of the contents, it can reposition a pointer. Class PositionableStream is abstract in that it does not implement the messages next and nextPut: which are inherited from the superclass Stream. Instance Variables: collection position pointer to the current access position readLimit size of the collection'! !PositionableStream methodsFor: 'accessing'! contents "Answer with a copy of the receiver's collection from 1 to readLimit." ^collection copyFrom: 1 to: readLimit! next: anInteger "Answer the next anInteger elements of the receiver." | newArray | newArray _ self contents species new: anInteger. 1 to: anInteger do: [:index | newArray at: index put: self next]. ^newArray! peek "Answer what would be returned with a self next, without changing position. If the receiver is at the end, answer nil." | nextObject | self atEnd ifTrue: [^nil]. nextObject _ self next. self skip: -1. ^nextObject! peekFor: anObject "Answer false and do not move the position if self next ~= anObject or if the receiver is at the end. Answer true and increment position if self next = anObject." | nextObject | self atEnd ifTrue: [^false]. nextObject _ self next. "peek for matching element" anObject = nextObject ifTrue: [^true]. "gobble it if found" self skip: -1. ^false! through: anObject "Answer a subcollection from position to the occurrence (if any, inclusive) of anObject. If not there, answer everything." | newStream element | newStream _ WriteStream on: (collection species new: 64). [self atEnd] whileFalse: [element _ self next. newStream nextPut: element. element = anObject ifTrue: [^newStream contents]]. ^newStream contents! upTo: anObject "Answer a subcollection from position to the occurrence (if any, not inclusive) of anObject. If not there, answer everything." | newStream element | newStream _ WriteStream on: (collection species new: 64). [self atEnd or: [(element _ self next) = anObject]] whileFalse: [newStream nextPut: element]. ^newStream contents! upToEnd "Answer a subcollection from position to the end of anObject." | newStream | newStream _ WriteStream on: (collection species new: 64). [self atEnd] whileFalse: [newStream nextPut: self next]. ^newStream contents! ! !PositionableStream methodsFor: 'testing'! atEnd "Answer whether the position is greater than or equal to the limit. Fail if either the receiver's position or readLimit is not a SmallInteger. Optional. See Object documentation whatIsAPrimitive." ^position >= readLimit! isEmpty "Answer whether the receiver contains any elements." ^position = 0! ! !PositionableStream methodsFor: 'positioning'! position "Answer the current position of accessing the stream." ^position! position: anInteger "Set position to anInteger as long as anInteger is within the bounds of the receiver's contents. If it is not, provide an error notification." anInteger >= 0 & (anInteger <= readLimit) ifTrue: [position _ anInteger] ifFalse: [self positionError]! reset "Set the receiver's position to 0." position _ 0! setToEnd "Set the position of the receiver to the end of its stream of elements." readLimit _ readLimit max: position. position _ readLimit! skip: anInteger "Set position to position+anInteger. A subclass might choose to be more helpful and select the minimum of self size and position+anInteger or maximum of 1 and position+anInteger for the repositioning." self position: position + anInteger! skipTo: anObject "Position the receiver past the next occurrance of anObject. Answer whether anObject is found." [self atEnd] whileFalse: [self next = anObject ifTrue: [^true]]. ^false! ! !PositionableStream methodsFor: 'fileIn/Out'! nextChunk "Answer the contents of the receiver, up to the next terminator character, with double terminators ignored." | aStream char terminator | terminator _ $!!. aStream _ WriteStream on: (String new: 200). self skipSeparators. [(char _ self next) ==nil] whileFalse: [char == terminator ifTrue: [char _ self next. char == terminator ifTrue: ["doubled terminator" aStream nextPut: char] ifFalse: [char == nil ifFalse: [self skip: -1 ]. ^aStream contents]] ifFalse: [aStream nextPut: char]]. ^aStream contents! skipSeparators "Move the receiver's position past any separators." | ch | [(ch _ self next) == nil] whileFalse: [ch isSeparator ifFalse: [^self skip: -1]]! ! !PositionableStream methodsFor: 'private'! on: aCollection collection _ aCollection. readLimit _ aCollection size. position _ 0. self reset! positionError "Provide an error notification that an object has attempted to set the position of the receiver out of bounds." "Since the receiver is not necessarily writable, it is up to the subclasses to override position: if expanding the collection is preferrable to giving this error." self error: 'Attempt to set the position of a PositionableStream out of bounds'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PositionableStream class instanceVariableNames: ''! !PositionableStream class methodsFor: 'instance creation'! on: aCollection "Answer a new instance of the receiver, streaming over aCollection." ^self basicNew on: aCollection! on: aCollection from: firstIndex to: lastIndex "Answer a new instance of the receiver, streaming over a copy of aCollection from firstIndex to lastIndex." ^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)! ! Link subclass: #Process instanceVariableNames: 'suspendedContext priority myList userError ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! Process comment: 'Class Process represents an independent path of control in the system. This path of control may be stopped (by sending the instance the message suspend) in such a way that it can later be restarted (by sending the instance the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the instance''s priority. Instance Variables: suspendedContext activeContext at time of process suspension priority partial indication of relative scheduling myList on which I am suspended '! !Process methodsFor: 'changing process state'! resume "Allow the process that the receiver represents to continue. Put the receiver in line to become the activeProcess. Fail if the receiver is already waiting in a queue (in a Semaphore or ProcessScheduler). Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! suspend "Stop the process that the receiver represents in such a way that it can be restarted at a later time (by sending the receiver the message resume). If the receiver represents the activeProcess, suspend it. Otherwise fail and the code below will remove the receiver from the list of waiting processes. Essential. See Object documentation whatIsAPrimitive." Processor activeProcess == self ifTrue: [self primitiveFailed] ifFalse: [Processor remove: self ifAbsent: [self error: 'This process was not active']. myList _ nil]! terminate "Perhaps this method should be primitive. If the a process might run at any moment (like a Delay), and another process is trying to terminate it, there is a race condition in this method. The remove:ifAbsent: may get confused. One way to avoid this is to let Delays terminate themselves. See MessageTally spyEvery:on: for an example. " | context | Processor activeProcess == self ifTrue: [thisContext sender == nil ifFalse: [thisContext sender release]. thisContext removeSelf suspend] ifFalse: ["remove me first, then destroy me" myList == nil ifFalse: [myList remove: self ifAbsent: []. myList _ nil]. context _ suspendedContext. suspendedContext _ nil. (context ~~ nil and: [context sender ~~ nil]) ifTrue: [context sender release]]! ! !Process methodsFor: 'changing suspended state'! install: aContext "Replace the suspendedContext with aContext." self == Processor activeProcess ifTrue: [^self error: 'The active process cannot install contexts']. suspendedContext _ aContext! popTo: aContext "Replace the suspendedContext with aContext, releasing all contexts between the currently suspendedContext and it." self == Processor activeProcess ifTrue: [^self error: 'The active process cannot pop contexts']. suspendedContext releaseTo: aContext. suspendedContext _ aContext! ! !Process methodsFor: 'accessing'! offList "Inform the receiver that it has been taken off a list that it was suspended on. This is to break a backpointer." myList _ nil! priority "Answer the priority of the receiver." ^priority! priority: anInteger "Set the receiver's priority to anInteger." anInteger<=Processor highestPriority ifTrue: [priority _ anInteger] ifFalse: [self error: 'priority too high']! suspendedContext "Answer the context the receiver has suspended." ^suspendedContext! suspendingList "Answer the list on which the receiver has been suspended." ^myList! userError ^userError! userError: error userError _ error! ! !Process methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." super printOn: aStream. aStream nextPutAll: ' in '. suspendedContext printOn: aStream! ! !Process methodsFor: 'private'! suspendedContext: aContext suspendedContext _ aContext! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Process class instanceVariableNames: ''! !Process class methodsFor: 'instance creation'! forContext: aContext priority: anInteger "Answer an instance of me that has suspended aContext at priority anInteger." | newProcess | newProcess _ self new. newProcess suspendedContext: aContext. newProcess priority: anInteger. ^newProcess! ! Object subclass: #ProcessHandle instanceVariableNames: 'process controller interrupted resumeContext proceedValue haltedScrollBar ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Debugger'! ProcessHandle comment: 'A ProcessHandle holds the state of an interrupted process. It is capable of cutting back the process''s stack, terminating the process, or causing it to resume again.'! !ProcessHandle methodsFor: 'initialize-release'! process: aProcess controller: aController interrupted: aBoolean resumeContext: aContext process _ aProcess. controller _ aController. interrupted _ aBoolean. resumeContext _ aContext. proceedValue _ nil. haltedScrollBar _ ScrollController haltedScrollBar.! release process _ nil. "break all cycles" controller _ nil. resumeContext _ nil. proceedValue _ nil! ! !ProcessHandle methodsFor: 'access'! interrupted ^ interrupted! interrupted: aBoolean "whoever uses this should be a method in this class" interrupted _ aBoolean! proceedValue ^ proceedValue! proceedValue: value proceedValue _ value! topContext ^ resumeContext! topContext: aContext resumeContext _ aContext! ! !ProcessHandle methodsFor: 'menu messages'! proceed interrupted ifTrue: [resumeContext push: proceedValue]. self resumeProcess! ! !ProcessHandle methodsFor: 'control'! resumeProcess | aScheduledController | aScheduledController _ ScheduledControllers activeController. aScheduledController view erase. process suspendedContext method == (Process compiledMethodAt: #terminate) ifFalse: [resumeContext == process suspendedContext ifFalse: [process popTo: resumeContext]. ScheduledControllers activeControllerNoTerminate: controller "NoTerminate" andProcess: process]. "if old process was terminated, just terminate current one" self release. "must precede close because it tries to terminate" aScheduledController closeAndUnscheduleNoErase. ScrollController restoreHaltedScrollBar: haltedScrollBar. Processor terminateActive! terminate process == nil ifFalse: [process terminate]. self release! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProcessHandle class instanceVariableNames: ''! !ProcessHandle class methodsFor: 'instance creation'! on: aProcess at: aContext interrupted: aBoolean ^ self new process: aProcess controller: (ScheduledControllers activeControllerProcess == aProcess ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) interrupted: aBoolean resumeContext: aContext! ! Object subclass: #ProcessorScheduler instanceVariableNames: 'quiescentProcessLists activeProcess ' classVariableNames: 'BackgroundProcess HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority ' poolDictionaries: '' category: 'Kernel-Processes'! ProcessorScheduler comment: 'The single instance of class ProcessorScheduler, named Processor, coordinates the use of the physical processor by all Processes requiring service. Instance Variables: quiescentProcessLists on which to suspend processes activeProcess currently executing process Class Variables: BackgroundProcess nil or These priorities for processes are set in the class initialize method. HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority '! !ProcessorScheduler methodsFor: 'accessing'! activePriority "Answer the priority level of the currently running Process." ^activeProcess priority! activeProcess "Answer the currently running Process." ^activeProcess! highestPriority "Answer the number of priority levels currently available for use." ^quiescentProcessLists size! highestPriority: newHighestPriority "Change the number of priority levels currently available for use." | newProcessLists | (quiescentProcessLists size > newHighestPriority and: [self anyProcessesAbove: newHighestPriority]) ifTrue: [self error: 'There are processes with priority higher than ' , newHighestPriority printString]. newProcessLists _ Array new: newHighestPriority. 1 to: ((quiescentProcessLists size) min: (newProcessLists size)) do: [:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)]. quiescentProcessLists size to: newProcessLists size do: [:priority | newProcessLists at: priority put: LinkedList new]. quiescentProcessLists become: newProcessLists! processesAt: priority ^(quiescentProcessLists at: priority) size! ! !ProcessorScheduler methodsFor: 'removing'! remove: aProcess ifAbsent: aBlock "Remove aProcess from the list on which it is waiting for the processor. If it is not waiting, evaluate aBlock." (quiescentProcessLists at: aProcess priority) remove: aProcess ifAbsent: aBlock. ^aProcess! ! !ProcessorScheduler methodsFor: 'process state change'! suspendFirstAt: aPriority "Suspend the first Process that is waiting to run with priority aPriority." ^self suspendFirstAt: aPriority ifNone: [self error: 'No Process to suspend']! suspendFirstAt: aPriority ifNone: noneBlock "Suspend the first Process that is waiting to run with priority aPriority. If no Process is waiting, evaluate noneBlock" | aList | aList _ quiescentProcessLists at: aPriority. aList isEmpty ifTrue: [^noneBlock value] ifFalse: [^aList first suspend]! terminateActive "Terminate the process that is currently running." activeProcess terminate! yield "Give other Processes at the current priority a chance to run" | semaphore | semaphore _ Semaphore new. [semaphore signal] fork. semaphore wait! ! !ProcessorScheduler methodsFor: 'timing'! signal: aSemaphore atTime: timeInterval "Signal aSemaphore when the system's millisecond clock reaches timeInterval (an Integer)" | milliseconds | (timeInterval digitLength > 4 or: [timeInterval negative]) ifTrue: [self error: 'Can''t convert time to double word']. milliseconds _ ByteArray new: 4. milliseconds at: 1 put: (timeInterval digitAt: 1). milliseconds at: 2 put: (timeInterval digitAt: 2). milliseconds at: 3 put: (timeInterval digitAt: 3). milliseconds at: 4 put: (timeInterval digitAt: 4). ^self signal: aSemaphore atMilliseconds: milliseconds! ! !ProcessorScheduler methodsFor: 'priority names'! highIOPriority "Answer the priority at which the most time critical input/output processes should run. An example is the process handling input from a network." ^HighIOPriority! lowIOPriority "Answer the priority at which most input/output processes should run. Examples are the process handling input from the user (keyboard, pointing device, etc.) and the process distributing input from a network." ^LowIOPriority! systemBackgroundPriority "Answer the priority at which system background processes should run. Examples are an incremental garbage collector or status checker." ^SystemBackgroundPriority! timingPriority "Answer the priority at which the system processes keeping track of real time should run." ^TimingPriority! userBackgroundPriority "Answer the priority at which user background processes should run." ^UserBackgroundPriority! userInterruptPriority "Answer the priority at which user processes desiring immediate service should run. Processes run at this level will preempt the window scheduler and should, therefore, not consume the processor forever." ^UserInterruptPriority! userSchedulingPriority "Answer the priority at which the window scheduler should run." ^UserSchedulingPriority! ! !ProcessorScheduler methodsFor: 'private'! anyProcessesAbove: highestPriority "Do any instances of Process exist with higher priorities?" ^(Process allInstances select: [:aProcess | aProcess priority > highestPriority]) isEmpty not! signal: aSemaphore atMilliseconds: milliseconds "Signal the semaphore when the millisecond clock reaches the value of the second argument. The second argument is a byte indexable object at least four bytes long (a 32-bit unsigned number with the low order 8-bits stored in the byte with the lowest index). Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProcessorScheduler class instanceVariableNames: ''! !ProcessorScheduler class methodsFor: 'class initialization'! initialize SystemRockBottomPriority _ 1. SystemBackgroundPriority _ 2. UserBackgroundPriority _ 3. UserSchedulingPriority _ 4. UserInterruptPriority _ 5. LowIOPriority _ 6. HighIOPriority _ 7. TimingPriority _ 8 "ProcessorScheduler initialize."! ! !ProcessorScheduler class methodsFor: 'instance creation'! new "New instances of ProcessorScheduler should not be created." self error: 'New ProcessSchedulers should not be created since the integrity of the system depends on a unique scheduler'! ! !ProcessorScheduler class methodsFor: 'background process'! background: aBlock "Replace the background process with a process running the code in aBlock." BackgroundProcess == nil ifFalse: [BackgroundProcess terminate]. BackgroundProcess _ aBlock newProcess. BackgroundProcess priority: SystemRockBottomPriority. BackgroundProcess resume! hiddenBackgroundProcess "Install a default background process which is invisible." self background: [[true] whileTrue: []]! sweepHandBackgroundProcess "Install the default background process which shows a sweeping circle of Xor-ed bits on the screen." | sweepHand | sweepHand _ Pen new. sweepHand defaultNib: 2. sweepHand combinationRule: 6. self background: [[true] whileTrue: [2 timesRepeat: [sweepHand north. 36 timesRepeat: [sweepHand place: Display boundingBox topRight + (-25@25). sweepHand go: 20. sweepHand turn: 10]]]]! ! ProcessorScheduler initialize! StringHolder subclass: #Project instanceVariableNames: 'projectWindows projectChangeSet projectTranscript projectHolder ' classVariableNames: 'CurrentProject ' poolDictionaries: '' category: 'Interface-Projects'! Project comment: 'Each screen is a manifestation of a project. Each project manages the windows (views) in it. While the user is working in the project, the changes made to classes are collected. Thus a system-wide set of changes is the collection of all project changes.'! !Project methodsFor: 'initialize-release'! release projectWindows isNil ifFalse: [projectWindows release]. ^super release! ! !Project methodsFor: 'access'! changes ^projectChangeSet! ! !Project methodsFor: 'controlling'! enter "The user has chosen to change the context of the workspace to be that of the receiver. Change the ChangeSet, Transcript, and collection of scheduled views accordingly." Smalltalk newChanges: projectChangeSet. CurrentProject _ self. TextCollector newTranscript: projectTranscript. ControlManager newScheduler: projectWindows! exit "Leave the current project and enter the project in which the receiver's view is scheduled." projectHolder enter! ! !Project methodsFor: 'dependents access'! removeDependent: aDependent super removeDependent: aDependent. self dependents isEmpty ifTrue: [self release]! ! !Project methodsFor: 'change management'! noChanges "Reset the receiver's ChangeSet so that it is empty." projectChangeSet _ ChangeSet new. Smalltalk newChanges: projectChangeSet! ! !Project methodsFor: 'lock access'! isLocked ^super isLocked | projectChangeSet isEmpty not | (projectWindows scheduledControllers size > 1)! isUnlocked ^ self isLocked not! ! !Project methodsFor: 'private'! initialProject projectWindows _ ScheduledControllers. projectChangeSet _ Smalltalk changes. projectHolder _ self! setProjectHolder: aProject projectWindows _ ControlManager new. projectChangeSet _ ChangeSet new. projectTranscript _ TextCollector new. projectHolder _ aProject! ! !Project methodsFor: 'change set stats'! putStatsOn: aStream aStream nextPutAll: 'PROJECT ' ; nextPutAll: self contents;cr;cr. projectChangeSet putStatsOn: aStream. aStream cr! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Project class instanceVariableNames: ''! !Project class methodsFor: 'class initialization'! initialize "This is the Top Project." CurrentProject _ super new initialProject "Project initialize."! ! !Project class methodsFor: 'instance creation'! new ^super new setProjectHolder: CurrentProject! ! !Project class methodsFor: 'constants'! current "Answer the project that is currently being used." ^CurrentProject! ! !Project class methodsFor: 'change set stats'! putStatsOn: aStream self allInstances do: [:aProject | aProject putStatsOn: aStream]! ! Project initialize! StringHolderController subclass: #ProjectController instanceVariableNames: '' classVariableNames: 'ProjectYellowButtonMenu ProjectYellowButtonMessages ' poolDictionaries: '' category: 'Interface-Projects'! ProjectController comment: 'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). The commands doIt and printIt are omitted. I provide one additional menu command enter -- replace the current project by the model, thereby "entering" the door to a new office or work area'! !ProjectController methodsFor: 'menu messages'! enter "Exchange projects so that the receiver's model is the context in which the user works." self controlTerminate. view topView deEmphasize. model enter! ! !ProjectController methodsFor: 'private'! initializeYellowButtonMenu self yellowButtonMenu: ProjectYellowButtonMenu yellowButtonMessages: ProjectYellowButtonMessages.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProjectController class instanceVariableNames: ''! !ProjectController class methodsFor: 'class initialization'! initialize "Initialize the menu for the yellow mouse button." "ProjectController initialize" ProjectYellowButtonMenu _ PopUpMenu labels: 'again\undo\copy\cut\paste\do it\print it\inspect\accept\cancel\enter' withCRs lines: #(2 5 8 10 ). ProjectYellowButtonMessages _ #(again undo copySelection cut paste doIt printIt inspectIt accept cancel enter )! ! ProjectController initialize! IconController subclass: #ProjectIconController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Projects'! ProjectIconController comment: 'I override IconController''s menu so that ''enter'' is available on yellowButton menu.'! !ProjectIconController methodsFor: 'initialization'! initializeYellowButtonMenu "Initialize my yellow button menu." self yellowButtonMenu: (PopUpMenu labels: 'expand\enter' withCRs lines: #(1)) yellowButtonMessages: #(expand enter). self redButtonMenu: yellowButtonMenu redButtonMessages: yellowButtonMessages.! ! !ProjectIconController methodsFor: 'menu messages'! enter "Enter the project." view topView model enter! ! StringHolderView subclass: #ProjectView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Projects'! ProjectView comment: 'I am a StringHolderView of the description of a Project. ProjectController is my default controller.'! !ProjectView methodsFor: 'initialize-release'! release model release. super release! ! !ProjectView methodsFor: 'controller access'! defaultControllerClass ^ProjectController! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProjectView class instanceVariableNames: ''! !ProjectView class methodsFor: 'instance creation'! open "Answer an instance of me for a new Project. It is created on the display screen." ^self open: Project new "ProjectView open"! open: aProject "Answer an instance of me for the argument, aProject. It is created on the display screen." | aProjectView topView | aProjectView _ super new. aProjectView model: aProject. aProjectView borderWidth: 1. topView _ StandardSystemView new. topView model: aProject. topView borderWidth: 1. topView addSubView: aProjectView. topView label: 'Project'. topView minimumSize: 100 @ 50. topView icon: (Icon constantNamed: #default). topView iconView controller: ProjectIconController new. topView iconText: 'project'. topView controller open! ! Rectangle subclass: #Quadrangle instanceVariableNames: 'borderWidth borderColor insideColor ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! Quadrangle comment: 'Class Quadrangle represents a particular kind of Rectangle that has a border and inside color. Instance Variables: borderWidth representing the left, right, top, bottom border widths borderColor insideColor '! !Quadrangle methodsFor: 'initialize-release'! initialize "Initialize the region to a null Rectangle, the border width to 1, the border color to black, and the inside color to white." origin _ 0 @ 0. corner _ 0 @ 0. borderWidth _ 1. borderColor _ Form black. insideColor _ Form white! ! !Quadrangle methodsFor: 'bordering'! borderColor "Answer the border color of the receiver." ^borderColor! borderColor: aColor "Set the border color of the receiver to aColor." borderColor _ aColor! borderWidth "Answer the border width of the receiver." ^borderWidth! borderWidth: anInteger "Set the border width of the receiver to anInteger." borderWidth _ anInteger! borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4 "Set the border width of the receiver so that the arguments denote the left, right, top, and bottom border widths." borderWidth _ anInteger1 @ anInteger3 corner: anInteger2 @ anInteger4! inside "Answer a Rectangle that is the receiver inset by the border width." ^self insetBy: borderWidth! insideColor "Answer the inside color of the receiver." ^insideColor! insideColor: aColor "Set the inside color of the receiver to the argument aColor." insideColor _ aColor! region "Answer a Rectangle that defines the area of the receiver." ^origin corner: corner! region: aRectangle "Set the rectangular area of the receiver to aRectangle." origin _ aRectangle origin. corner _ aRectangle corner! ! !Quadrangle methodsFor: 'displaying'! display "Display the border and inside region of the receiver." self displayOn: Display! displayAlign: aPoint1 with: aPoint2 clippingBox: aRectangle "Display the border and region of the reciever so that its position at aPoint1 is aligned with position aPoint2. The displayed information should be clipped so that only information with the area determined by aRectangle is displayed." | savedRegion | savedRegion _ self region. self region: ((savedRegion align: aPoint1 with: aPoint2) intersect: aRectangle). self displayOn: Display. self region: savedRegion! displayOn: aDisplayMedium "Display the border and insideRegion of the receiver." insideColor ~~ nil ifTrue: [aDisplayMedium fill: self inside mask: insideColor]. borderWidth ~~ 0 & (insideColor ~~ nil) ifTrue: [aDisplayMedium fill: self region mask: borderColor. aDisplayMedium fill: self inside mask: insideColor]! displayOn: aDisplayMedium align: aPoint1 with: aPoint2 clippingBox: aRectangle "Display the border and region of the reciever so that its position at aPoint1 is aligned with position aPoint2. The displayed information should be clipped so that only information with the area determined by aRectangle is displayed." | savedRegion | savedRegion _ self region. self region: ((savedRegion align: aPoint1 with: aPoint2) intersect: aRectangle). self displayOn: aDisplayMedium. self region: savedRegion! displayOn: aDisplayMedium transformation: aWindowingTransformation clippingBox: aRectangle "Display the border and region of the reciever so that it is scaled and translated with respect to aWindowingTransformation. The displayed information should be clipped so that only information with the area determined by aRectangle is displayed." | screenRectangle | screenRectangle _ (aWindowingTransformation applyTo: self) intersect: aRectangle. borderWidth ~~ 0 & (insideColor ~~ nil) ifTrue: [aDisplayMedium fill: screenRectangle mask: borderColor. aDisplayMedium fill: (screenRectangle insetBy: borderWidth) mask: insideColor]! ! !Quadrangle methodsFor: 'rectangle functions'! intersect: aRectangle "Answer a new Quadrangle whose region is the intersection of the receiver's area and aRectangle." ^ self species region: (super intersect: aRectangle) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! ! !Quadrangle methodsFor: 'transforming'! adjustInsideHeightToMultipleOf: anInteger "Answer a new Quadrangle that is a copy of the receiver with the rectangular area changed so that its hight is a multiple of the argument anInteger." | inside | inside _ self inside. ^self species region: ((inside height: inside height - (inside height \\ anInteger)) expandBy: borderWidth) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! align: aPoint1 with: aPoint2 "Answer a new Quadrangle translated by aPoint2 - aPoint1." ^ self species region: (super translateBy: aPoint2 - aPoint1) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! scaleBy: aPoint "Answer a new Quadrangle whose rectangular area is scaled by the argument aPoint." ^ self species region: (super scaleBy: aPoint) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! translateBy: aPoint "Answer a new Quadrangle whose rectangular area is translated by aPoint." ^ self species region: (super translateBy: aPoint) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! ! !Quadrangle methodsFor: 'private'! region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2 "Initialize the instance variables." origin _ aRectangle origin. corner _ aRectangle corner. borderWidth _ anInteger. borderColor _ aMask1. insideColor _ aMask2.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Quadrangle class instanceVariableNames: ''! !Quadrangle class methodsFor: 'instance creation'! new "Answer an instance of the receiver, initialized to a null Rectangle, with border width of 1, border color of black, and inside color of white." ^super new initialize! region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2 "Answer an instance of the receiver with rectangle, border width and color, and inside color determined by the arguments." ^super new region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2! ! Stream subclass: #Random instanceVariableNames: 'seed increment modulus fmodulus multiplier ' classVariableNames: 'DefaultGenerator Increments MaxGenerator Moduli Multipliers ' poolDictionaries: '' category: 'Numeric-Numbers'! Random comment: 'An instance of class Random provides an endless supply of random numbers. We produce a uniform deviate in the half-open interval [0.0,1.0) using a linear congruential generator. See "Numerical Recipes" (W.H. Press, B.P. Flannery, S.A. Teukolsky, W.T. Vetterling; Cambridge University Press 1986), pp. 191-199. Instance Variables: seed the first of the series. increment modulus multiplier fmodulus The recurrance parameters. Class Variables: DefaultGenerator used to choose a generator if the client doesn''t select one. MaxGenerator Highest numbered generator permitted; this is the length of the 3 arrays named below. Increments Moduli Multipliers Constants for the recurrance parameters. generator: selects from these, e.g. generator #2 uses: {Increments at: 2, Moduli at:2, Multipliers at: 2}.'! !Random methodsFor: 'accessing'! contents "Random numbers do not have a contents so provide an error notification." ^self shouldNotImplement! next "Answer the next random number." ^self step asFloat / fmodulus! nextPut: anObject "Random numbers do not implement nextPut: so provide an error notification." ^self shouldNotImplement! ! !Random methodsFor: 'testing'! atEnd "Answer false that the stream is not at an end." ^false! ! !Random methodsFor: 'private'! generator: aSmallInteger "Chooses a parameter triplet." | generatorIndex | generatorIndex _ aSmallInteger. generatorIndex < 1 | (generatorIndex > MaxGenerator) ifTrue: [self error: 'No such generator; proceed for generator #1'. generatorIndex _ 1]. increment _ Increments at: generatorIndex. modulus _ Moduli at: generatorIndex. fmodulus _ modulus asFloat. multiplier _ Multipliers at: generatorIndex! seed: aSmallInteger "Initialize the first random number." seed _ aSmallInteger \\ modulus! setSeed "Initialize the first random number." seed _ Time millisecondClockValue bitAnd: 65535 "Time millisecondClockValue gives a large integer; I only want the lower 16 bits."! step "Produce the next random seed." ^seed _ seed * multiplier + increment \\ modulus! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Random class instanceVariableNames: ''! !Random class methodsFor: 'instance creation'! fromGenerator: g seededWith: s "Answer a new random number generator." | r | r _ self basicNew. r generator: g. r seed: s. ^r! new "Answer a new random number generator, seeded from the time-of-day. " "The simple, naive interface..." ^self fromGenerator: DefaultGenerator seededWith: Time millisecondClockValue! ! !Random class methodsFor: 'class initialization'! initialize "Set the recurrance parameter constants." "These values are appropriate for SmallInteger maxVal = ((2 raisedToInteger: 29) - 1)" "Random initialize" DefaultGenerator _ 1. MaxGenerator _ 7. Moduli _ #(120050 214326 244944 233280 175000 121500 145800). Multipliers _ #(2311 1807 1597 1861 2661 4081 3661). Increments _ #(25367 45289 51749 49297 36979 25673 30809)! ! Random initialize! PositionableStream subclass: #ReadStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! ReadStream comment: 'Instances of ReadStream are readers of an indexable collection. Thus the message nextPut: can not be sent.'! !ReadStream methodsFor: 'accessing'! next "Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." position >= readLimit ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! nextPut: anObject "Provide an error notification that the receiver does not implement this message." self shouldNotImplement! ! !ReadStream methodsFor: 'private'! on: aCollection from: firstIndex to: lastIndex | len | collection _ aCollection. readLimit _ lastIndex > (len _ collection size) ifTrue: [len] ifFalse: [lastIndex]. position _ firstIndex <= 1 ifTrue: [0] ifFalse: [firstIndex - 1]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ReadStream class instanceVariableNames: ''! !ReadStream class methodsFor: 'instance creation'! on: aCollection from: firstIndex to: lastIndex "Answer with a new instance streaming over a copy of aCollection from firstIndex to lastIndex." ^self basicNew on: aCollection from: firstIndex to: lastIndex! ! WriteStream subclass: #ReadWriteStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! ReadWriteStream comment: 'Class ReadWriteStream represents a positionable stream into which it is possible to both read and write.'! !ReadWriteStream methodsFor: 'accessing'! contents "Answer a copy of the receiver's collection from 1 to readLimit." readLimit _ readLimit max: position. ^collection copyFrom: 1 to: readLimit! next "Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." "treat me as a FIFO" position >= readLimit ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! ! !ReadWriteStream methodsFor: 'file status'! close "Sets the status of the stream to be closed." "This message does nothing at this level, but is included for FileStream compatibility." ^self! ! !ReadWriteStream methodsFor: 'fileIn/Out'! fileIn "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation." | val | Cursor read showWhile: [[self atEnd] whileFalse: [self skipSeparators. val _ (self peekFor: $!!) ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self] ifFalse: [Compiler evaluate: self nextChunk logged: true]]. self close]. ^val! fileOutChanges "Append to the receiver a description of all system changes." Cursor write showWhile: [self timeStamp. Smalltalk changes fileOutOn: self. self close]! fileOutChangesFor: class "Append to the receiver a description of the changes to the argument, class." Cursor write showWhile: [self timeStamp. Smalltalk changes fileOutChangesFor: class on: self. self close]! timeStamp "Append the current time to the receiver as a chunk." | aStream | aStream _ WriteStream on: (String new: 16). Smalltalk timeStamp: aStream. self nextChunkPut: aStream contents printString. "double quotes and !!s" self cr; cr! ! Object subclass: #Rectangle instanceVariableNames: 'origin corner ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! Rectangle comment: 'Class Rectangle usually represents a rectangular area on the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new Rectangles. Rectangle functions create new Rectangles by determining intersections of rectangles with rectangles. Instance Variables: origin upper left corner position corner lower right corner position'! !Rectangle methodsFor: 'accessing'! area "Answer the receiver's area, the product of width and height." ^self width * self height! bottom "Answer the position of the receiver's bottom horizontal line." ^corner y! bottom: anInteger "Set the position of the bottom horizontal line of the receiver." corner y: anInteger! bottomCenter "Answer the point at the center of the bottom horizontal line of the receiver." ^self center x @ self bottom! bottomLeft "Answer the point at the left edge of the bottom horizontal line of the receiver." ^origin x @ corner y! bottomRight "Answer the point at the right edge of the bottom horizontal line of the receiver." ^corner! bottomRight: bottomRightPoint "Set the position of the right corner of the bottom horizontal line of the receiver." corner _ bottomRightPoint! center "Answer the point at the center of the receiver." ^self topLeft + self bottomRight // 2! corner "Answer the point at the bottom right corner of the receiver." ^corner! corner: cornerPoint "Set the point at the bottom right corner of the receiver." corner _ cornerPoint! extent "Answer a Point representing the extent of the receiver, that is one whose x coordinate is the width and whose y coordinate is the height." ^corner - origin! extent: extentPoint "Set the extent (width and height) of the receiver to be the argument extentPoint." corner _ origin + extentPoint! height "Answer the height of the receiver." ^corner y - origin y! height: heightInteger "Change the receiver's bottom y to make its height the argument heightInteger." corner y: origin y + heightInteger! left "Answer the position of the receiver's left vertical line." ^origin x! left: anInteger "Set the position of the receiver's left vertical line." origin x: anInteger! leftCenter "Answer the point at the center of the receiver's left vertical line." ^self left @ self center y! origin "Answer the point at the top left corner of the receiver." ^origin! origin: originPoint "Set the point at the top left corner of the receiver." origin _ originPoint! origin: originPoint corner: cornerPoint "Set the points at the top left corner and the bottom right corner of the receiver." origin _ originPoint. corner _ cornerPoint! origin: originPoint extent: extentPoint "Set the point at the top left corner of the receiver to be originPoint and set the width and height of the receiver to be extentPoint." origin _ originPoint. corner _ origin + extentPoint! right "Answer the position of the receiver's right vertical line." ^corner x! right: anInteger "Set the position of the receiver's right vertical line." corner x: anInteger! rightCenter "Answer the point at the center of the receiver's right vertical line." ^self right @ self center y! top "Answer the position of the receiver's top horizontal line." ^origin y! top: anInteger "Set the position of the receiver's top horizontal line." origin y: anInteger! topCenter "Answer the point at the center of the receiver's top horizontal line." ^self center x @ self top! topLeft "Answer the point at the top left corner of the receiver's top horizontal line." ^origin! topLeft: topLeftPoint "Set the point at the top left corner of the receiver's top horizontal line." origin _ topLeftPoint! topRight "Answer the point at the top right corner of the receiver's top horizontal line." ^corner x @ origin y! width "Answer the width of the receiver." ^corner x - origin x! width: widthInteger "Change the receiver's right vertical line to make its width widthInteger." corner x: origin x + widthInteger! ! !Rectangle methodsFor: 'comparing'! = aRectangle "Answer whether the receiver's species, origin and corner match those of the argument, aRectangle." self species = aRectangle species ifTrue: [^origin = aRectangle origin and: [corner = aRectangle corner]] ifFalse: [^false]! hash "Answer a SmallInteger unique to the receiver." ^origin hash bitXor: corner hash! ! !Rectangle methodsFor: 'rectangle functions'! amountToTranslateWithin: aRectangle "Answer a Point, delta, such that self + delta is forced within aRectangle." | delta | delta _ 0@0. self left < aRectangle left ifTrue: [delta x: aRectangle left - self left]. self top < aRectangle top ifTrue: [delta y: aRectangle top - self top]. self right > aRectangle right ifTrue: [delta x: aRectangle right - self right]. self bottom > aRectangle bottom ifTrue: [delta y: aRectangle bottom - self bottom]. ^delta! areasOutside: aRectangle "Answer a Collection of Rectangles comprising the parts of the receiver that do not lie within aRectangle." | areas yOrigin yCorner | "Make sure the intersection is non-empty" (self intersects: aRectangle) ifFalse: [^Array with: self]. areas _ OrderedCollection new. aRectangle origin y > origin y ifTrue: [areas add: (origin corner: corner x @ (yOrigin _ aRectangle origin y))] ifFalse: [yOrigin _ origin y]. aRectangle corner y < corner y ifTrue: [areas add: (origin x @ (yCorner _ aRectangle corner y) corner: corner)] ifFalse: [yCorner _ corner y]. aRectangle origin x > origin x ifTrue: [areas add: (origin x @ yOrigin corner: aRectangle origin x @ yCorner)]. aRectangle corner x < corner x ifTrue: [areas add: (aRectangle corner x @ yOrigin corner: corner x @ yCorner)]. ^areas! expandBy: delta "Answer a Rectangle that is outset from the receiver by delta. delta is a Rectangle, Point, or scalar." (delta isKindOf: Rectangle) ifTrue: [^self species origin: origin - delta origin corner: corner + delta corner] ifFalse: [^self species origin: origin - delta corner: corner + delta]! insetBy: delta "Answer a Rectangle that is inset from the receiver by delta. delta is a Rectangle, Point, or scalar." (delta isKindOf: Rectangle) ifTrue: [^self species origin: origin + delta origin corner: corner - delta corner] ifFalse: [^self species origin: origin + delta corner: corner - delta]! insetOriginBy: originDeltaPoint cornerBy: cornerDeltaPoint "Answer a Rectangle that is inset from the receiver by a given amount in the origin and corner." ^self species origin: origin + originDeltaPoint corner: corner - cornerDeltaPoint! intersect: aRectangle "Answer a Rectangle that is the area in which the receiver overlaps with aRectangle. " ^self species origin: (origin max: aRectangle origin) corner: (corner min: aRectangle corner)! merge: aRectangle "Answer a Rectangle that contains both the receiver and the argument aRectangle." ^self species origin: (origin min: aRectangle origin) corner: (corner max: aRectangle corner)! ! !Rectangle methodsFor: 'testing'! contains: aRectangle "Answer whether the receiver is equal to aRectangle or whether aRectangle is contained within the receiver." ^aRectangle origin >= origin and: [aRectangle corner <= corner]! containsPoint: aPoint "Answer whether the argument aPoint is within the receiver." ^origin <= aPoint and: [aPoint < corner]! intersects: aRectangle "Answer whether aRectangle intersects the receiver anywhere." ^(origin max: aRectangle origin) < (corner min: aRectangle corner)! ! !Rectangle methodsFor: 'truncation and round off'! rounded "Answer a Rectangle whose origin and corner are rounded." ^self species origin: origin rounded corner: corner rounded! ! !Rectangle methodsFor: 'transforming'! align: aPoint1 with: aPoint2 "Answer a new Rectangle that is a translated by aPoint2 - aPoint1." ^self translateBy: aPoint2 - aPoint1! moveBy: aPoint "Change the corner positions of the receiver so that its area translates by the amount defined by the argument, aPoint." origin _ origin + aPoint. corner _ corner + aPoint! moveTo: aPoint "Change the corners of the receiver so that its top left position is aPoint." corner _ corner + aPoint - origin. origin _ aPoint! scaleBy: scale "Answer a new Rectangle scaled by the argument scale, a Point or a scalar." ^ self species origin: origin * scale corner: corner * scale! translateBy: factor "Answer a new Rectangle translated by factor, a Point or a scalar." ^self species origin: origin + factor corner: corner + factor! ! !Rectangle methodsFor: 'copying'! copy "Answer another instance just like the receiver." ^self deepCopy! ! !Rectangle methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver. The general format is originPoint corner: cornerPoint." origin printOn: aStream. aStream nextPutAll: ' corner: '. corner printOn: aStream! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a rectangle similar to the receiver. The general format for rectangles is ( class-name origin: aNumber corner: aNumber)" aStream nextPut: $(; nextPutAll: self species name; nextPutAll: ' origin: '; store: origin; nextPutAll: ' corner: '; store: corner; nextPut: $).! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Rectangle class instanceVariableNames: ''! !Rectangle class methodsFor: 'instance creation'! fromUser "Answer an instance of the receiver that is determined by having the user designate the top left and bottom right corners. The gridding for user selection is 1@1." ^self fromUser: 1 @ 1! fromUser: gridPoint "Answer an instance of the receiver that is determined by having the user designate the top left and bottom right corners. The gridding for user selection is gridPoint." | originPoint newSelf minCorner oldCursor corner| oldCursor _ Sensor currentCursor. Cursor cursorLink: false. originPoint _ Sensor cursorPoint grid: gridPoint. [Sensor redButtonPressed] whileFalse: [Processor yield. Cursor origin showGridded: gridPoint. originPoint _ Sensor cursorPoint grid: gridPoint]. minCorner _ originPoint + gridPoint. newSelf _ originPoint corner: minCorner. Display border: newSelf width: 2 rule: Form reverse mask: Form gray. Sensor cursorPoint: minCorner. [Sensor redButtonPressed] whileTrue: [Processor yield. Cursor corner showGridded: gridPoint. corner _ Sensor cursorPoint grid: gridPoint. corner ~= newSelf corner ifTrue: [Display border: newSelf width: 2 rule: Form reverse mask: Form gray. newSelf corner: (corner max: minCorner). Display border: newSelf width: 2 rule: Form reverse mask: Form gray]]. Display border: newSelf width: 2 rule: Form reverse mask: Form gray. Cursor cursorLink: true. oldCursor show. ^newSelf "Rectangle fromUser: 100@100."! fromUserAspectRatio: aspectPoint "Answer an instance of Rectangle that is determined by having the user designate the top left and bottom right corners, constrained so the aspect ratio is determined by aspectPoint." "Rectangle fromUserAspectRatio: Sensor waitButton" | rectangle extent ratio | Cursor origin showWhile: [rectangle _ Sensor waitButton extent: 1 @ 1]. ratio _ aspectPoint y / aspectPoint x. Cursor corner showWhile: [Sensor cursorPoint: rectangle corner. [Sensor anyButtonPressed] whileTrue: [extent _ Sensor cursorPoint - rectangle origin max: 1 @ 1. extent y * aspectPoint x > (aspectPoint y * extent x) ifTrue: [extent x: (extent y / ratio) rounded "constrain width"] ifFalse: [extent y: (extent x * ratio) rounded]. "constrain height" rectangle extent: extent. Display flash: rectangle]]. ^rectangle! left: leftNumber right: rightNumber top: topNumber bottom: bottomNumber "Answer an instance of the receiver whose left, right, top, and bottom coordinates are determined by the arguments." ^self origin: leftNumber @ topNumber corner: rightNumber @ bottomNumber! origin: originPoint corner: cornerPoint "Answer an instance of the receiver whose corners (top left and bottom right) are determined by the arguments." ^self new origin: originPoint corner: cornerPoint! origin: originPoint extent: extentPoint "Answer an instance of the receiver whose top left corner is originPoint and width by height is extentPoint." ^self new origin: originPoint extent: extentPoint! originFromUser: extentPoint "Answer an instance of the receiver that is determined by having the user designate the top left corner. The width and height are determined by extentPoint. The gridding for user selection is 1@1." ^self originFromUser: extentPoint grid: 1 @ 1! originFromUser: extentPoint grid: scaleFactor "Answer an instance of the receiver that is determined by having the user designate the top left corner. The width and height are determined by extentPoint. The gridding for user selection is scaleFactor. Assumes that the sender has determined an extent that is a proper multiple of scaleFactor. " | tempRect | Display outline: [tempRect _ (Sensor cursorPoint grid: scaleFactor) extent: extentPoint] while: [Sensor redButtonPressed] width: 2 halftone: Form gray. ^tempRect! ! Object subclass: #RemoteString instanceVariableNames: 'sourceFileNumber filePosition ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Support'! RemoteString2 comment: 'Instances of class RemoteString hold the file reference to the class comment (or any other piece of executable text). Instance Variables: sourceFileNumber index into SourceFiles filePosition position in that file for start of the string '! !RemoteString methodsFor: 'accessing'! position "Answer the location of the string on a file." ^filePosition! sourceFileNumber "Answer the index of the file on which the string is stored." ^sourceFileNumber! string "Answer the receiver's string if remote files are enabled." | theFile | (SourceFiles == nil or: [sourceFileNumber == nil]) ifTrue: [^''] ifFalse: [theFile _ SourceFiles at: sourceFileNumber. theFile position: filePosition. ^theFile nextChunk]! ! !RemoteString methodsFor: 'private'! fileNumber: sourceIndex position: anInteger sourceFileNumber _ sourceIndex. filePosition _ anInteger! string: aString onFileNumber: anInteger "Store this as my string if source files exist" | theFile | SourceFiles == nil ifFalse: [theFile _ SourceFiles at: anInteger. theFile setToEnd; readWriteShorten; cr. self string: aString onFileNumber: anInteger toFile: theFile. theFile readOnly]! string: aString onFileNumber: anInteger toFile: aFileStream "Store this as the receiver's string if source files exist." sourceFileNumber _ anInteger. filePosition _ aFileStream position. aFileStream nextChunkPut: aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RemoteString class instanceVariableNames: ''! !RemoteString class methodsFor: 'instance creation'! empty ^self newFileNumber: 1 position: 0! newFileNumber: sourceIndex position: anInteger "Answer a new instance of RemoteString for file indexed by sourceIndex, at the position anInteger. Assumes that the string is already stored on the file and the instance will be used to access it." ^self new fileNumber: sourceIndex position: anInteger! newString: aString onFileNumber: sourceIndex "Answer a new instance of RemoteString for string, aString, on file indexed by sourceIndex. Puts the string on the file and creates the remote reference." ^self new string: aString onFileNumber: sourceIndex! newString: aString onFileNumber: sourceIndex toFile: aFileStream "Answer a new instance of RemoteString for string, aString, on file indexed by sourceIndex. Puts the string on the file, aFileStream, and creates the remote reference. Assumes that the index corresponds properly to aFileStream." ^self new string: aString onFileNumber: sourceIndex toFile: aFileStream! ! ParseNode subclass: #ReturnNode instanceVariableNames: 'expr pc ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! ReturnNode comment: 'I represent an expression of the form ^expr'! !ReturnNode methodsFor: 'initialize-release'! expr: e expr _ e! expr: e encoder: encoder sourceRange: range expr _ e. encoder noteSourceRange: range forNode: self! ! !ReturnNode methodsFor: 'converting'! asReturnNode! ! !ReturnNode methodsFor: 'testing'! isReturnSelf ^expr == NodeSelf! isVariableReference ^expr isVariableReference! ! !ReturnNode methodsFor: 'code generation'! code ^expr code! emitForReturn: stack on: strm expr emitForReturn: stack on: strm. pc _ strm position! emitForValue: stack on: strm expr emitForReturn: stack on: strm. pc _ strm position! pc "used by encoder source mapping" pc == nil ifTrue: [^3]. "quick returns never generate, so pc=nil" ^pc! sizeForReturn: encoder ^expr sizeForReturn: encoder! sizeForValue: encoder ^expr sizeForReturn: encoder! ! !ReturnNode methodsFor: 'printing'! printOn: aStream indent: level aStream nextPut: $^. expr printOn: aStream indent: level. expr printCommentOn: aStream indent: level! ! ExternalPort subclass: #RS232Port instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Terminal'! RS232Port comment: 'I am an External connection to a RS232 device.'! !RS232Port methodsFor: 'accessing'! getSpeed "Return the receiver's speed (baud rate) to the sender" ^self readStatus: 2! ! !RS232Port methodsFor: 'dialing'! dialUp: aString "dial the number" self reset. self sendBuffer: 'ATDT'. self sendBuffer: aString. self sendBuffer: (String with: (Character cr))! ! !RS232Port methodsFor: 'private'! setDefaultSpeed "Set default speed to be 1200 baud" self setSpeed: 1200! setParityMode "Set the receiver into Even or Odd Parity Mode, which means receiving 7 bits data and either even or odd parity and sending even parity with 7-bit data, do this by setting XON/XOFF flow control" self writeStatus: 4 with: 1! setRawMode "Set the receiver into Raw Mode, which means sending/receiving 8 bits data and NO PARITY, do this by setting no data flow control" self writeStatus: 4 with: 0! setSpeed: baudRate "Set the baud rate of this port to be baudRate." self writeStatus: 2 with: baudRate! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RS232Port class instanceVariableNames: ''! !RS232Port class methodsFor: 'instance creation'! open: aPortNumber | newPort | (aPortNumber > self SerialMaxPortNumber or: [aPortNumber < 1]) ifTrue: [^nil]. newPort _ self new setPortNumber: aPortNumber. newPort isOpen ifTrue: [^nil]. newPort open. newPort setDefaultSpeed. ^newPort! ! ArrayedCollection subclass: #RunArray instanceVariableNames: 'runs values cacheRun cacheRunStart ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! RunArray comment: 'RunArrays provide space-efficient storage of data which tends to be constant over long runs of the possible indices. runs is an array of Integers, and each indicates the number of indices over which the corresponding value (in values) is constant.'! !RunArray methodsFor: 'accessing'! at: anInteger "Answer the element at index anInteger." ^self at: anInteger setRunAndOffset: [:run :offset | values at: run]! runLengthAt: index "Answer the length remaining in run beginning at index." ^self at: index setRunAndOffset: [:run :offset | (runs at: run) - offset]! size "Answer how many elements the receiver contains." | size | size _ 0. runs do: [:run | size _ size + run]. ^size! values "Answer the values in the receiver." ^values! ! !RunArray methodsFor: 'adding'! addFirst: value "Add value as the first element of the receiver." cacheRun _ cacheRunStart _ 1. "Clear cache" (runs size = 0 or: [values first ~= value]) ifTrue: [runs _ (Array with: 1) , runs. values _ (Array with: value) , values] ifFalse: [runs at: 1 put: runs first + 1]! addLast: value "Add value as the last element of the receiver." (runs size=0 or: [values last ~= value]) ifTrue: [runs_ runs copyWith: 1. values_ values copyWith: value] ifFalse: [runs at: runs size put: runs last+1]! ! !RunArray methodsFor: 'copying'! , aRunArray "Answer a new RunArray that is a concatenation of the receiver and aRunArray. " | new copySize newRuns newValues index | (aRunArray class == RunArray) ifFalse: [new _ self copy. "attempt to be sociable" aRunArray do: [:each | new addLast: each]. ^new]. runs size = 0 ifTrue: [^aRunArray copy]. aRunArray runs size = 0 ifTrue: [^self copy]. "Compute size of runs/values in result." copySize _ runs size + aRunArray runs size. values last = aRunArray values first ifTrue: ["runs at boundary will be merged" copySize _ copySize - 1]. newRuns _ Array new: copySize. newValues _ Array new: copySize. "copy self into result" index _ self copyFromRun: 1 offset: 0 toRun: runs size offset: runs last - 1 intoRuns: newRuns values: newValues startingAt: 1. "copy argument into result" aRunArray copyFromRun: 1 offset: 0 toRun: aRunArray runs size offset: aRunArray runs last - 1 intoRuns: newRuns values: newValues startingAt: index. ^RunArray runs: newRuns values: newValues! copyFrom: start to: stop | newRuns newValues | stop < start ifTrue: [^RunArray new]. self at: start setRunAndOffset: [:run1 :offset1 | self at: stop setRunAndOffset: [:run2 :offset2 | newRuns _ Array new: run2 - run1 + 1. newValues _ Array new: newRuns size. self copyFromRun: run1 offset: offset1 toRun: run2 offset: offset2 intoRuns: newRuns values: newValues startingAt: 1]]. ^RunArray runs: newRuns values: newValues! copyReplaceFrom: start to: stop with: replacement "head _ self copyFrom: 1 to: start - 1. tail _ self copyFrom: stop + 1 to: self size. ^ head , replacement , tail" | startRun startOffset stopRun stopOffset endRun endOffset rep repSize copySize newRuns newValues index | self at: start - 1 setRunAndOffset: [:run :offset | startRun _ run. startOffset _ offset]. (startRun = 1 and: [startOffset < 0]) ifTrue: [startRun _ 0 "head is empty"]. self at: stop + 1 setRunAndOffset: [:run :offset | stopRun _ run. stopOffset _ offset]. (endRun _ runs size) = 0 ifFalse: ["if true, receiver is empty" endOffset _ (runs at: endRun) - 1]. (stopRun = endRun and: [stopOffset > endOffset]) ifTrue: [stopRun _ endRun + 1 "tail is empty"]. "Coerce replacement to a RunArray." ((rep _ replacement) class == RunArray) ifFalse: [rep _ RunArray new. replacement do: [:each | rep addLast: each]]. "Compute the size of the copy's runs and values." repSize _ rep runs size. copySize _ startRun "head runs size" + repSize + (endRun - stopRun + 1) "tail runs size". "Determine if boundary runs will merge" repSize = 0 ifTrue: ["Replacement is empty, check for merging head and tail" (startRun > 0 and: [stopRun <= endRun and: [(values at: startRun) = (values at: stopRun)]]) ifTrue: [copySize _ copySize - 1]] ifFalse: [(startRun > 0 and: [(values at: startRun) = (rep values at: 1)]) ifTrue: [copySize _ copySize - 1]. (stopRun <= endRun and: [(rep values at: repSize) = (values at: stopRun)]) ifTrue: [copySize _ copySize - 1]]. newRuns _ Array new: copySize. newValues _ Array new: copySize. index _ startRun > 0 ifTrue: "non-empty head" [self copyFromRun: 1 offset: 0 toRun: startRun offset: startOffset intoRuns: newRuns values: newValues startingAt: 1] ifFalse: [1]. repSize > 0 ifTrue: "non-empty replacement" [index _ rep copyFromRun: 1 offset: 0 toRun: repSize offset: (rep runs at: repSize) - 1 intoRuns: newRuns values: newValues startingAt: index]. stopRun <= endRun ifTrue: "non-empty tail" [self copyFromRun: stopRun offset: stopOffset toRun: endRun offset: endOffset intoRuns: newRuns values: newValues startingAt: index]. ^RunArray runs: newRuns values: newValues! shallowCopy |nr nv len i| nr _ Array new: (len _ runs size). nv _ Array new: len. i _ 1. [i <= len] whileTrue: [nr at: i put: (runs at: i). nv at: i put: (values at: i). i _ i + 1]. ^self class runs: nr values: nv! ! !RunArray methodsFor: 'printing'! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a runarray similar to the receiver. The general format is ( class-name runs: runs values: values )" aStream nextPut: $(. aStream nextPutAll: self class name. aStream nextPutAll: ' runs: '. runs storeOn: aStream. aStream nextPutAll: ' values: '. values storeOn: aStream. aStream nextPut: $)! ! !RunArray methodsFor: 'fileIn/Out'! writeOn: aStream "Append the receiver to the argument, aStream, writing first runs and then values." aStream nextWordPut: runs size. 1 to: runs size do: [:x | aStream nextWordPut: (runs at: x). aStream nextWordPut: (values at: x)]! ! !RunArray methodsFor: 'private'! at: index setRunAndOffset: aBlock "Supply all run information to aBlock." " Tolerates index=0 and index=size+1 for copyReplace:" | run limit offset runStart runLength | index >= cacheRunStart ifTrue: [run _ cacheRun. runStart _ cacheRunStart. limit _ runs size. offset _ index - runStart. [run < limit and: [(runLength _ runs at: run) <= offset]] whileTrue: [offset _ offset - runLength. run _ run + 1. runStart _ runStart + runLength]] ifFalse: [index >= (cacheRunStart - index) ifFalse: [run _ runStart _ 1. offset _ index - runStart. limit _ runs size. [run < limit and: [(runLength _ runs at: run) <= offset]] whileTrue: [offset _ offset - runLength. run _ run + 1. runStart _ runStart + runLength]] ifTrue: [run _ cacheRun - 1. runStart _ cacheRunStart. [run >= 1 and: [(runStart _ runStart - ( runs at: run)) > index]] whileTrue: [run _ run -1]. offset _ index - runStart]]. cacheRun _ run. cacheRunStart _ runStart. ^aBlock value: run value: offset"an index into runs and values" "zero-based offset from beginning of this run"! at: index setRunOffsetAndValue: aBlock "Supply all run information to aBlock." | run limit position | " Tolerates index=0 and index=size+1 for copyReplace:" run _ 1. limit _ runs size. position _ index. [run <= limit and: [position > (runs at: run)]] whileTrue: [position _ position - (runs at: run). run _ run + 1]. run > limit ifTrue: ["adjustment for size+1" run _ run - 1. position _ position + (runs at: run)]. ^aBlock value: run "an index into runs and values" value: position - 1 "zero-based offset from beginning of this run" value: (values at: run) "value for this run"! copyFromRun: run1 offset: offset1 toRun: run2 offset: offset2 intoRuns: newRuns values: newValues startingAt: index "Copy a non-empty interval of this RunArray into runs/values being constructed. Return the index beyond the copy. Check for merging the first copied run with the last existing run." | end | end _ index + run2 - run1. (index > 1 and: [(newValues at: index - 1) = (values at: run1)]) ifTrue: ["Merge runs" end _ end - 1. run1 = run2 ifTrue: [newRuns at: index - 1 put: (newRuns at: index - 1) + offset2 - offset1 + 1] ifFalse: [newRuns at: index - 1 put: (newRuns at: index - 1) + (runs at: run1) - offset1. newRuns replaceFrom: index to: end - 1 with: runs startingAt: run1 + 1. newRuns at: end put: offset2 + 1. newValues replaceFrom: index to: end with: values startingAt: run1 + 1]] ifFalse: [run1 = run2 ifTrue: [newRuns at: index put: offset2 - offset1 + 1. newValues at: index put: (values at: run1)] ifFalse: [newRuns at: index put: (runs at: run1) - offset1. newRuns replaceFrom: index + 1 to: end - 1 with: runs startingAt: run1 + 1. newRuns at: end put: offset2 + 1. newValues replaceFrom: index to: end with: values startingAt: run1]]. ^ end + 1! runs ^runs! setRuns: newRuns setValues: newValues cacheRun _ cacheRunStart _ 1. "Clear cache" runs _ newRuns. values _ newValues! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RunArray class instanceVariableNames: ''! !RunArray class methodsFor: 'instance creation'! new "Answer a new instance of the receiver." ^self runs: Array new values: Array new! new: size withAll: value "Answer a new instance of the receiver, whose every element is equal to the argument, value." size = 0 ifTrue: [^self new]. ^self runs: (Array with: size) values: (Array with: value)! readFrom: aStream "Answer a new instance of the receiver as described on the stream, aStream." | size runs values | size _ aStream nextWord. runs _ Array new: size. values _ Array new: size. 1 to: size do: [:x | runs at: x put: aStream nextWord. values at: x put: aStream nextWord]. ^ self runs: runs values: values! runs: newRuns values: newValues "Answer a new instance of the receiver with runs and values specified by the arguments." | instance | instance _ self basicNew. instance setRuns: newRuns setValues: newValues. ^instance! ! Object subclass: #Scanner instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable ' classVariableNames: 'EndChar TypeTable ' poolDictionaries: '' category: 'System-Compiler'! Scanner comment: 'I scan a stream picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into token and its type (a Symbol) into tokenType. At the end of stream or a doit symbol, I pretend to see an endless sequence of doits.'! !Scanner methodsFor: 'initialize-release'! initScanner buffer _ WriteStream on: (String new: 40). typeTable _ TypeTable! on: inputStream "Bind the input stream, fill the character buffers" source _ inputStream. self step. self step! scan: inputStream "Bind the input stream, fill the character buffers and first token buffer" self on: inputStream. self scanToken! ! !Scanner methodsFor: 'public access'! scanFieldNames: stringOrArray "Answer with an Array of strings which are the identifiers in the input string. If passed an Array, just answer with that Array (it has already been scanned)." | strm | (stringOrArray isMemberOf: Array) ifTrue: [^stringOrArray]. self scan: (ReadStream on: stringOrArray asString). strm _ WriteStream on: (Array new: 10). [tokenType = #doIt] whileFalse: [tokenType = #word ifTrue: [strm nextPut: token]. self scanToken]. ^strm contents "Scanner new scanFieldNames: 'abc def ghi' ('abc' 'def' 'ghi' )"! scanTokens: textOrString "Answer with an Array which has been tokenized as though the input text had appeared between #( and ) in a Smalltalk literal expression." self scan: (ReadStream on: textOrString asString). self scanLitVec. ^token "Scanner new scanTokens: 'identifier keyword: 8r31 ''string'' embedded.period key:word: . ' "! ! !Scanner methodsFor: 'expression types'! scanLitVec | s | s _ WriteStream on: (Array new: 16). [tokenType = #rightParenthesis or: [tokenType = #doIt]] whileFalse: [tokenType = #leftParenthesis ifTrue: [self scanToken; scanLitVec] ifFalse: [tokenType = #word | (tokenType = #keyword) ifTrue: [self scanLitWord] ifFalse: [(token == #- and: [(typeTable at: hereChar asciiValue) = #xDigit]) ifTrue: [self scanToken. token _ token negated]]]. s nextPut: token. self scanToken]. token _ s contents! scanLitWord "accumulate keywords and asSymbol the result" | t | [(typeTable at: hereChar asciiValue) = #xLetter] whileTrue: [t _ token. self xLetter. token _ t , token]. token _ token asSymbol! scanToken [(tokenType _ typeTable at: hereChar asciiValue) == #xDelimiter] whileTrue: [self step]. "Skip delimiters fast, there almost always is one." mark _ source position - 1. (tokenType at: 1) = $x "x as first letter" ifTrue: [self perform: tokenType "means perform to compute token & type"] ifFalse: [token _ self step asSymbol "else just unique the first char"]. ^token! step | c | c _ hereChar. hereChar _ aheadChar. (aheadChar _ source next) == nil ifTrue: [aheadChar _ EndChar "doit"]. ^c! ! !Scanner methodsFor: 'multi-character scans'! xBinary tokenType _ #binary. token _ Symbol internCharacter: self step. ((typeTable at: hereChar asciiValue) = #xBinary and: [hereChar ~= $-]) ifTrue: [token _ (token , (String with: self step)) asSymbol]! xDelimiter "ignore blanks etc." self scanToken! xDigit "form a number" tokenType _ #number. (aheadChar = EndChar and: [source atEnd and: [source skip: -1. source next ~= EndChar]]) ifTrue: [source skip: -1 "Read off the end last time"] ifFalse: [source skip: -2]. token _ Number readFrom: source. self step; step! xDollar "form a Character literal" self step. "pass over $" token _ self step. tokenType _ #number "really should be Char, but rest of compiler doesn't know"! xDoubleQuote "collect comment" | aStream | aStream _ WriteStream on: (String new: 32). self step. [aStream nextPut: self step. hereChar == $"] whileFalse: [(hereChar = EndChar and: [source atEnd]) ifTrue: [^self offEnd: 'Unmatched comment quote']]. self step. currentComment == nil ifTrue: [currentComment _ OrderedCollection with: aStream contents] ifFalse: [currentComment add: aStream contents]. self scanToken! xLetter "form a word or keyword" | type prefix | buffer reset. [type _ typeTable at: hereChar asciiValue. type == #xLetter or: [type == #xDigit]] whileTrue: ["open code step for speed" buffer nextPut: hereChar. hereChar _ aheadChar. source atEnd ifTrue: [aheadChar _ EndChar "doit"] ifFalse: [aheadChar _ source next]]. (type == #period and: [tokenType _ typeTable at: aheadChar asciiValue. (tokenType == #xLetter) | (tokenType == #xBinary)]) ifTrue: "Allow embedded period in selectors" [buffer nextPut: self step. prefix _ buffer contents. self perform: tokenType. token _ prefix , token. tokenType == #binary ifTrue: [token _ token asSymbol]. ^self]. type == #colon ifTrue: [buffer nextPut: self step. tokenType _ #keyword] ifFalse: [tokenType _ #word]. token _ buffer contents! xLitQuote "UniqueStrings and Vectors" " #(1 (4 5) 2 3) #ifTrue:ifFalse:" | start | self step. "litQuote" self scanToken. tokenType = #leftParenthesis ifTrue: [start _ mark. self scanToken; scanLitVec. tokenType == #doIt ifTrue: [mark _ start. self offEnd: 'Unmatched parenthesis']] ifFalse: [(#(word keyword colon) includes: tokenType) ifTrue: [self scanLitWord]]. tokenType _ #literal! xSingleQuote "string" self step. buffer reset. [hereChar == $' and: [aheadChar == $' ifTrue: [self step. false] ifFalse: [true]]] whileFalse: [buffer nextPut: self step. (hereChar == EndChar and: [source atEnd]) ifTrue: [^self offEnd: 'Unmatched string quote']]. self step. token _ buffer contents. tokenType _ #string! ! !Scanner methodsFor: 'error handling'! notify: string self error: string! offEnd: aString "Parser overrides this" ^self notify: aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Scanner class instanceVariableNames: ''! !Scanner class methodsFor: 'class initialization'! initialize "Scanner initialize." | newTable | newTable _ Array new: 256 withAll: #xBinary. "default" newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" newTable atAll: ($0 asciiValue to: $9 asciiValue) put: #xDigit. newTable atAll: ($A asciiValue to: $Z asciiValue) put: #xLetter. newTable atAll: ($a asciiValue to: $z asciiValue) put: #xLetter. newTable at: 30 put: #doIt. newTable at: $" asciiValue put: #xDoubleQuote. newTable at: $# asciiValue put: #xLitQuote. newTable at: $$ asciiValue put: #xDollar. newTable at: $' asciiValue put: #xSingleQuote. newTable at: $( asciiValue put: #leftParenthesis. newTable at: $) asciiValue put: #rightParenthesis. newTable at: $. asciiValue put: #period. newTable at: $: asciiValue put: #colon. newTable at: $; asciiValue put: #semicolon. newTable at: $[ asciiValue put: #leftBracket. newTable at: $] asciiValue put: #rightBracket. newTable at: $^ asciiValue put: #upArrow. newTable at: $_ asciiValue put: #leftArrow. newTable at: $| asciiValue put: #verticalBar. EndChar _ 30 asCharacter. TypeTable _ newTable "bon voyage!!"! ! !Scanner class methodsFor: 'instance creation'! new ^super new initScanner! ! !Scanner class methodsFor: 'testing'! isLiteralSymbol: aSymbol "Test whether a symbol can be stored as # followed by its characters. Symbols created internally with asSymbol may not have this property, e.g. '3' asSymbol." | i ascii type next | i _ aSymbol size. i = 0 ifTrue: [^false]. ascii _ (aSymbol at: 1) asciiValue. "TypeTable should have been origined at 0 rather than 1 ..." ascii = 0 ifTrue: [^false]. type _ TypeTable at: ascii. (type == #colon or: [type == #verticalBar]) ifTrue: [^i = 1]. type == #xBinary ifTrue: [i > 2 ifTrue: [^false]. [i > 1] whileTrue: [ascii _ (aSymbol at: i) asciiValue. ascii = 0 ifTrue: [^false]. (TypeTable at: ascii) == #xBinary ifFalse: [^false]. i _ i - 1]. ^true]. type == #xLetter ifTrue: [next _ nil. [i > 1] whileTrue: [ascii _ (aSymbol at: i) asciiValue. ascii = 0 ifTrue: [^false]. type _ TypeTable at: ascii. (type == #xLetter or: [type == #xDigit or: [type == #colon and: [type ~= next]]]) ifFalse: [^false]. next _ type. i _ i - 1]. ^true]. ^false! ! Scanner initialize! MouseMenuController subclass: #ScreenController instanceVariableNames: '' classVariableNames: 'ScreenYellowButtonMenu ScreenYellowButtonMessages ' poolDictionaries: '' category: 'Interface-Support'! ScreenController comment: 'Class ScreenController represents the controller for the parts of the display screen that have no window on them. It only provides a standard yellow button menu and views (a FormView of) an infinite gray form. Class Variables: ScreenYellowButtonMenu ScreenYellowButtonMessages '! !ScreenController methodsFor: 'initialize-release'! initialize super initialize. self initializeYellowButtonMenu! ! !ScreenController methodsFor: 'control defaults'! isControlActive ^super isControlActive and: [sensor anyButtonPressed]! isControlWanted ^super isControlWanted and: [sensor anyButtonPressed]! ! !ScreenController methodsFor: 'menu messages'! exitProject Project current exit! garbageCollect Smalltalk garbageCollect! openBrowser BrowserView openOn: SystemOrganization! openCshView "Create and schedule a CShell view for communicating with Unix." Terminal openCsh! openDeskTop | accessories ws rv number | "Create and display a menu available Desk Accessories." accessories _ (SystemCall resetDeskAccessory). accessories == nil ifTrue: [^self suspend]. ws _ WriteStream with: ( String new: 100 ). [ rv _ SystemCall enumerateDeskTop: accessories. rv notNil] whileTrue: [ ws nextPutAll: rv; nextPut: (Character cr)]. ws skip: -1. number _ (PopUpMenu labels: ws contents) startUp. number = 0 ifFalse: [SystemCall openDeskTopNumbered: number]! openFileEditor "Prompt for a file name and open an editor on it." | aString | aString _ FillInTheBlank request: 'Please type a file name: ' initialAnswer: 'fileName.st'. aString = '' ifFalse: [ (FileStream fileNamed: aString) edit]! openFileList "Create and schedule a FileList view for specifying files to access." HierarchicalFileList open! openProject ProjectView open! openSystemWorkspace StringHolderView openSystemWorkspace.! openTerminalView "Create and schedule a Terminal view for communicating with the RS232 Port at 1200 baud." Terminal openPort: 1! openTranscript TextCollectorView open: Transcript label: 'System Transcript'! openWorkspace StringHolderView open! quit | menu index imagePrefix | menu _ PopUpMenu labels: ' Save, then quit Quit, without saving Continue ' lines: #(1 2). index _ menu startUp. index = 1 ifTrue: [imagePrefix _ Smalltalk getImagePrefix. imagePrefix isEmpty ifTrue: [^self]. Smalltalk saveAs: imagePrefix thenQuit: true]. index = 2 ifTrue: [Smalltalk quit]! restoreDisplay ScheduledControllers restore! save | prefix | prefix _ Smalltalk getImagePrefix. prefix isEmpty ifTrue: [^self]. Smalltalk saveAs: prefix thenQuit: false! suspend Smalltalk suspend! ! !ScreenController methodsFor: 'cursor'! centerCursorInView "Override so this doesn't happen when taking control"! ! !ScreenController methodsFor: 'bit caching'! flushDisplayBits! intersectsDisplayBoxOf: aController ^false! saveDisplayBits! showOnDisplay! ! !ScreenController methodsFor: 'private'! initializeYellowButtonMenu self yellowButtonMenu: ScreenYellowButtonMenu yellowButtonMessages: ScreenYellowButtonMessages. self redButtonMenu: ScreenYellowButtonMenu redButtonMessages: ScreenYellowButtonMessages. self blueButtonMenu: ScreenYellowButtonMenu blueButtonMessages: ScreenYellowButtonMessages! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ScreenController class instanceVariableNames: ''! !ScreenController class methodsFor: 'class initialization'! initialize "Initialize the System Menu." "ScreenController initialize. ScreenController allInstancesDo: [:c | c initializeYellowButtonMenu]" ScreenYellowButtonMenu _ PopUpMenu labels: 'restore display garbage collect exit project browser workspace file list file editor terminal project system transcript system workspace desk top save quit' lines: #(3 9 11 12). ScreenYellowButtonMessages _ #(restoreDisplay garbageCollect exitProject openBrowser openWorkspace openFileList openFileEditor openCshView openProject openTranscript openSystemWorkspace openDeskTop save quit).! ! ScreenController initialize! MouseMenuController subclass: #ScrollController instanceVariableNames: 'scrollBar marker ' classVariableNames: 'HaltedScrollBar SavedArea ' poolDictionaries: '' category: 'Interface-Support'! ScrollController comment: 'Class ScrollController represents control for scrolling using a scrollBar. It is a MouseMenuController that creates a scrollBar, rather than menus. Its subclasses add the button menus. Instances of ScrollController keep control as long as the cursor is inside the view or the scrollBar area. A scrollBar is a rectangular area representing the length of the information being viewed. It contains an inner rectangle whose top y-coordinate represents the relative position of the information visible on the screen with respect to all of the information, and whose size represents the relative amount of that information visible on the screen. The user controls which part of the information is visible by pressing the red button. If the cursor is to the right of the inner rectangle, the window onto the visible information moves upward, if the cursor is to the left, the window moves downward, and if the cursor is inside, the inner rectangle is grabbed and moved to a desired position. Instance Variables: scrollBar inside white, the outer rectangle marker inside gray, the inner rectangle Class Variables: HaltedScrollBar the area the scrollBar overlaps that needs restoration should the view be interrupted SavedArea the area the scrollBar overlaps, restored whenever the scrollBar is hidden during normal operation '! !ScrollController methodsFor: 'initialize-release'! initialize super initialize. scrollBar _ Quadrangle new. scrollBar borderWidthLeft: 2 right: 0 top: 2 bottom: 2. marker _ Quadrangle new. marker insideColor: Form gray! ! !ScrollController methodsFor: 'basic control sequence'! controlInitialize "The scrollbar has a two-pixel border, and for alignment it assumes that this sub-view has a one-pixel border and shares another one-pixel border from its neighbor/super view" super controlInitialize. scrollBar region: (0 @ 0 extent: 32 @ (view displayBox height + 2)). marker region: self computeMarkerRegion. scrollBar _ scrollBar align: scrollBar topRight with: view displayBox topLeft - (0@1). marker _ marker align: marker topCenter with: scrollBar inside topCenter. self class getSavedAreaFor: scrollBar. scrollBar displayOn: Display. self moveMarker! controlTerminate super controlTerminate. self class restoreSavedArea! ! !ScrollController methodsFor: 'control defaults'! controlActivity self scrollBarContainsCursor ifTrue: [self scroll] ifFalse: [super controlActivity]! isControlActive ^self viewHasCursor | self scrollBarContainsCursor! isControlWanted ^self viewHasCursor! ! !ScrollController methodsFor: 'scrolling'! canScroll "Answer whether there is information that is not visible and can be seen by scrolling." ^marker region height < scrollBar inside height! scroll "Check to see whether the user wishes to jump, scroll up, or scroll down." | savedCursor regionPercent | savedCursor _ sensor currentCursor. [self scrollBarContainsCursor] whileTrue: [Processor yield. regionPercent _ 100 * (sensor cursorPoint x - scrollBar left) // scrollBar width. regionPercent <= 40 ifTrue: [self scrollDown] ifFalse: [regionPercent >= 60 ifTrue: [self scrollUp] ifFalse: [self scrollAbsolute]]]. savedCursor show! scrollAmount "Answer the number of bits of y-coordinate should be scrolled. This is a default determination based on the view's preset display transformation." ^((view inverseDisplayTransform: sensor cursorPoint) - (view inverseDisplayTransform: scrollBar inside topCenter)) y! scrollView "The scroll bar jump method was used so that the view should be updated to correspond to the location of the scroll bar gray area." self scrollView: self viewDelta! scrollView: anInteger "If anInteger is not zero, tell the reciever's view to scroll by anInteger amount." anInteger ~= 0 ifTrue: [view scrollBy: 0 @ ((anInteger min: view window top - view boundingBox top) max: view window top - view boundingBox bottom). view clearInside. view display]! scrollViewDown "Scroll the receiver's view down the default amount." self scrollView: self scrollAmount! scrollViewUp "Scroll the receiver's view up the default amount." self scrollView: self scrollAmount negated! viewDelta "Answer an integer that indicates how much the view should be scrolled. The scroll bar has been moved and now the view must be so the amount to scroll is computed as a ratio of the current scroll bar position." ^view window top - view boundingBox top - ((marker top - scrollBar inside top) asFloat / scrollBar inside height asFloat * view boundingBox height asFloat) rounded! ! !ScrollController methodsFor: 'cursor'! changeCursor: aCursor "The current cursor should be set to be aCursor." sensor currentCursor ~~ aCursor ifTrue: [aCursor show]! markerContainsCursor "Answer whether the gray area inside the scroll bar area contains the cursor." ^marker inside containsPoint: sensor cursorPoint! scrollBarContainsCursor "Answer whether the cursor is anywhere within the scroll bar area." ^scrollBar containsPoint: sensor cursorPoint! ! !ScrollController methodsFor: 'marker adjustment'! computeMarkerRegion "Answer the rectangular area in which the gray area of the scroll bar should be displayed." ^0@0 extent: 10 @ ((view window height asFloat / view boundingBox height * scrollBar inside height) rounded min: scrollBar inside height)! markerDelta ^marker top - scrollBar inside top - ((view window top - view boundingBox top) asFloat / view boundingBox height asFloat * scrollBar inside height asFloat) rounded! markerRegion: aRectangle "Set the area defined by aRectangle as the marker. Fill it with gray tone." Display fill: marker mask: scrollBar insideColor. marker region: aRectangle. marker _ marker align: marker topCenter with: scrollBar inside topCenter! moveMarker "The view window has changed. Update the marker." self moveMarker: self markerDelta negated! moveMarker: anInteger "Update the marker so that is is translated by an amount corresponding to a distance of anInteger, constrained within the boundaries of the scroll bar." Display fill: marker mask: scrollBar insideColor. marker _ marker translateBy: 0 @ ((anInteger min: scrollBar inside bottom - marker bottom) max: scrollBar inside top - marker top). marker displayOn: Display! ! !ScrollController methodsFor: 'private'! scrollAbsolute | oldMarker | self changeCursor: Cursor marker. self canScroll & sensor anyButtonPressed ifTrue: [[sensor anyButtonPressed] whileTrue: [oldMarker _ marker. marker _ marker translateBy: 0@((sensor cursorPoint y - marker center y min: scrollBar inside bottom - marker bottom) max: scrollBar inside top - marker top). (oldMarker areasOutside: marker), (marker areasOutside: oldMarker) do: [:region | Display fill: region rule: Form reverse mask: Form gray]. self scrollView]. scrollBar display. self moveMarker]! scrollDown self changeCursor: Cursor down. sensor anyButtonPressed ifTrue: [self canScroll ifTrue: [self scrollViewDown. self moveMarker]]. sensor waitNoButton! scrollUp self changeCursor: Cursor up. sensor anyButtonPressed ifTrue: [self canScroll ifTrue: [self scrollViewUp. self moveMarker]]. sensor waitNoButton! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ScrollController class instanceVariableNames: ''! !ScrollController class methodsFor: 'scrollbar access'! getSavedAreaFor: aScrollBar SavedArea _ Form fromDisplay: aScrollBar. SavedArea offset: aScrollBar origin.! haltedScrollBar | tmp | tmp _ HaltedScrollBar. HaltedScrollBar _ nil. ^tmp! haltScrollBar SavedArea == nil ifTrue: [HaltedScrollBar _ nil] ifFalse: [HaltedScrollBar _ Form fromDisplay: (SavedArea boundingBox translateBy: SavedArea offset). HaltedScrollBar offset: SavedArea offset. self restoreSavedArea]! restoreHaltedScrollBar: aHaltedScrollBar aHaltedScrollBar == nil ifFalse: [SavedArea _ Form fromDisplay: (aHaltedScrollBar boundingBox translateBy: aHaltedScrollBar offset). SavedArea offset: aHaltedScrollBar offset. aHaltedScrollBar display]! restoreSavedArea SavedArea notNil ifTrue: [SavedArea displayOn: Display. SavedArea_ nil]! ! ListController subclass: #SelectionInListController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Lists'! SelectionInListController comment: 'This controllers is designed to support the pluggable SelectionInListViews (q.v.). As its operation is parameterized in the view, it must ask its view for current selection and for menu options. The tighter controller/view relationship appropriate to pluggable viewing has not yet fully matured. Note that control is not accepted if the view is empty.'! !SelectionInListController methodsFor: 'menu messages'! redButtonActivity | selectionMovement oldSelection trialSelection nextSelection | selectionMovement _ false. oldSelection _ view selection. [sensor redButtonPressed] whileTrue: [trialSelection _ view findSelection: sensor cursorPoint. trialSelection ~~ nil ifTrue: [nextSelection _ trialSelection. view moveSelectionBox: nextSelection. nextSelection ~= oldSelection ifTrue: [selectionMovement _ true]]]. nextSelection == nil ifTrue: [^self]. nextSelection = oldSelection ifTrue: [selectionMovement ifTrue: [^self]. nextSelection _ 0. view moveSelectionBox: nextSelection]. model changeRequest ifFalse: [view moveSelectionBox: oldSelection. ^ view flash]. view changeModelSelection: nextSelection! yellowButtonActivity | index menu | menu _ view yellowButtonMenu. menu == nil ifTrue: [view flash. super controlActivity] ifFalse: [index _ menu startUp. index ~= 0 ifTrue: [self controlTerminate. model perform: (menu selectorAt: index). self controlInitialize]]! ! !SelectionInListController methodsFor: 'control defaults'! isControlWanted view isEmpty ifTrue: [^ false]. ^super isControlWanted! ! ListView subclass: #SelectionInListView instanceVariableNames: 'itemList printItems oneItem partMsg initialSelectionMsg changeMsg listMsg menuMsg ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Lists'! SelectionInListView comment: 'SelectionInListView is a "pluggable" ListView. 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 listView operations (such as changeSelection) into model-specific operations (such as fileName:). An added feature of this listView is that it tries to preserve its selection through changes in the choice list. This effect, and also the choice of an intial selection are transmitted to the model just as a user-requested selection would be. See the protocol ''adaptor'' for use of the pluggable selectors. 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.'! !SelectionInListView methodsFor: 'initialization'! on: anObject printItems: flag1 oneItem: flag2 aspect: m1 change: m3 list: m4 menu: m5 initialSelection: m6 self model: anObject. printItems _ flag1. oneItem _ flag2. partMsg _ m1. changeMsg _ m3. listMsg _ m4. menuMsg _ m5. initialSelectionMsg _ m6. oneItem ifTrue: [self noTopDelimiter noBottomDelimiter. initialSelectionMsg == nil ifTrue: [self error: 'initialSelection must be specified for oneItem mode']]. self list: self getList! ! !SelectionInListView methodsFor: 'list access'! list: anArray "Set my list to be anAray." | item theList| itemList _ anArray. anArray == nil ifTrue: [isEmpty _ true. selection _ 0. ^self changeModelSelection: 0]. isEmpty _ false. printItems ifTrue: [theList _ anArray collect: [:each | each printString copyUpTo: Character cr]] ifFalse: [theList _ anArray]. list _ TextList onList: (topDelimiter == nil ifTrue: [theList] ifFalse: [(Array with: topDelimiter) , theList , (Array with: bottomDelimiter)]). item _ self initialSelection. selection _ item == nil ifTrue: [0] ifFalse: [itemList findFirst: [:x | x = item]]. self positionList. self changeModelSelection: selection! ! !SelectionInListView methodsFor: 'adaptor'! changeModelSelection: anInteger changeMsg ~~ nil ifTrue: [model perform: changeMsg with: (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger])]! getList | item | oneItem ifTrue: [item _ self initialSelection. item == nil ifTrue: [^ nil]. ^ Array with: item]. listMsg == nil ifTrue: [^nil]. ^ model perform: listMsg! initialSelection initialSelectionMsg == nil ifTrue: [^ nil]. ^ model perform: initialSelectionMsg! yellowButtonMenu menuMsg == nil ifTrue: [^ nil]. ^ model perform: menuMsg! ! !SelectionInListView methodsFor: 'controller access'! defaultControllerClass ^ SelectionInListController! ! !SelectionInListView methodsFor: 'updating'! update: aSymbol aSymbol == partMsg ifTrue: [self list: self getList; displayView]! ! !SelectionInListView methodsFor: 'displaying'! displayView isEmpty ifTrue: [self clearInside] ifFalse: [super displayView]! ! !SelectionInListView methodsFor: 'testing'! isEmpty "Answer whether the receiver contains any elements." ^ isEmpty! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SelectionInListView class instanceVariableNames: ''! !SelectionInListView class methodsFor: 'instance creation'! on: anObject aspect: aspectMsg change: changeMsg list: listMsg menu: menuMsg initialSelection: sel "Create a 'pluggable' listView viewing anObject. aspectMsg is sent to read the value of the current selection. It is also used as the changed: parameter for this view. changeMsg is sent to inform anObject of a new selection. listMsg is sent to read the current list which should be displayed. menuMsg is sent to read the yellowButton menu for this view. initialSelection is sent to read a selection to be selected initailly as a default." ^ self new on: anObject printItems: false oneItem: false aspect: aspectMsg change: changeMsg list: listMsg menu: menuMsg initialSelection: sel! on: anObject printItems: flag1 oneItem: flag2 aspect: aspectMsg change: changeMsg list: listMsg menu: menuMsg initialSelection: sel "Create a listView with these parameters - see comment in on:aspect:change: . . . Moreover, if printItems is true, then the view will show the printStrings of the items in the list, rather than assuming they are already text-like objects. And if oneItem is true the list works as a read-only list of one item. this is mainly used for the root list of various sub-browsers spawned from the browser." ^ self new on: anObject printItems: flag1 oneItem: flag2 aspect: aspectMsg change: changeMsg list: listMsg menu: menuMsg initialSelection: sel! ! LeafNode subclass: #SelectorNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! SelectorNode comment: 'I am a parse tree leaf representing a selector'! !SelectorNode methodsFor: 'code generation'! emit: stack args: nArgs on: strm self emit: stack args: nArgs on: strm super: false! emit: stack args: nArgs on: aStream super: supered | index | stack pop: nArgs. (supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue: ["short send" aStream nextPut: (code < Send ifTrue: [code] ifFalse: ["special" nArgs * 16 + code])] ifFalse: [index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256]. (index < 32 and: [nArgs <= 7]) ifTrue: ["medium send" aStream nextPut: SendLong + (supered ifTrue: [2] ifFalse: [0]). aStream nextPut: nArgs * 32 + index] ifFalse: ["long send" aStream nextPut: SendLong + 1 + (supered ifTrue: [2] ifFalse: [0]). aStream nextPut: nArgs. aStream nextPut: index]]! size: encoder args: nArgs super: supered | index | self reserve: encoder. (supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue: [^1]. "short send" (supered and: [code < Send]) ifTrue: ["super special:" code _ self code: (encoder litIndex: key) type: 5]. index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256]. (index < 32 and: [nArgs <= 7]) ifTrue: [^2]. "medium send" ^3 "long send"! ! !SelectorNode methodsFor: 'printing'! printOn: aStream indent: level aStream nextPutAll: key! ! LinkedList subclass: #Semaphore instanceVariableNames: 'excessSignals ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! Semaphore comment: 'Class Semaphore provides synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the instance the message signal and received by sending it the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent. Instance Variable: excessSignals count of signals not yet sent'! !Semaphore methodsFor: 'initialize-release'! initSignals "Consume any excess signals the receiver may have accumulated." excessSignals _ 0! terminateProcess self isEmpty ifFalse: [self removeFirst terminate]! ! !Semaphore methodsFor: 'communication'! signal "Send a signal through the receiver. If one or more processes have been suspended trying to receive a signal, allow the first one to proceed. If no process is waiting, remember the excess signal. Essential. See Object documentation whatIsAPrimitive. " self primitiveFailed "self isEmpty ifTrue: [excessSignals _ excessSignals+1] ifFalse: [Processor resume: self removeFirstLink]"! wait "The active Process must receive a signal through the receiver before proceeding. If no signal has been sent, the active Process will be suspended until one is sent. Essential. See Object whatIsAPrimitive." self primitiveFailed "excessSignals>0 ifTrue: [excessSignals _ excessSignals-1] ifFalse: [self addLastLink: Processor activeProcess suspend]"! ! !Semaphore methodsFor: 'mutual exclusion'! critical: mutuallyExcludedBlock "Evaluate mutuallyExcludedBlock only if the receiver is not currently in the process of running the critical: message. If the receiver is, evaluate mutuallyExcludedBlock after the other critical: message is finished." | blockValue | self wait. blockValue _ mutuallyExcludedBlock value. self signal. ^blockValue! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Semaphore class instanceVariableNames: ''! !Semaphore class methodsFor: 'instance creation'! forMutualExclusion "Answer a new instance of me that contains a single signal. This new instance can now be used for mutual exclusion (see the critical: message to Semaphore)." ^self new signal! new "Answer a new instance of Semaphore that contains no signals." ^self basicNew initSignals! ! Collection subclass: #SequenceableCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! SequenceableCollection comment: 'Abstract superclass for collections that have a well-defined order associated with their elements. All SequenceableCollections are accessible through keys that are integer indices. Subclasses are distinguished by how the ordering is created and whether or not the elements are restricted kinds of objects. Subclasses are ordered determined externally OrderedCollection elements ordered by user adding and removing LinkedList uses a chain of elements that must be links ArrayedCollection elements accessible by integers as external keys. ordered determined internally Interval elements must be numbers Concrete subclasses must implement methods for adding add: accessing size Subclasses should not implement methods for removing remove: ifAbsent:'! !SequenceableCollection methodsFor: 'comparing'! = otherCollection "Answer whether the species of the receiver is the same as otherCollection's species, and the receiver's size is the same as otherCollection's size, and each of the receiver's elements equal the corresponding element of otherCollection." | size index | (size _ self size) = otherCollection size ifFalse: [^false]. self species == otherCollection species ifFalse: [^false]. index _ 0. [(index _ index + 1) <= size] whileTrue: [(self at: index) = (otherCollection at: index) ifFalse: [^false]]. ^true! hash "Answer a SmallInteger unique to the receiver." self size = 0 ifTrue: [^17171]. ^(self at: 1) hash + (self at: self size) hash! ! !SequenceableCollection methodsFor: 'accessing'! atAll: anInterval put: anObject "Put anObject at every index specified by the integer elements of anInterval." anInterval do: [:index | self at: index put: anObject]! atAllPut: anObject "Put anObject at every one of the receiver's indices." | index size | index _ 0. size _ self size. [(index _ index + 1) <= size] whileTrue: [self at: index put: anObject]! first "Answer the first element of the receiver. Provide an error notification if the receiver contains no elements." self emptyCheck. ^self at: 1! indexOf: anElement "Answer the index of anElement within the receiver. If the receiver does not contain anElement, answer 0." ^self indexOf: anElement ifAbsent: [0]! indexOf: anElement ifAbsent: exceptionBlock "Answer the index of anElement within the receiver. If the receiver does not contain anElement, answer the result of evaluating the exceptionBlock." |i length| length _ self size. i _ 1. [i <= length] whileTrue: [ (self at: i) = anElement ifTrue: [^i]. i _ i + 1]. ^exceptionBlock value! indexOfSubCollection: aSubCollection startingAt: anIndex "Answer the index of the receiver's first element, such that that element equals the first element of aSubCollection, and the next elements equal the rest of the elements of aSubCollection. Begin the search at element anIndex of the receiver. If no such match is found, answer 0." | subSize firstElement index matchIndex len| subSize _ aSubCollection size. subSize = 0 ifTrue: [^0]. firstElement _ aSubCollection at: 1. subSize = 1 ifTrue: [index _ anIndex. len _ self size. [index <= len] whileTrue: [(self at: index) = firstElement ifTrue: [^index]. index _ index + 1]. ^0]. matchIndex _ anIndex. len _ self size - subSize + 1. [matchIndex <= len] whileTrue: [(self at: matchIndex) = firstElement ifTrue: [index _ 2. [(self at: matchIndex + index - 1) = (aSubCollection at: index)] whileTrue: [index = subSize ifTrue: [^matchIndex]. index _ index + 1]]. matchIndex _ matchIndex + 1]. ^0! indexOfSubCollection: aSubCollection startingAt: anIndex ifAbsent: exceptionBlock "Answer the index of the receiver's first element, such that that element equals the first element of aSubCollection, and the next elements equal the rest of the elements of aSubCollection. Begin the search at element anIndex of the receiver. If no such match is found, answer the result of evaluating exceptionBlock." | matchIndex | matchIndex _ self indexOfSubCollection: aSubCollection startingAt: anIndex. ^matchIndex = 0 ifTrue: [exceptionBlock value] ifFalse: [matchIndex]! last "Answer the last element of the receiver. Provide an error notification if the receiver contains no elements." self emptyCheck. ^self at: self size! replaceFrom: start to: stop with: replacement "This destructively replaces elements from start to stop in the receiver. Answer the receiver itself. Use copyReplaceFrom:to:with: for insertion/deletion which may alter the size of the result." replacement size = (stop - start + 1) ifFalse: [self error: 'Size of replacement doesn''t match']. ^self replaceFrom: start to: stop with: replacement startingAt: 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. No range checks are performed." | index repOff | repOff _ repStart - start. index _ start - 1. [(index _ index + 1) <= stop] whileTrue: [self at: index put: (replacement at: repOff + index)]! size "Answer how many elements the receiver contains." self subclassResponsibility! ! !SequenceableCollection methodsFor: 'adding'! grow "The receiver becomes larger." "This is not a copy of the receiver, so all shared references survive." | newArray | newArray _ self species new: self size + self growSize. newArray replaceFrom: 1 to: self size with: self. ^self become: newArray! ! !SequenceableCollection methodsFor: 'removing'! remove: oldObject ifAbsent: anExceptionBlock "Provide an error notification that SequencableCollections cannot implement removing." self shouldNotImplement! ! !SequenceableCollection methodsFor: 'copying'! , aSequenceableCollection "Answer a copy of the receiver concatenated with the argument, a SequencableCollection." ^self copyReplaceFrom: self size + 1 to: self size with: aSequenceableCollection! copyFrom: start to: stop "Answer a copy of a subset of the receiver, starting from element at index start until element at index stop." | newSize | newSize _ stop - start + 1. ^(self species new: newSize) replaceFrom: 1 to: newSize with: self startingAt: start! copyReplaceAll: oldSubCollection with: newSubCollection "Answer a copy of the receiver in which all occurrences of oldSubCollection have been replaced by newSubCollection. If there are no such occurrences, answer the receiver." | startSearch matchIndex matchIndices newCollection oldIndex newIndex newPlace | "If there are no matches, answer the receiver." (matchIndex _ self indexOfSubCollection: oldSubCollection startingAt: 1) > 0 ifFalse: [^self]. matchIndices _ OrderedCollection with: matchIndex. [(matchIndex _ self indexOfSubCollection: oldSubCollection startingAt: matchIndex + oldSubCollection size) > 0] whileTrue: [matchIndices addLast: matchIndex]. "Copy the collection, replacing all the occurrences." newCollection _ self species new: self size + ((newSubCollection size - oldSubCollection size) * matchIndices size). oldIndex _ 1. newIndex _ 1. [matchIndices isEmpty] whileFalse: [matchIndex _ matchIndices removeFirst. "Copy the subcollection up to the match." newPlace _ newIndex + matchIndex - oldIndex. newCollection replaceFrom: newIndex to: newPlace - 1 with: self startingAt: oldIndex. oldIndex _ matchIndex + oldSubCollection size. "Insert the new subcollection." newIndex _ newPlace + newSubCollection size. newCollection replaceFrom: newPlace to: newIndex - 1 with: newSubCollection startingAt: 1]. "Copy the collection beyond the last match." newCollection replaceFrom: newIndex to: newCollection size with: self startingAt: oldIndex. ^newCollection "'How noww brown cowow?' copyReplaceAll: 'ow' with: 'ello'"! copyReplaceFrom: start to: stop with: replacementCollection "Answer a copy of the receiver satisfying the following conditions: If stop is less than start, then this is an insertion; stop should be exactly start-1, start = 1 means insert before the first character, start = size+1 means append after last character. Otherwise, this is a replacement; start and stop have to be within the receiver's bounds." | newSequenceableCollection newSize endReplacement | newSize _ self size - (stop - start + 1) + replacementCollection size. endReplacement _ start - 1 + replacementCollection size. newSequenceableCollection _ self species new: newSize. newSequenceableCollection replaceFrom: 1 to: start - 1 with: self startingAt: 1. newSequenceableCollection replaceFrom: start to: endReplacement with: replacementCollection startingAt: 1. newSequenceableCollection replaceFrom: endReplacement + 1 to: newSize with: self startingAt: stop + 1. ^newSequenceableCollection! copyWith: newElement "Answer a copy of the receiver that is 1 bigger than the receiver and has newElement at the last element." | newIC | newIC _ self species new: self size + 1. newIC replaceFrom: 1 to: self size with: self startingAt: 1. newIC at: newIC size put: newElement. ^newIC! copyWithout: oldElement "Answer a copy of the receiver in which all occurrences of oldElement have been left out." | aStream | aStream _ WriteStream on: (self species new: self size). self do: [:each | oldElement = each ifFalse: [aStream nextPut: each]]. ^aStream contents! shallowCopy "Answer a copy of the receiver which shares the receiver's instance variables. " ^self copyFrom: 1 to: self size! ! !SequenceableCollection 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." | aStream index length | aStream _ WriteStream on: (self species new: self size). index _ 0. length _ self size. [(index _ index + 1) <= length] whileTrue: [aStream nextPut: (aBlock value: (self at: index))]. ^aStream contents! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." | index length | index _ 0. length _ self size. [(index _ index + 1) <= length] whileTrue: [aBlock value: (self at: index)]! findFirst: aBlock "Answer the index of the first element of the receiver for which aBlock evaluates as true." | index | index _ 0. [(index _ index + 1) <= self size] whileTrue: [(aBlock value: (self at: index)) ifTrue: [^index]]. ^ 0! findLast: aBlock "Answer the index of the last element of the receiver for which aBlock evaluates as true." | index | index _ self size + 1. [(index _ index - 1) >= 1] whileTrue: [(aBlock value: (self at: index)) ifTrue: [^index]]. ^ 0! reverse "Answer with a new sequenceable collection with its elements in the opposite order." | aStream index | aStream _ WriteStream on: (self species new: self size). index _ self size + 1. [(index _ index - 1) > 0] whileTrue: [aStream nextPut: (self at: index)]. ^aStream contents! reverseDo: aBlock "Evaluate aBlock with each of the receiver's elements as the argument, starting with the last element and taking each in sequence up to the first. For SequenceableCollections, this is the reverse of the enumeration in do:." | index | index _ self size. [index > 0] whileTrue: [aBlock value: (self at: index). index _ index - 1]! select: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect into a new sequenceable collection only those elements for which aBlock evaluates to true. Answer the new collection." | aStream index length | aStream _ WriteStream on: (self species new: self size). index _ 0. length _ self size. [(index _ index + 1) <= length] whileTrue: [(aBlock value: (self at: index)) ifTrue: [aStream nextPut: (self at: index)]]. ^aStream contents! with: aSequenceableCollection do: aBlock "Evaluate aBlock with each of the receiver's elements along with the corresponding element from aSequencableCollection." | otherCollection | self size ~= aSequenceableCollection size ifTrue: [^self errorNoMatch]. otherCollection _ ReadStream on: aSequenceableCollection. self do: [:each | aBlock value: each value: otherCollection next]! ! !SequenceableCollection methodsFor: 'converting'! asArray "Answer a new instance of Array whose elements are the elements of the receiver, in the same order." | newArray | newArray _ Array new: self size. 1 to: self size do: [:index | newArray at: index put: (self at: index)]. ^newArray! mappedBy: aSequenceableCollection "Answer a new instance of MappedCollection whose contents is the receiver and whose map is the argument, aSequencableCollection." ^(MappedCollection collection: self map: aSequenceableCollection) contents! readStream "return a readStream on me. Subclasses can provide their own kinds of Stream here." ^ReadStream on: self! writeStream "return a writeStream on me. Subclasses can provide their own kinds of Stream here." ^WriteStream on: self! ! !SequenceableCollection methodsFor: 'private'! errorOutOfBounds "Provide an error notification that an attempt was made to access a position that is out of the bounds of the receiver." self error: 'indices are out of bounds'! swap: oneIndex with: anotherIndex "Move the element at oneIndex to anotherIndex, and vice-versa." | element | element _ self at: oneIndex. self at: oneIndex put: (self at: anotherIndex). self at: anotherIndex put: element! ! Collection variableSubclass: #Set instanceVariableNames: 'tally ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! Set comment: 'The class Set represents an unordered collection of elements that are not duplicated. Instance Variables: *indexed* tally a count of the number of elements in the Set'! !Set methodsFor: 'accessing'! at: anInteger "Provide an error notification that elements of a Set are not accessible by external keys." self errorNotKeyed! at: index put: anObject "Provide an error notification that elements of a Set can not be accessed by external keys." self errorNotKeyed! size "Answer how many elements the receiver contains." ^tally! ! !Set methodsFor: 'testing'! includes: anObject "Answer whether anObject is one of the receiver's elements." ^(self basicAt: (self findElementOrNil: anObject)) ~~ nil! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." (self includes: anObject) ifTrue: [^1] ifFalse: [^0]! ! !Set methodsFor: 'adding'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." | index | newObject == nil ifTrue: [^newObject]. index _ self findElementOrNil: newObject. (self basicAt: index) == nil ifTrue: [self atNewIndex: index put: newObject]. ^newObject! grow "The receiver becomes twice as large." "This is not a copy of the receiver, so all shared references survive." | newSelf | newSelf _ self species new: self basicSize + self growSize. self do: [:each | newSelf noCheckAdd: each]. self become: newSelf! ! !Set methodsFor: 'removing'! 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." | index | index _ self find: oldObject ifAbsent: [^anExceptionBlock value]. self basicAt: index put: nil. tally _ tally - 1. self fixCollisionsFrom: index. ^oldObject! ! !Set methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of the values of the receiver as the argument. Collect the resulting values into a Set that is like the receiver. Answer the new Set." "Override the general method, so that we make a big enough set and avoid growing. " | newSet size index element | tally = 0 ifTrue: [^Set new: 2]. newSet _ Set new: (size _ self basicSize). index _ 0. [(index _ index + 1) <= size] whileTrue: [(element _ self basicAt: index) == nil ifFalse: [newSet add: (aBlock value: element)]]. ^newSet! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." | index length obj| tally = 0 ifTrue: [^self]. index _ 1. length _ self basicSize. [index <= length] whileTrue: [(obj _ self basicAt: index) == nil ifFalse: [aBlock value: obj]. index _ index + 1]! ! !Set methodsFor: 'copying'! deepCopy "Answer a copy of the receiver with its own copy of each instance variable." ^super deepCopy rehash! ! !Set methodsFor: 'private'! atNewIndex: index put: anObject self basicAt: index put: anObject. tally _ tally + 1. self fullCheck! find: anObject ifAbsent: aBlock | index | index _ self findElementOrNil: anObject. (self basicAt: index) == nil ifTrue: [^aBlock value] ifFalse: [^index]! findElementOrNil: anObject "Answer the index of the argument anObject or answer nil." | index length probe pass | length _ self basicSize. pass _ 1. index _ anObject hash \\ length + 1. [(probe _ self basicAt: index) == nil or: [probe = anObject]] whileFalse: [(index _ index + 1) > length ifTrue: [index _ 1. pass _ pass + 1. pass > 2 ifTrue: [^self grow findElementOrNil: anObject]]]. ^index! fixCollisionsFrom: index | myLength oldIndex nextIndex nextObject | oldIndex _ index. myLength _ self basicSize. [oldIndex _ oldIndex \\ myLength + 1. nextObject _ self basicAt: oldIndex. nextObject == nil] whileFalse: [nextIndex _ self findElementOrNil: nextObject. nextIndex = oldIndex ifFalse: [self basicAt: nextIndex put: nextObject. self basicAt: oldIndex put: nil]]! fullCheck self basicSize - self size <= (self basicSize // 4) ifTrue: [self grow]! noCheckAdd: anObject "Assume that the association is in the receiver and add it without checking to make sure." self basicAt: (self findElementOrNil: anObject) put: anObject. tally _ tally + 1! rehash | newSelf | newSelf _ self species new: self basicSize. self do: [:each | newSelf noCheckAdd: each]. self become: newSelf! setTally "Initialize the number of elements to be 0." tally _ 0! swap: oneElement with: otherElement | save | save _ self basicAt: oneElement. self basicAt: oneElement put: (self basicAt: otherElement). self basicAt: otherElement put: save! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Set class instanceVariableNames: ''! !Set class methodsFor: 'instance creation'! new "Create an instance of a Set." ^self new: 2! new: anInteger "Create an instance of a Set." ^(super new: (anInteger max: 1)) setTally! ! Object subclass: #SharedQueue instanceVariableNames: 'contentsArray readPosition writePosition accessProtect readSynch ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! SharedQueue comment: 'Class SharedQueue provides synchronized communication of arbitrary objects between Processes. An object is sent by sending an instance the message nextPut: and received by sending it the message next. If no object has been sent when a next message is sent, the Process requesting the object will be suspended until one is sent. Instance Variables: contentsArray readPosition writePosition accessProtect readSynch '! !SharedQueue methodsFor: 'initialize-release'! release contentsArray _ nil! ! !SharedQueue methodsFor: 'accessing'! next "Answer the object that was sent through the receiver first and has not yet been received by anyone. If no object has been sent, suspend the requesting process until one is." | value | readSynch wait. accessProtect critical: [readPosition = writePosition ifTrue: [self error: 'Error in SharedQueue synchronization'. value _ nil] ifFalse: [value _ contentsArray at: readPosition. contentsArray at: readPosition put: nil. readPosition _ readPosition + 1]]. ^value! nextPut: value "Send value through the receiver. If a Process has been suspended waiting to receive a value through the receiver, allow it to proceed." accessProtect critical: [writePosition > contentsArray size ifTrue: [self makeRoomAtEnd]. contentsArray at: writePosition put: value. writePosition _ writePosition + 1]. readSynch signal. ^value! peek "Answer the object that was sent through the receiver first and has not yet been received by anyone but do not remove it from the receiver. If no object has been sent, suspend the requesting process until one is." | value | accessProtect critical: [readPosition >= writePosition ifTrue: [readPosition _ 1. writePosition _ 1. value _ nil] ifFalse: [value _ contentsArray at: readPosition]]. ^value! size "Answer the number of objects that have been sent through the receiver and not yet received by anyone." ^writePosition - readPosition! ! !SharedQueue methodsFor: 'testing'! isEmpty "Answer whether any objects have been sent through the receiver and not yet received by anyone." ^readPosition = writePosition! ! !SharedQueue methodsFor: 'private'! init: size contentsArray _ Array new: size. readPosition _ 1. writePosition _ 1. accessProtect _ Semaphore forMutualExclusion. readSynch _ Semaphore new! makeRoomAtEnd | contentsSize | readPosition = 1 ifTrue: [contentsArray grow] ifFalse: [contentsSize _ writePosition - readPosition. 1 to: contentsSize do: [:index | contentsArray at: index put: (contentsArray at: index + readPosition - 1)]. readPosition _ 1. writePosition _ contentsSize + 1]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SharedQueue class instanceVariableNames: ''! !SharedQueue class methodsFor: 'instance creation'! new "Answer a new instance of SharedQueue that has 10 elements." ^self new: 10! new: anInteger ^super new init: anInteger! ! Integer subclass: #SmallInteger instanceVariableNames: '' classVariableNames: 'Digitbuffer ' poolDictionaries: '' category: 'Numeric-Numbers'! SmallInteger comment: 'Representation for instances of class SmallInteger are optimized for the interpreter, stored in two-s complement form. The allowable range is from minVal to maxVal, determined dynamically. Assume that minVal is -2^N and maxVal is (2^N)-1 where N is the SmallInteger. Class Variable: DigitBuffer '! !SmallInteger methodsFor: 'arithmetic'! * aNumber "Answer the result of multiplying the receiver by the argument, aNumber. Fail if the argument or the result is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." self = 0 ifTrue: [^0]. "This eliminates the need for a self=0 check in LargeInteger *" ^super * aNumber! + aNumber "Answer the result of adding the receiver to the argument. Fail if the argument or the result is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." ^super + aNumber! - aNumber "Answer the result of subtracting the argument from the receiver. Fail if the argument or the result is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." ^super - aNumber! / aNumber "Answer the result of dividing the receiver by the argument aNumber. Fail if the result is not a whole integer, or if the argument is 0 or is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." aNumber = 0 ifTrue: [^self error: 'division by 0']. (aNumber isMemberOf: SmallInteger) ifTrue: [^(Fraction numerator: self denominator: aNumber) reduced] ifFalse: [^super / aNumber]! // aNumber "Answer with the result of dividing the receiver by the argument. Round the result down towards negative infinity to make it a whole integer. Fail if the argument is 0 or is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive. " ^super // aNumber "Do with // if primitive fails"! quo: aNumber "Answer the result of dividing the receiver by the argument. Round the result down towards zero to make it a whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. See Object documentation whatIsAPrimitive." aNumber = 0 ifTrue: [^self error: 'Attempt to divide by zero']. (aNumber isMemberOf: SmallInteger) ifTrue: [self primitiveFailed] ifFalse: [^super quo: aNumber]! \\ aNumber "Take the receiver modulo the argument. Answer the remainder, rounded towards negative infinity, of the receiver divided by the argument. Fail if the argument is 0 or is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive. " ^super \\ aNumber "Do with // if primitive fails"! ! !SmallInteger methodsFor: 'bit manipulation'! bitAnd: arg "Answer the logical AND of the two's-complement representation of the receiver with the argument. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive. " ^arg bitAnd: self! bitOr: arg "Answer the logical OR the two's-complement representation of the receiver with the argument. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive. " ^arg bitOr: self! bitShift: arg "Answer a SmallInteger whose value (in two's-complement representation) is the receiver's value (in two's-complement representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts. The sign bit is extended in right shifts. Fail if the result cannot be represented as a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." ^super bitShift: arg! bitXor: arg "Answer the exclusive OR of the two's-complement representation of the receiver with the argument. Fail if the argument is not a SmallInteger. Essential. See Object documentation whatIsAPrimitive." ^arg bitXor: self! highBit "Answer the index of the high order bit of the binary representation of the receiver." | i bit | self < 0 ifTrue: [^self error: 'highBit is not defined for negative numbers']. self = 0 ifTrue: [^0]. i _ 1. bit _ 1. [self > bit] whileTrue: [i _ i + 1. bit _ bit + bit + 1]. ^i! ! !SmallInteger methodsFor: 'testing'! even "Answer whether the receiver is an even number." ^(self bitAnd: 1) = 0! odd "Answer whether the receiver is an odd number." ^(self bitAnd: 1) = 1! ! !SmallInteger methodsFor: 'comparing'! < aNumber "Answer whether the receiver is less than the argument. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." ^super < aNumber! <= aNumber "Answer whether the receiver is less than or equal to the argument. Fail if the argument is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive. " ^super <= aNumber! = aNumber "Answer whether the receiver is equal to the argument. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." ^super = aNumber! > aNumber "Answer whether the receiver is greater than the argument. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." ^super > aNumber! >= aNumber "Answer whether the receiver is greater than or equal to the argument. Fail if the argument is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^super >= aNumber! hash "Answer a SmallInteger unique to the receiver." ^self! identityHash "Answer a SmallInteger (in this case the receiver itself) whose value reflects the identity, not the contents, of the receiver." ^self! ~= aNumber "Answer whether the receiver is not equal to the argument. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." ^super ~= aNumber! ! !SmallInteger methodsFor: 'copying'! deepCopy "Answer the receiver itself." ^self! shallowCopy "Answer the receiver itself." ^self! ! !SmallInteger methodsFor: 'coercing'! coerce: aNumber "Answer an Integer that is the argument truncated." ^aNumber truncated! generality "Answer the number representing the ordering of the receiver in the generality hierarchy." ^20! ! !SmallInteger methodsFor: 'converting'! asFloat "Answer an instance of Float whose value is the value of the receiver. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !SmallInteger methodsFor: 'printing'! printOn: aStream base: b "Print a representation of the receiver on the stream, aStream, in base b where 2<=b<=256." | i x | (x _ self) < 0 ifTrue: [aStream nextPut: $-. x _ self negated]. i _ 0. [x >= b] whileTrue: [Digitbuffer at: (i _ i + 1) put: x \\ b. x _ x // b]. Digitbuffer at: (i _ i + 1) put: x. [i > 0] whileTrue: [aStream nextPut: (Character digitValue: (Digitbuffer at: i)). i _ i - 1]! ! !SmallInteger methodsFor: 'system primitives'! asObject "Answer an object that is determined by this SmallInteger as its object pointer. This is the inverse of Object asOop. See also Object documentation whatIsAPrimitive." ^self primitiveFailed! asOop "Answer an Integer which is unique to the receiver, consistent with Object asOop. See Object asOop for detailed documentation" " 0...maxVal --> maxVal+1...maxVal+1+maxVal minVal...-1 --> minVal-1+minVal...minval-2 " self >= 0 ifTrue: [^self class maxVal + 1 + self]. ^self class minVal - 1 + self! asSafeObject "Answer an object that is determined by this SmallInteger as its object pointer. This is the inverse of Object asOop. See also Object documentation whatIsAPrimitive." ^nil! digitAt: n "Answer the value of an apparent indexable field. This is provided for compatibility with LargeInteger." n = 1 ifTrue: ["Negate carefully in case I am SmallInteger minVal" self < 0 ifTrue: [^-256 - self bitAnd: 255]. ^self bitAnd: 255] ifFalse: [self < 0 ifTrue: [^(-256 - self bitShift: -8) + 1 digitAt: n - 1]. ^(self bitShift: 8 - (n bitShift: 3)) bitAnd: 255]! digitAt: n put: value "Provides an error notification. The digits of a small integer can not be modified." self error: 'You cant store in a SmallInteger'! digitLength "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Included so that a SmallInteger can behave like a LargeInteger." | maxSize minValue size | (self < 16r100 and: [self > -16r100]) ifTrue: [^1]. maxSize _ SmallInteger maxBytes. maxSize = 2 ifTrue: [^2]. "Make things go fast for 16-bit systems" minValue _ -16r100. size _ 2. [size < maxSize] whileTrue: [minValue _ minValue bitShift: 8. (self <= (-1 - minValue) and: [self > minValue]) ifTrue: [^size]. size _ size + 1]. ^maxSize! instVarAt: i "Answer a fixed variable in an object. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable." i = 1 ifTrue: [^self]. self error: 'argument too big for small integer instVarAt:'! ! !SmallInteger methodsFor: 'private'! fromString: str radix: radix | maxdigit c val | maxdigit _ radix + (radix > 10 ifTrue: [55 - 1] ifFalse: [48 - 1]). val _ 0. 1 to: str size do: [:i | c _ str at: i. (c < 48 ifFalse: [c > maxdigit]) ifTrue: [^false]. val _ val * radix + (c <= 57 ifTrue: [c - 48] ifFalse: [c < 65 ifTrue: [^false]. c - 55])]. ^val! subtractOrFail: aNumber "This is a private copy of the subtraction primitive, used by SmallInteger class initialize to discover the correct value of SmallInteger minVal." ^nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SmallInteger class instanceVariableNames: 'minVal maxVal maxBits maxBytes '! !SmallInteger class methodsFor: 'class initialization'! initialize "Initialize the digit buffer, and discover the range of SmallIntegers on this system." "SmallInteger initialize." | val bits | Digitbuffer _ Array new: 32. "Big enough for 32-bit systems" "Discover minVal and maxVal dynamically. Assume that minVal is -2^N and maxVal is (2^N)-1." val _ -1. bits _ 0. [(val subtractOrFail: 1) notNil] whileTrue: [val _ val + val. bits _ bits + 1]. minVal _ val. maxVal _ (val + 1) negated. maxBits _ bits. maxBytes _ bits + 7 // 8.! ! !SmallInteger class methodsFor: 'instance creation'! new "Fail. SmallIntegers can only be created by performing arithmetic." self error: 'SmallIntegers can only be created by performing arithmetic'! ! !SmallInteger class methodsFor: 'constants'! maxBits "Answer N such that maxVal is (2^N)-1." ^maxBits! maxBytes "Answer N such that maxVal < 256^N." ^maxBytes! maxVal "Answer the maximum value for a SmallInteger." ^maxVal! minVal "Answer the minimum value for a SmallInteger." ^minVal! ! !SmallInteger class methodsFor: 'documentation'! guideToDivision "Handy guide to the kinds of Integer division: / exact division, answer a fraction if result is not a whole integer. // answer an Integer, rounded towards negative infinity. \\ is modulo rounded towards negative infinity. quo: truncated division, rounded towards zero."! ! SmallInteger initialize! OrderedCollection variableSubclass: #SortedCollection instanceVariableNames: 'sortBlock ' classVariableNames: 'DefaultSortBlock ' poolDictionaries: '' category: 'Collections-Sequenceable'! SortedCollection comment: 'A SortedCollection is an ordered collection of elements, sorted via a function of two arguments. It is a kind of OrderedCollection whose elements are internally ordered according to the rules of the function. Instance Variables: *indexed* sortBlock The function for sorting the elements of the collection.'! !SortedCollection methodsFor: 'initialize-release'! initialize sortBlock _ DefaultSortBlock! ! !SortedCollection methodsFor: 'comparing'! = aSortedCollection "Answer whether the species of the receiver and argument are the same, and if their blocks and elements are the same." self species = aSortedCollection species ifFalse: [^false]. sortBlock = aSortedCollection sortBlock ifTrue: [^super = aSortedCollection] ifFalse: [^false]! ! !SortedCollection methodsFor: 'accessing'! at: anInteger put: anObject "Provide an error notification that storing into a SortedCollection must be done using the message add:." self error: 'to add to a sorted collection, you must use add:'! sortBlock "Answer the blockContext which is the criterion for sorting elements of the receiver." ^sortBlock! sortBlock: aBlock "Make the argument, aBlock, be the criterion for ordering elements of the receiver." sortBlock _ aBlock fixTemps. "The sortBlock must copy its home context, so as to avoid circularities!!" "Therefore sortBlocks with side effects may not work right" self size > 0 ifTrue: [self reSort]! ! !SortedCollection methodsFor: 'copying'! copy "Answer another instance just like the receiver." | newCollection | newCollection _ self species sortBlock: sortBlock. newCollection addAll: self. ^newCollection! copyEmpty "Answer a copy of the receiver without any of the receiver's elements." ^SortedCollection sortBlock: sortBlock! ! !SortedCollection methodsFor: 'adding'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." | nextIndex | self isEmpty ifTrue: [^super addLast: newObject]. nextIndex _ self indexForInserting: newObject. self insert: newObject before: nextIndex. ^newObject! addAll: aCollection "Include each element of aCollection as one of the receiver's elements." aCollection size > (self size // 3) ifTrue: ["Faster to add the new elements and resort" aCollection do: [:each | super addLast: each]. self reSort] ifFalse: ["Faster to add the elements individually in their proper places" aCollection do: [:each | self add: each]]! grow "Increase the number of elements of the collection." "We must duplicate this message from OrderedCollection so the addLast: won't cause an error." | newSelf index | newSelf _ self species new: self size + self growSize. newSelf setIndicesFrom: self growSize // 2 + 1. newSelf sortBlock: sortBlock. index _ firstIndex. [index <= lastIndex] whileTrue: [newSelf addLastNoCheck: (self basicAt: index). index _ index + 1]. self become: newSelf! ! !SortedCollection methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of my elements as the argument. Collect the resulting values into an OrderedCollection Answer with the new collection. Override superclass in order to produce OrderedCollection instead of SortedCollection. " | newCollection | newCollection _ OrderedCollection new. self do: [:each | newCollection add: (aBlock value: each)]. ^newCollection! ! !SortedCollection methodsFor: 'removing'! removeAllSuchThat: aBlock "Evaluate aBlock for each element of the receiver. Remove each element for which aBlock evaluates to true. A subclass might have to override this message to initialize additional instance variables for newCollection" | index element newCollection | newCollection _ self species new. newCollection sortBlock: self sortBlock. index _ firstIndex. [index <= lastIndex] whileTrue: [element _ self basicAt: index. (aBlock value: element) ifTrue: [newCollection add: element. self removeIndex: index] ifFalse: [index _ index + 1]]. ^newCollection! ! !SortedCollection methodsFor: 'private'! indexForInserting: newObject | index low high | low _ firstIndex. high _ lastIndex. [index _ high + low // 2. low > high] whileFalse: [(sortBlock value: (self basicAt: index) value: newObject) ifTrue: [low _ index + 1] ifFalse: [high _ index - 1]]. ^low! reSort self sort: firstIndex to: lastIndex! sort: i to: j "Sort elements i through j of self to be nondescending according to sortBlock." | di dij dj tt ij k l n | "The prefix d means the data at that index." (n _ j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort." "Sort di,dj." di _ self basicAt: i. dj _ self basicAt: j. (sortBlock value: di value: dj) "i.e., should di precede dj?" ifFalse: [self swap: i with: j. tt _ di. di _ dj. dj _ tt]. n > 2 ifTrue: "More than two elements." [ij _ (i + j) // 2. "ij is the midpoint of i and j." dij _ self basicAt: ij. "Sort di,dij,dj. Make dij be their median." (sortBlock value: di value: dij) "i.e. should di precede dij?" ifTrue: [(sortBlock value: dij value: dj) "i.e., should dij precede dj?" ifFalse: [self swap: j with: ij. dij _ dj]] ifFalse: "i.e. di should come after dij" [self swap: i with: ij. dij _ di]. n > 3 ifTrue: "More than three elements." ["Find k>i and l of Points '! !Spline methodsFor: 'accessing'! derivativePointsAt: knot "Answer an Array of three points around the element of the path knot." ^Array with: ((derivatives at: 1) at: knot) with: ((derivatives at: 2) at: knot) with: ((derivatives at: 3) at: knot)! isCyclic "Answer whether the receiver is cyclic, i.e., folds back on itself." ^self size > 3 and: [self first = self last]! ! !Spline methodsFor: 'displaying'! displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger mask: aForm "Method for display of a Spline curve approximated by straight line segments." | segment steps a b c d t | segment _ Line new. segment form: self form. segment beginPoint: self first. 1 to: self size-1 do: "for each knot" [:k | "taylor series coefficients" d _ self at: k. c _ (derivatives at: 1) at: k. b _ ((derivatives at: 2) at: k) / 2.0. a _ ((derivatives at: 3) at: k) / 6.0. "guess stepping parameter" steps _ ((derivatives at: 2) at: k) abs + ((derivatives at: 2) at: k+1) abs. steps _ 5 max: (steps x + steps y) // 100. 1 to: steps do: [:j | t _ j asFloat / steps. segment endPoint: a * t + b * t + c * t + d. segment displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger mask: aForm. segment beginPoint: segment endPoint]. segment endPoint: (self at: k+1). segment displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger mask: aForm]! ! !Spline methodsFor: 'private'! computeCurve "Compute an array for the derivatives at each knot." | size extras values | size _ self size. self isCyclic ifTrue: "for cyclic curves" [extras _ 2. "add 2 extra points to each end." values _ Array new: 2*extras + size. 1 to: extras do: [:i | values at: i put: (self at: size-extras+i-1). values at: size+extras+i put: (self at: i+1)]. values replaceFrom: extras+1 to: extras+size with: collectionOfPoints] ifFalse: [extras _ 0. values _ collectionOfPoints]. derivatives _ Array new: 3. 1 to: 3 do: [:i | derivatives at: i put: (Array new: values size)]. self derivs: values first: (derivatives at: 1) second: (derivatives at: 2) third: (derivatives at: 3). extras > 0 ifTrue: "remove extra points" [1 to: 3 do: [:i | derivatives at: i put: ((derivatives at: i) copyFrom: extras+1 to: extras+size)]]! derivs: values first: first second: second third: third "Compute the first, second and third derivitives at each point in the array values." | size v b | size _ values size. size > 2 ifTrue: [v _ Array new: size. v at: 1 put: 4.0. b _ Array new: size. b at: 1 put: 6.0*(values first-((values at: 2)*2.0)+(values at: 3)). 2 to: size-2 do: [:i | v at: i put: 4.0-(1.0/(v at: i-1)). b at: i put: 6.0*((values at: i)-((values at: i+1)*2.0) +(values at: i+2))-((b at: i-1)/(v at: i-1))]. second at: size-1 put: (b at: size-2)/(v at: size-2). size-2 to: 2 by: -1 do: [:i | second at: i put: (b at: i-1)-(second at: i+1)/(v at: i-1)]]. second at: 1 put: 0.0 asPoint. second at: size put: 0.0 asPoint. 1 to: size-1 do: [:i | first at: i put: (values at: i+1)-(values at: i)-((second at: i)*2.0 +(second at: i+1)/6.0). third at: i put: (second at: i+1)-(second at: i)].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Spline class instanceVariableNames: ''! !Spline class methodsFor: 'examples'! splineSample "Designate points on the Path by clicking the red button. Terminate by pressing any other button. A curve will be displayed, through the selected points, using a square black form." "Spline splineSample." | splineCurve aForm flag| aForm _ Form new extent: 3@3. aForm black. splineCurve _ Spline new. splineCurve form: aForm. flag _ true. [flag] whileTrue: [Sensor waitButton. Sensor redButtonPressed ifTrue: [splineCurve add: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: splineCurve last] ifFalse: [flag_false]]. splineCurve computeCurve. splineCurve isEmpty ifFalse: [splineCurve displayOn: Display. Sensor waitNoButton]. ^splineCurve! ! MouseMenuController subclass: #StandardSystemController instanceVariableNames: 'status labelForm viewForm ' classVariableNames: 'MenuWhenCollapsed ScheduledBlueButtonMenu ScheduledBlueButtonMessages ' poolDictionaries: '' category: 'Interface-Support'! StandardSystemController comment: 'Class StandardSystemController represents a controller for StandardSystemViews, that is, those views that are at the top level of a project in the system user interface. It is a kind of MouseMenuController that creates a blue button menu for moving, framing, collapsing, and closing its views, and for selecting views under its view. Instance Variables: status condition, either #active--keep control as long as the cursor is inside the view if a button is pressed #inactive -- no longer in control, deEmphasize any highlighting #open -- visible on the screen #closed -- unschedule the instance from the project labelForm the image of the label for a view that is displayed at the upper left edge viewForm the image of the view itself, whether open or collapsed Class Variables: MenuWhenCollapsed valid selections when the view is collapsed ScheduledBlueButtonMenu ScheduledBlueButtonMessages '! !StandardSystemController methodsFor: 'initialize-release'! initialize super initialize. status _ #inactive. self initializeBlueButtonMenu! initializeBlueButtonMenu "Initialize the blue button pop-up menu and corresponding array of messages for the receiver." self blueButtonMenu: ScheduledBlueButtonMenu blueButtonMessages: ScheduledBlueButtonMessages! ! !StandardSystemController methodsFor: 'control defaults'! isControlActive ^status == #active and: [sensor anyButtonPressed ifTrue: [(view containsPoint: sensor cursorPoint) ifTrue: [view isCollapsed ifTrue: [view subViewWantingControl ~~ nil] ifFalse: [true]] ifFalse: [false]] ifFalse: [true]]! isControlWanted self viewHasCursor ifFalse: [^false]. ^view isCollapsed ifTrue: [view subViewWantingControl ~~ nil] ifFalse: [true]! ! !StandardSystemController methodsFor: 'basic control sequence'! controlInitialize view refreshDisplay. self flushDisplayBits. status _ #active! controlTerminate status == #closed ifTrue: [view ~~ nil ifTrue: [view release]. self flushDisplayBits. ScheduledControllers unschedule: self. ^self]. status == #inactive ifTrue: [view deEmphasize. self saveDisplayBits. ScheduledControllers pullBottomToTop. ^self]. view deEmphasize. self saveDisplayBits! ! !StandardSystemController methodsFor: 'menu messages'! blueButtonActivity "Use special menu if collapsed" | selector | view isCollapsed ifTrue: [(selector _ MenuWhenCollapsed startUp) ~= 0 ifTrue: [self menuMessageReceiver perform: (MenuWhenCollapsed selectorAt: selector)]] ifFalse: [^ super blueButtonActivity]! close "The receiver's view should be removed from the screen and from the collection of scheduled views." model changeRequest "check for changes in progress" ifFalse: [^self]. status _ #closed. view erase! collapse "Get the receiver's view to change to a collapsed view on the screen. " | oldFrame lastIconFrame| lastIconFrame _ view lastIconFrame. view deEmphasize. oldFrame _ view displayBox. view erase. view collapse. lastIconFrame == nil ifTrue: [self moveIcon.] ifFalse: [view align: view displayBox origin with: lastIconFrame origin. Display zoom: oldFrame to: view displayBox]. view displayEmphasized! expand "Expand the collapsed view." view restoreFullView! frame "The receiver's view was collapsed; open it again and ask the user to designate its rectangular area. The save code is used for expand" view erase. self moveOpened. self trackFrame. view displayEmphasized! move "move the view to a new position on the display" view erase. view isCollapsed ifTrue: [self moveIcon] ifFalse: [self moveOpened]. view displayEmphasized! newLabel "Prompt the user for a new label" | newLabel | newLabel _ FillInTheBlank request: 'Type the new label' initialAnswer: view label. newLabel = '' ifFalse: [view deEmphasize. view newLabel: newLabel. view emphasize].! redButtonActivity ^(view labelDisplayBox containsPoint: sensor cursorPoint ) ifTrue: [ self blueButtonActivity] ifFalse:[ super redButtonActivity]! under "Deactive the receiver's scheduled view and pass control to any view that might be positioned directly underneath it and the cursor." status _ #inactive! ! !StandardSystemController methodsFor: 'scheduling'! closeAndUnschedule "Erase the receiver's view and remove it from the collection of scheduled controllers." status _ #closed. view erase. view release. ScheduledControllers unschedule: self! closeAndUnscheduleNoErase "Remove the scheduled view from the collection of scheduled controllers. Set its status to closed but do not erase." status _ #closed. view release. ScheduledControllers unschedule: self! open "Create an area on the screen in which the receiver's scheduled controller can be displayed. Make it the active controller." view window: view window viewport: (sensor cursorPoint extent: view minimumSize). status _ #open. self moveOpened. self trackFrame. ScheduledControllers scheduleActive: self! openDisplayAt: aPoint "Create an area with origin aPoint in which the receiver's scheduled view can be displayed. If necessary, translate so the view is completely on the screen. Make it the active view." view align: view viewport center with: aPoint. view translateBy: (view displayBox amountToTranslateWithin: Display boundingBox). status _ #open. ScheduledControllers scheduleActive: self! openNoTerminate "Create an area in which the receiver's scheduled view can be displayed. Make it the active view. Do not terminate the currently active process." view window: view window viewport: (sensor cursorPoint extent: view minimumSize). status _ #open. self moveOpened. self trackFrame. ScheduledControllers scheduleActiveNoTerminate: self! openNoTerminateDisplayAt: aPoint "Create an area with origin aPoint in which the receiver's scheduled view can be displayed. Make it the active view. Do not terminate the currently active process." view resizeMinimumCenteredAt: aPoint. status _ #open. ScheduledControllers scheduleActiveNoTerminate: self! ! !StandardSystemController methodsFor: 'bit cacheing'! flushDisplayBits "Get rid of the cached bits" StandardSystemView fillHoles ifTrue: [labelForm _ nil. viewForm _ nil]! intersectsDisplayBoxOf: aController "Does my views display region intersect the display region for aController's view?" ^aController view displayRegion intersects: view displayRegion! isActiveController "Am I the active controller?" ^self == ScheduledControllers activeController! labelForm "Return the cached lable form" ^labelForm! refreshDisplay "Redisplay the image of my view" (StandardSystemView fillHoles and: [view isCollapsed not]) ifTrue: [(labelForm == nil or: [viewForm == nil]) ifTrue: [view displayEmphasized] ifFalse: [labelForm displayOn: Display at: view labelDisplayBox origin. viewForm displayOn: Display at: view displayBox origin. view emphasize]] ifFalse: [view displayEmphasized]! saveDisplayBits "Cache the receiver's view's image" StandardSystemView fillHoles ifTrue: [labelForm _ view labelBits. viewForm _ view viewBits]! showOnDisplay "Redisplay the image of my view" (StandardSystemView fillHoles) ifTrue: [(labelForm == nil or: [viewForm == nil]) ifTrue: [view display] ifFalse: [labelForm displayOn: Display at: view labelDisplayBox origin. viewForm displayOn: Display at: view displayBox origin]] ifFalse: [view displayEmphasized]! viewForm "Return the cached view form" ^viewForm! ! !StandardSystemController methodsFor: 'private'! moveIcon "Ask the user to designate a new origin position for the receiver's icon. " | form | sensor cursorPoint: view displayBox origin. form _ view image. Cursor blank showWhile: [form follow: [sensor cursorPoint] while: [sensor noButtonPressed]]. view window: view window viewport: (sensor cursorPoint extent: view displayBox extent). sensor waitNoButton. sensor cursorPoint: view displayBox center! moveOpened "Ask the user to designate a new origin position for the receiver's view." | form frame location background offset | frame _ view displayBox. form _ Form extent: (view labelDisplayBox extent). offset _ (0@form extent y). location _ view labelDisplayBox origin. background _ form backgroundAt: location. form _ view labelForm. form displayAt: location. sensor cursorPoint: location + offset. Cursor origin showWhile: [Display outline: [frame _ (frame moveTo: sensor cursorPoint) rounded] do: [form moveTo: frame origin - offset restoring: background] while: [ sensor anyButtonPressed not] width: 2 halftone: Form gray. background display]. view window: view window viewport: frame! trackFrame "Track the mouse and set the displayBox of the view" | frame background| frame _ view displayBox. view minimumSize = view maximumSize ifTrue: [^self]. background _ Form fromDisplay: view labelDisplayBox. view displayLabel. sensor cursorPoint: (((frame corner max: sensor cursorPoint) max: (frame origin + view minimumSize)) min: (frame origin + view maximumSize)). Cursor corner showWhile: [Display outline: [frame corner: ((sensor cursorPoint max: (frame origin + view minimumSize)) min: (frame origin + view maximumSize))] while: [Sensor anyButtonPressed] width: 2 halftone: Form gray]. background displayAt: view labelDisplayBox origin. view window: view window viewport: frame.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StandardSystemController class instanceVariableNames: ''! !StandardSystemController class methodsFor: 'class initialization'! initialize "Initialize the class variables." "StandardSystemController initialize. StandardSystemController allInstances do: [:sc | sc initializeBlueButtonMenu]" ScheduledBlueButtonMenu _ PopUpMenu labels: 'new label\under\move\frame\collapse\close' withCRs lines: #(1 5 ). ScheduledBlueButtonMessages _ #(newLabel under move frame collapse close ). MenuWhenCollapsed _ ActionMenu labels: 'new label\under\move\expand\close' withCRs lines: #(1 4 ) selectors: #(newLabel under move expand close )! ! !StandardSystemController class methodsFor: 'access'! ScheduledBlueButtonMenu ^ ScheduledBlueButtonMenu! ScheduledBlueButtonMessages ^ ScheduledBlueButtonMessages! ! StandardSystemController initialize! View subclass: #StandardSystemView instanceVariableNames: 'labelFrame labelText isLabelComplemented savedSubViews minimumSize maximumSize iconView iconText lastFrame cacheRefresh ' classVariableNames: 'FillInHoles ' poolDictionaries: '' category: 'Interface-Support'! StandardSystemView comment: 'Class StandardSystemView represents a view that has a label above its top left corner. The text in the label identifies the kind of view. In addition to a label, the class add control over the maximum and minimum size of the display box of its instances. The default controller for a StandardSystemView is StandardSystemController. The elements of ScheduledControllers, the sole instance of ControlManager, usually contain controllers for instances of StandardSystemView. Instance Variables: labelFrame labelText isLabelComplemented true if the label is complemented savedSubViews of Views minimumSize representing minimum width and height maximumSize representing maximum width and height iconView the image of the receiver when collapsed iconText to be displayed in the collapsed view of the receiver lastFrame the last open size of the receiver cacheRefresh Class Variables: FillInHoles indicating whether or not to maintain a "clean" screen by caching image information and replacing any areas changed by moving or reframing views.'! !StandardSystemView methodsFor: 'initialize-release'! initialize super initialize. self insideColor: Form white. labelFrame _ Quadrangle new. labelFrame region: (Rectangle origin: 0 @ 0 extent: 50 @ 20). labelFrame insideColor: Form white. labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 0. self label: nil. isLabelComplemented _ false. minimumSize _ 50 @ 50. maximumSize _ Display extent. cacheRefresh _ true! release self expand. iconView == nil ifFalse: [iconView release]. super release! ! !StandardSystemView methodsFor: 'testing'! containsPoint: aPoint ^(super containsPoint: aPoint) | (self labelDisplayBox containsPoint: aPoint)! isCollapsed "Answer whether the scheduled view is collapsed (true) or expanded (false)." ^savedSubViews ~~ nil! ! !StandardSystemView methodsFor: 'label access'! deEmphasizeLabel "If the label is highlighted, reverse it." isLabelComplemented ifTrue: [self reverseLabel. isLabelComplemented _ false]! emphasizeLabel "Highlight the label." isLabelComplemented ifFalse: [self reverseLabel. isLabelComplemented _ true]! label "Answer the string that appears in the receiver's label." ^labelText isNil ifTrue: [^''] ifFalse: [labelText asString]! label: aString "Set aString to be the receiver's label." aString == nil ifTrue: [labelText _ nil. labelFrame region: (0 @ 0 extent: 0 @ 0)] ifFalse: [labelText _ (Text string: aString emphasis: 1) asParagraph. labelFrame region: (0 @ 0 extent: labelText boundingBox extent + (8 @ 4))]. iconText isNil & iconView notNil ifTrue: [iconView text: self label asText].! labelDisplayBox "Answer the rectangle that borders the visible parts of the receiver's label on the display screen." ^labelFrame align: (self isCollapsed ifTrue: [labelFrame topLeft] ifFalse: [labelFrame bottomLeft]) with: self displayBox topLeft! labelForm "Answer with a form that contains the label text." | form formBox | form _ Form extent: labelFrame extent. labelFrame displayOn: form. labelText isNil ifFalse: [formBox _ form boundingBox. labelText displayOn: form at: (formBox center - (labelText boundingBox center - labelText boundingBox topLeft)) clippingBox: formBox]. ^form! labelFrame "Answer the bounding box for the label." ^labelFrame! labelFrame: aQuadrangle "Set the bounding box for the label to be aQuadrangle." labelFrame _ aQuadrangle! newLabel: aString | oldLabelDisplayBox oldLabelComplemented | oldLabelDisplayBox _ self labelDisplayBox. oldLabelComplemented _ isLabelComplemented. self label: aString. "change label" self iconView isNil ifFalse: [self iconView isFromLabel ifTrue: [self icon: self iconFromLabel] ifFalse: [self iconText: aString]]. self isCollapsed ifTrue: [self iconView isFromLabel ifTrue: [self display] ifFalse: [self iconText: aString]. oldLabelComplemented ifTrue: [self emphasize]] ifFalse: [oldLabelDisplayBox width > self labelDisplayBox width ifTrue: [self eraseRectangle: oldLabelDisplayBox]. self displayView. oldLabelComplemented ifTrue: [self emphasizeLabel]]! ! !StandardSystemView methodsFor: 'size'! maximumSize "Answer a point representing the maximum width and height of the receiver." ^maximumSize! maximumSize: aPoint "Set the argument, aPoint, to be the maximum width and height of the receiver." maximumSize _ aPoint! minimumSize "Answer a point representing the minimum width and height of the receiver." ^minimumSize! minimumSize: aPoint "Set the argument, aPoint, to be the minimum width and height of the receiver." minimumSize _ aPoint! ! !StandardSystemView methodsFor: 'framing'! collapse "If the receiver is not already collapsed, change its view to be that of its icon only." | icon | self isCollapsed ifFalse: [lastFrame _ self displayBox. savedSubViews _ Array with: subViews with: window with: viewport. self resetSubViews. iconText isNil & labelText isNil ifTrue: [self label: 'No Label']. iconView isNil ifTrue: [icon _ Icon constantNamed: #default. icon isNil ifTrue: [iconView _ IconView on: self iconFromLabel] ifFalse: [iconView _ IconView on: icon. iconView text: self label asText]]. self addSubView: iconView. self window: nil. self setTransformation: (WindowingTransformation scale: nil translation: self transformation translation)]! erase "Clear the display box of the receiver to be gray, as in the screen background." isLabelComplemented _ false. FillInHoles ifTrue: [ScheduledControllers restoreOn: self displayRegion for: self] ifFalse: [self clear: Form gray. Display fill: self labelDisplayBox region mask: Form gray]! eraseLabel "Erase label" ScheduledControllers restoreOn: self labelDisplayBox for: self! eraseRectangle: aRectangle "Erase aRectangle of self" ScheduledControllers restoreOn: aRectangle for: self! expand "If the receiver is collapsed, change its view to be that of all of its subviews, not its icon alone." self isCollapsed ifTrue: [self removeSubView: iconView. subViews _ savedSubViews at: 1. window _ savedSubViews at: 2. viewport _ savedSubViews at: 3. savedSubViews _ nil]! getFrame "Ask the user to designate a rectangular area in which the receiver should be displayed." |frame | viewport == nil ifTrue: [frame _ Sensor cursorPoint extent: self minimumSize] ifFalse: [frame _ self displayBox. Sensor cursorPoint: frame origin]. Sensor waitNoButton. Cursor origin showWhile: [Display outline: [frame _ Sensor cursorPoint extent: frame extent] while: [Sensor anyButtonPressed not] width: 2 halftone: Form gray]. self minimumSize = self maximumSize ifTrue: [^frame]. Sensor cursorPoint: frame corner. Cursor corner showWhile: [Display outline: [frame corner: ((Sensor cursorPoint max: (frame origin + self minimumSize)) min: (frame origin + self maximumSize))] while: [Sensor anyButtonPressed] width: 2 halftone: Form gray]. ^frame! lastFullFrame ^ lastFrame! moveTo: aPoint "Move the view to aPoint. Turn off lastFrame cache. Typically used when view is off-screen to get back on." self erase. self align: self viewport topLeft with: aPoint. self display. lastFrame _ nil! resize "Determine the rectangular area for the receiver, adjusted to the minimum and maximum sizes." | aRectangle | aRectangle _ self getFrame. aRectangle _ aRectangle origin extent: ((aRectangle extent max: minimumSize) min: maximumSize). self window: self window viewport: aRectangle.! resizeMinimumCenteredAt: aPoint "Determine the rectangular area for the receiver, adjusted so that it is centered a position, aPoint." | aRectangle | aRectangle _ 0 @ 0 extent: self minimumSize. aRectangle _ aRectangle align: aRectangle center with: aPoint. self window: self window viewport: aRectangle! restoreFullView "The receiver was collapsed; open it again to original size or user's selection." | oldFrame | self erase. oldFrame _ self displayBox. self expand. lastFrame == nil ifTrue: [self resize] ifFalse: [Display zoom: oldFrame to: lastFrame. self window: self window viewport: self viewport]. self displayEmphasized. lastFrame _ oldFrame! ! !StandardSystemView methodsFor: 'controller access'! defaultControllerClass ^StandardSystemController! ! !StandardSystemView methodsFor: 'displaying'! displayEmphasized "Display the receiver with the label highlighted to indicate that it is active." self display. self emphasize.! displayLabel | clippingBox labelDisplayBox | clippingBox _ self clippingBox. labelDisplayBox _ self labelDisplayBox. self isCollapsed ifTrue: [^self]. (labelDisplayBox intersect: clippingBox) displayOn: Display. labelText isNil ifFalse: [isLabelComplemented _ false. labelText displayOn: Display at: (labelDisplayBox center - (labelText boundingBox center - labelText boundingBox topLeft)) clippingBox: clippingBox]! displayRegion ^self labelDisplayBox merge: self displayBox! displaySafe: aBlock "Put the display of the receiver at the top of all views and evaluate the argument aBlock." ScheduledControllers displaySafe: aBlock forController: self controller! displayView | clippingBox labelDisplayBox | clippingBox _ self clippingBox. labelDisplayBox _ self labelDisplayBox. self isCollapsed ifTrue: [^self]. (labelDisplayBox intersect: clippingBox) displayOn: Display. labelText isNil ifFalse: [isLabelComplemented _ false. labelText displayOn: Display at: (labelDisplayBox center - (labelText boundingBox center - labelText boundingBox topLeft)) clippingBox: clippingBox]! refreshDisplay "Redisplay myself." self cacheRefresh ifTrue: [controller refreshDisplay] ifFalse: [self displayEmphasized]! ! !StandardSystemView methodsFor: 'deEmphasizing'! deEmphasizeView self isCollapsed ifFalse: [self deEmphasizeLabel]! emphasizeView self isCollapsed ifFalse: [self emphasizeLabel]! ! !StandardSystemView methodsFor: 'clipping box access'! clippingBox "Answer the rectangular area in which the receiver can show its label." ^self isTopView ifTrue: [self labelDisplayBox] ifFalse: [super insetDisplayBox]! ! !StandardSystemView methodsFor: 'bordering'! borderWidth self isCollapsed ifTrue: [^0] ifFalse: [^super borderWidth]! insideColor self isCollapsed ifTrue: [^nil] ifFalse: [^super insideColor]! ! !StandardSystemView methodsFor: 'icon access'! icon ^iconView model! icon: anIcon "set the icon for this view to be anIcon and display" self icon: anIcon display: true! icon: anIcon display: displaying "set the icon for this view to be anIcon and display if displaying is true" | shouldEmphasize icon | icon _ anIcon. icon isNil ifTrue: [icon _ Icon constantNamed: #default ifAbsent: [nil]]. icon isNil ifTrue: [icon _ self iconFromLabel]. iconView isNil ifTrue: [iconView _ IconView new model: icon. iconView text: self iconText] ifFalse: [iconView model: icon. iconView newIcon]. self isCollapsed ifTrue: [shouldEmphasize _ isLabelComplemented. "Need to update my display location info to reflect the fact that my shape (which is currently that of my icon) has changed." displaying ifTrue: [ self erase ]. insetDisplayBox _ iconView insetDisplayBox copy. window _ iconView window. viewport _ iconView viewport. displaying ifTrue: [ self display. shouldEmphasize ifTrue: [self emphasize]]]! iconFromLabel "Return an icon that looks like my title tab" | iconForm box | iconForm _ Form extent: labelFrame corner + (0 @ 2). box _ iconForm computeBoundingBox. iconForm black. iconForm reverse: (box insetBy: 2). labelText asParagraph displayOn: iconForm at: 4 @ 2 clippingBox: box. ^Icon new form: iconForm textRect: nil! iconText ^iconText isNil ifTrue: [self label asText] ifFalse: [iconText]! iconText: string iconText _ string. iconView text: self iconText. self isCollapsed ifTrue: [self display]! iconView ^iconView! image "Answer the icon from the iconView" ^iconView image! lastIconFrame ^ lastFrame! ! !StandardSystemView methodsFor: 'bit cacheing'! cacheRefresh "Answer a Boolean depending on whether to redisplay with cached bits." ^cacheRefresh! cacheRefresh: aBoolean "Set as to whether to redisplay with cached bits." cacheRefresh _ aBoolean! labelBits "Return the labelBits or nil if collapsed." ^self isCollapsed ifTrue: [nil] ifFalse: [Form fromDisplay: self labelDisplayBox]! viewBits "Answer the viewBits or the icon if collapsed." ^self isCollapsed ifTrue: [self image] ifFalse: [Form fromDisplay: self displayBox]! ! !StandardSystemView methodsFor: 'private'! reverseLabel "Reverse the label." labelText isNil ifFalse: [Display reverse: self labelDisplayBox inside]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StandardSystemView class instanceVariableNames: ''! !StandardSystemView class methodsFor: 'instance creation'! model: aModel label: labelText minimumSize: minimumSize | view | view _ self new. view model: aModel. view label: labelText. view minimumSize: minimumSize. view borderWidth: 1. ^view! ! !StandardSystemView class methodsFor: 'class var messages'! fillHoles ^FillInHoles! fillInHoles FillInHoles _ true! leaveHoles FillInHoles _ false! ! !StandardSystemView class methodsFor: 'class initialization'! initialize FillInHoles _ false.! ! StandardSystemView initialize! Object subclass: #Stream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! Stream comment: 'The abstract class Stream is at the top of the streaming hierarchy. Its subclasses are PositionableStream and Random. Stream represents objects that stream over a self typing data structure. Subclasses must implement methods for accessing contents next nextPut: testing atEnd '! !Stream methodsFor: 'accessing'! contents "Answer the contents of the receiver." self subclassResponsibility! next "Answer the next object in the receiver." self subclassResponsibility! next: anInteger "Answer an OrderedCollection of the next anInteger number of random numbers." | aCollection | aCollection _ OrderedCollection new. anInteger timesRepeat: [aCollection addLast: self next]. ^aCollection! next: anInteger put: anObject "Put anObject into the next anInteger elements of the receiver. Answer anObject." anInteger timesRepeat: [self nextPut: anObject]. ^anObject! nextMatchFor: anObject "Gobble the next element and answer whether it is equal to anObject." ^anObject = self next! nextPut: anObject "Insert the argument, anObject, at the next position in the receiver. Answer anObject." self subclassResponsibility! nextPutAll: aCollection "Append the elements of aCollection onto the receiver. Answer aCollection." aCollection do: [:v | self nextPut: v]. ^aCollection! ! !Stream methodsFor: 'testing'! atEnd "Answer whether the position is greater than or equal to the limit." self subclassResponsibility! ! !Stream methodsFor: 'enumerating'! do: aBlock "Evaluate aBlock for each of the elements of the receiver." [self atEnd] whileFalse: [aBlock value: self next]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Stream class instanceVariableNames: ''! !Stream class methodsFor: 'instance creation'! new "Provide an error notification that Streams are not created using this message." self error: 'Streams are created with on: and with:'! ! Object subclass: #StrikeFont instanceVariableNames: 'xTable glyphs name stopConditions minAscii maxAscii maxWidth strikeLength ascent descent xOffset raster subscript superscript emphasis ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! StrikeFont comment: 'Class StrikeFont represents a compact encoding of a set of Forms corresponding to characters in the ASCII character set. All the forms are placed side by side in a large form whose height is the font height, and whose width is the sum of all the character widths. The xTable gives the left-x coordinates of the subForms corresponding to the characters. Instance Variables: xTable Of left x-coordinate of character in glyphs. glyphs Containing bits representing the characters. name Name of this font. stopConditions Of selectors to be performed in scanning text. minAscii, maxAscii Giving range supported by this font. maxWidth Width of widest char. Not presently used, but may be for font modification. strikeLength Not used. ascent, descent Max extent of chars above and below the baseline xOffset For kerning (not presently used) raster Specifies layout of the glyphs form subscript, superscript Further vertical offset relative to baseline emphasis code for synthetic bold, italic, underline, strike-out'! !StrikeFont methodsFor: 'accessing'! ascent "Answer the font's maximum extent of characters above the baseline." ^ascent! characterFormAt: character "Answer a Form copied out of the glyphs for this character." | characterForm ascii | ascii _ character asciiValue. ascii > maxAscii ifTrue: [ascii _maxAscii]. characterForm _ Form new extent: (self widthOf: character) @ self height. characterForm copyBits: (Rectangle origin: (xTable at: ascii + 1) @ 0 extent: (self widthOf: character) @ self height) from: glyphs at: 0 @ 0 clippingBox: characterForm boundingBox rule: Form over mask: Form black. ^characterForm! characterFormAt: character put: aForm "Replace the glyph for this character with aForm." | sizedForm ascii newGlyphs deltaWidth | ascii _ character asciiValue + 1. ascii > maxAscii ifTrue: [^self]. ascii < minAscii ifTrue: [^self]. "sizedForm is the argument form with the correct height and no more than maxWidth" sizedForm _ Form extent: ((aForm width min: self maxWidth) @ self height). sizedForm copyBits: aForm boundingBox from: aForm at: 0 @ 0 clippingBox: sizedForm boundingBox rule: Form over mask: Form black. newGlyphs _ Form extent: (glyphs width - (self widthOf: character) + sizedForm width) @ self height. newGlyphs "get glyphs below character" copyBits: (0@0 extent: (xTable at: ascii) @ self height) from: glyphs at: 0 @ 0 clippingBox: newGlyphs boundingBox rule: Form over mask: Form black. newGlyphs "get glyphs for character" copyBits: sizedForm boundingBox from: sizedForm at: (xTable at: ascii) @ 0 clippingBox: newGlyphs boundingBox rule: Form over mask: Form black. newGlyphs "get glyphs above character" copyBits: ((xTable at: ascii + 1) @ 0 corner: glyphs extent) from: glyphs at: (xTable at: ascii) + sizedForm width @ 0 clippingBox: newGlyphs boundingBox rule: Form over mask: Form black. glyphs _ newGlyphs. "now update xTable" deltaWidth _ sizedForm width - (self widthOf: character). ascii+1 to: xTable size do: [:i | xTable at: i put: (xTable at: i) + deltaWidth]! descent "Answer the font's maximum extent of characters below the baseline." ^descent! familySizeFace "Answer an array with family name , point size , and face code ." " (1 to: 12) collect: [:x | (TextStyle default fontAt: x) familySizeFace] " | fontName firstDigit lastDigit | fontName_ name asUppercase. firstDigit _ fontName findFirst: [:char | char isDigit]. lastDigit _ fontName findLast: [:char | char isDigit]. ^Array with: (fontName copyFrom: 1 to: firstDigit-1) with: (Integer readFromString: (fontName copyFrom: firstDigit to: lastDigit)) with: (#('B' 'I' 'BI') indexOf: (fontName copyFrom: lastDigit+1 to: fontName size))! fontName "Answer the receiver's name." emphasis >= 4 ifTrue: [^name, 'u'] ifFalse: [^name]! glyphs "Answer a Form containing the bits representing the characters of the receiver." ^glyphs! height "Answer the height of the font, total of maximum extents of characters above and below the baseline." ^self ascent + self descent! maxAscii "Answer the integer that is the last Ascii character value of the receiver." ^maxAscii! maxWidth "Answer the integer that is the width of the receiver's widest character." ^maxWidth! minAscii "Answer the integer that is the first Ascii character value of the receiver." ^minAscii! name "Answer the receiver's name." ^name! name: aString "Set the receiver's name." name _ aString.! raster "Answer an integer that specifies the layout of the glyphs' form." ^raster! spaceWidth "Answer the width of the argument as a character in the receiver." | ascii | ascii _ $ asciiValue. ^(xTable at: ascii + 2) - (xTable at: ascii + 1)! stopConditions "Answer the array of selectors to be performed in scanning text made up of the receiver's characters." ^stopConditions! subscript "Answer an integer that is the further vertical offset relative to the baseline for positioning characters as subscripts." ^subscript! subscript: anInteger "Answer an integer that is the further vertical offset relative to the baseline for positioning characters as subscripts." subscript _ anInteger.! superscript "Answer an integer that is the further vertical offset relative to the baseline for positioning characters as superscripts." ^superscript! superscript: anInteger "Answer an integer that is the further vertical offset relative to the baseline for positioning characters as superscripts." superscript _ anInteger.! widthOf: aCharacter "Answer the width of the argument as a character in the receiver." | ascii | ascii _ (aCharacter asciiValue min: maxAscii + 1) max: minAscii. ^(xTable at: ascii + 2) - (xTable at: ascii + 1)! xTable "Answer an array of the left x-coordinate of characters in glyphs." ^xTable! ! !StrikeFont methodsFor: 'testing'! checkCharacter: character "Answer a character that is within the ascii range of the receiver--either character or the last character in the receiver." | ascii | ascii _ character asciiValue. ((ascii < minAscii) or: [ascii > maxAscii]) ifTrue: [^maxAscii asCharacter] ifFalse: [^character]! ! !StrikeFont methodsFor: 'displaying'! characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger mask: aForm "Simple, slow, primitive method for displaying a line of characters. No wrap-around is handled." | ascii character characterForm | anInterval do: [:i | ascii _ (character _ sourceString at: i) asciiValue. (ascii < minAscii or: [ascii > maxAscii]) ifTrue: [character _ (ascii _ maxAscii) asCharacter]. characterForm _ self characterFormAt: character. characterForm displayOn: Display at: aPoint clippingBox: clippingRectangle rule: ruleInteger mask: aForm. aPoint x: aPoint x + (self widthOf: character)]. ^aPoint x! composeWord: aTextLineInterval in: sourceString beginningAt: xInteger "Non-primitive composition of a word -- add up widths of characters, add sum to beginning x and answer the resulting x. Similar to performance of scanning primitive, but without stop conditions." | character resultX | resultX _ xInteger. aTextLineInterval do: [:i | character _ sourceString at: i. resultX _ resultX + (self widthOf: character)]. ^resultX! displayLine: aString at: aPoint "Display the characters in aString, starting at position aPoint." self characters: (1 to: aString size) in: aString displayAt: aPoint clippedBy: Display boundingBox rule: Form over mask: Form black! ! !StrikeFont methodsFor: 'emphasis'! emphasis "Answer the integer code for synthetic bold, itallic, and underline." ^emphasis! emphasis: code "Set the integer code for synthetic bold, itallic, underline, and strike-out, where bold=1, itallic=2, underlined=4, struck out=8, subscript=16, superscript=32." emphasis _ code! emphasized: code "Answer a copy of the receiver with emphasis set to code." "TextStyle default fontAt: 9 put: ((TextStyle default fontAt: 1) emphasized: 4)" ^self copy emphasis: code + emphasis! emphasized: code named: aString "Answer a copy of the receiver with emphasis set to code." | copy | copy _ self copy emphasis: (code + emphasis). copy name: aString. ^copy! ! !StrikeFont methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." aStream nextPutAll: self class name, ' name ', name, ' emphasis '; print: emphasis; nextPut: Character cr.! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver." | s | s _ WriteStream on: (String new: 128). s nextPutAll: '#(' , name printString; space. s print: minAscii; space. s print: maxAscii; space. s print: maxWidth; space. s print: strikeLength; space. s print: ascent; space. s print: descent; space. s print: xOffset; space. s print: raster; space. s nextPutAll: ') '. aStream nextPutAll: '(StrikeFont new setFrom: ' , s contents. aStream nextPutAll: ' glyphs: '. (glyphs storeOn: aStream base: 10). aStream nextPutAll: ' xTable: '. (xTable storeOn: aStream). aStream nextPut: $)! ! !StrikeFont methodsFor: 'private'! ascent: anInteger "Set the font's maximum extent of characters above the baseline." ascent _ anInteger.! characterForm: character "Answer a Form copied out of the glyphs for this character." ^self characterFormAt: character! glyphs: aForm "Set the Form containing the bits representing the characters of the receiver." glyphs _ aForm.! scrunch "Run through glyphs, taking one bit of white space out, and update xTable accordingly." | x char form | x _ (self widthOf: (Character value: minAscii))-1. minAscii+1 to: maxAscii do: [:ascii | char _ Character value: ascii. form _ self characterFormAt: char. form displayOn: glyphs at: x@0. xTable at: ascii+1 put: x. x _ x + form width-1]. xTable at: maxAscii+2 put: x! setFrom: anArray glyphs: someGlyphs xTable: aXtable "Initialize the instance variables." name _ anArray at: 1. minAscii _ anArray at: 2. maxAscii _ anArray at: 3. maxWidth _ anArray at: 4. strikeLength _ anArray at: 5. ascent _ anArray at: 6. descent _ anArray at: 7. xOffset _ anArray at: 8. raster _ anArray at: 9. superscript _ ascent - descent // 3. subscript _ descent - ascent // 3. emphasis _ 0. glyphs _ someGlyphs. xTable _ aXtable. "This has to do with scanning characters, not with the font" stopConditions _ Array new: 258. stopConditions atAllPut: nil. 1 to: (minAscii - 1) do: [:index | stopConditions at: index put: #characterNotInFont]. (maxAscii + 3) to: stopConditions size do: [:index | stopConditions at: index put: #characterNotInFont].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StrikeFont class instanceVariableNames: ''! !StrikeFont class methodsFor: 'examples'! sample "Displays a line of text on the display screen at the location of the cursor. The example depends on the strike font file 'Serif10.strike' existing." "StrikeFont sample." (TextStyle default fontAt: 1) displayLine: 'A line of text in serif style' at: Sensor cursorPoint.! ! ArrayedCollection variableByteSubclass: #String instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Text'! String comment: 'Instances of class String are indexed collections of Characters. Instance Variables: *byte indexed* Each String stores 8-bit bytes, but the access protocol translates between these and real Character instances.'! !String methodsFor: 'accessing'! at: anInteger "Answer the Character stored in the field of the receiver indexed by the argument. Fail if the index argument is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. " ^Character value: (super at: anInteger)! at: index put: aCharacter "Store the argument aCharacter in the field of the receiver indicated by the index. Answer aCharacter. Fail if the index is not an Integer or is out of bounds, or if the argument is not a Character. Essential. See Object documentation whatIsAPrimitive." (aCharacter isKindOf: Character) ifTrue: [super at: index put: aCharacter asciiValue. ^aCharacter] ifFalse: [self error: 'Strings only store Characters']! basicAt: index "Answer with the Character stored in the field of the receiver indexed by the argument. Fail if the index argument is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." ^Character value: (super at: index)! basicAt: index put: aCharacter "Store the argument aCharacter in the field of the receiver indicated by the index. Answer with aCharacter. Fail if the index is not an Integer or is out of bounds, or if the argument is not a Character. Essential. See Object documentation whatIsAPrimitive." (aCharacter isKindOf: Character) ifTrue: [super at: index put: aCharacter asciiValue. ^aCharacter] ifFalse: [self error: 'Strings only store Characters']! findString: subString startingAt: start "Answer the index of subString within the receiver, starting at start. If no such match is found, answer 0. " ^self indexOfSubCollection: subString startingAt: start! findString: subString startingAt: start ifAbsent: exceptionBlock "Answer the index of subString within the receiver, starting at start. If no such match is found, answer the result of evaluating exceptionBlock. " ^self indexOfSubCollection: subString startingAt: start ifAbsent: exceptionBlock! indexOfSubCollection: aSubCollection startingAt: anIndex "Answer the index of the receiver's first element, such that that element equals the first element of aSubCollection, and the next elements equal the rest of the elements of aSubCollection. Begin the search at element anIndex of the receiver. If no such match is found, answer 0." | subSize firstElement index matchIndex len| subSize _ aSubCollection size. subSize = 0 ifTrue: [^0]. firstElement _ aSubCollection at: 1. subSize = 1 ifTrue: [index _ anIndex. len _ self size. [index <= len] whileTrue: [(self at: index) == firstElement ifTrue: [^index]. index _ index + 1]. ^0]. matchIndex _ anIndex. len _ self size - subSize + 1. [matchIndex <= len] whileTrue: [(self at: matchIndex) == firstElement ifTrue: [index _ 2. [(self at: matchIndex + index - 1) == (aSubCollection at: index)] whileTrue: [index = subSize ifTrue: [^matchIndex]. index _ index + 1]]. matchIndex _ matchIndex + 1]. ^0! 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: String) ifTrue: [self primReplaceFrom: start to: stop with: replacement startingAt: repStart] ifFalse: [super replaceFrom: start to: stop with: replacement startingAt: repStart]! replaceFrom: start to: stop withByteArray: aByteArray startingAt: repStart "This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the byte array, aByteArray. Answer the receiver." | index repOff characterTable | repOff _ repStart - start. characterTable _ Character characterTable. "in-line asCharacter for speed" index _ start - 1. [(index _ index + 1) <= stop] whileTrue: [self at: index put: (characterTable at: (aByteArray at: repOff + index)+1)]! size "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." ^self basicSize! string "Answer the receiver itself. This is for compatibility with other text classes." ^self! ! !String methodsFor: 'comparing'! < aString "Answer true if and only if the receiver collates before aString. The collation sequence is ascii with case differences ignored." ^(self compare: aString) = 1! <= aString "Answer true if and only if the receiver collates before aString or is the same as aString. The collation sequence is ascii with case differences ignored." ^(self compare: aString) <= 2! = aString "Answer whether the species of the receiver and the argument are the same, and their size is the same, and each of the receiver's characters are the same as the corresponding character of the argument." ^super = aString! > aString "Answer true if and only if the receiver collates after aString. The collation sequence is ascii with case differences ignored." ^(self compare: aString) = 3! >= aString "Answer true if and only if the receiver collates after aString or is the same as aString. The collation sequence is ascii with case differences ignored." ^(self compare: aString) >= 2! hash "Answer with a SmallInteger unique to the receiver." | l m | (l _ m _ self size) <= 2 ifTrue: [l = 2 ifTrue: [m _ 3] ifFalse: [l = 1 ifTrue: [^((self at: 1) asciiValue bitAnd: 127) * 106]. ^21845]]. ^(self at: 1) asciiValue * 48 + ((self at: (m - 1)) asciiValue + l)! match: text "Answer whether text matches the pattern in the receiver. Matching ignores upper/lower case differences. Where the receiver contains #, text may contain any single character. Where the receiver contains *, text may contain any sequence of characters." | pattern scanning p t back textStream startScan | pattern _ ReadStream on: self. textStream _ ReadStream on: text. scanning _ false. [pattern atEnd] whileFalse: [p _ pattern next. p = $* ifTrue: [pattern atEnd ifTrue: [^true]. scanning _ true. startScan _ pattern position] ifFalse: [textStream atEnd ifTrue: [^false]. t _ textStream next. (t asUppercase = p asUppercase or: [p = $#]) ifFalse: [scanning ifFalse: [^false]. back _ startScan - pattern position. pattern skip: back. textStream skip: back + 1]]. (scanning and: [pattern atEnd and: [textStream atEnd not]]) ifTrue: [back _ startScan - pattern position. pattern skip: back. textStream skip: back + 1] ]. ^textStream atEnd " Examples: 'xyz' match: 'Xyz' true 'x#z' match: 'x@z' true 'x*z' match: 'x whyNot? z' true '*x' match: 'xx' true "! match: text ignoreCase: caseFlag "Answer whether text matches the pattern in the receiver. Matching includes upper/lower case differences if caseFlag is false. Where the receiver contains #, text may contain any single character. Where the receiver contains *, text may contain any sequence of characters." | pattern scanning p t back textStream startScan | pattern _ ReadStream on: self. textStream _ ReadStream on: text. scanning _ false. [pattern atEnd] whileFalse: [p _ pattern next. p = $* ifTrue: [pattern atEnd ifTrue: [^true]. scanning _ true. startScan _ pattern position] ifFalse: [textStream atEnd ifTrue: [^false]. t _ textStream next. (p = $# or: [ caseFlag ifTrue: [t asUppercase = p asUppercase ] ifFalse: [t = p]]) ifFalse: [scanning ifFalse: [^false]. back _ startScan - pattern position. pattern skip: back. textStream skip: back + 1]]. (scanning and: [pattern atEnd and: [textStream atEnd not]]) ifTrue: [back _ startScan - pattern position. pattern skip: back. textStream skip: back + 1] ]. ^textStream atEnd " Examples: 'xyz' match: 'Xyz' true 'x#z' match: 'x@z' true 'x*z' match: 'x whyNot? z' true '*x' match: 'xx' true "! sameAs: aString "Answer whether the receiver collates precisely with aString. The collation sequence is ascii with case differences ignored." ^(self compare: aString) = 2! spellAgainst: aString "Answer an integer between 0 and 100 indicating how similar the argument is to the receiver. No case conversion is done." | i1 i2 size1 size2 score maxLen | size1 _ self size. size2 _ aString size. maxLen _ size1 max: size2. score _ 0. i1 _ i2 _ 1. [i1 <= size1 and: [i2 <= size2]] whileTrue: [(self at: i1) = (aString at: i2) ifTrue: [score _ score+1. "match" i1 _ i1+1. "advance both" i2 _ i2+1] ifFalse: [(i2 < size2 and: [(self at: i1) = (aString at: i2+1)]) ifTrue: [i2 _ i2+1] "skip in other" ifFalse: [(i1 < size1 and: [(self at: i1+1) = (aString at: i2)]) ifTrue: [i1 _ i1+1] "skip in self" ifFalse: [i1 _ i1+1. "miss - advance both" i2 _ i2+1] ] ] ]. score = maxLen ifTrue: [^100] ifFalse: [^100*score//maxLen] " 'Smalltalk' spellAgainst: 'Smalltlak' "! ! !String methodsFor: 'copying'! copyFrom: start to: stop "Answer a copy of a subset of the receiver, starting from element at index start until element at index stop." | newSize | newSize _ stop - start + 1. ^(self species new: newSize) primReplaceFrom: 1 to: newSize with: self startingAt: start! copyUpTo: aCharacter "Answer a copy of the receiver from index 1 to the first occurrence of aCharacter, non-inclusive." | index | index _ self indexOf: aCharacter ifAbsent: [^self]. ^self copyFrom: 1 to: index-1! deepCopy "Answer a copy of the receiver with its own copy of each instance variable." "DeepCopy would otherwise mean make a copy of the character; since characters are unique, just return a shallowCopy." ^self shallowCopy! ! !String methodsFor: 'printing'! isLiteral ^true! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver. Print inside string quotes, doubling imbedded quotes." ^self storeOn: aStream! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a string similar to the receiver. The general format for strings includes printing inside string quotes, doubling imbedded quotes." | i length x | aStream nextPut: $'. i _ 0. length _ self size. [(i _ i + 1) <= length] whileTrue: [aStream nextPut: (x _ self at: i). x == $' ifTrue: [aStream nextPut: x]]. "embedded quotes get doubled" aStream nextPut: $'! ! !String methodsFor: 'converting'! asByteArray "Convert the receiver to a ByteArray." ^(ByteArray new: self size) replaceFrom: 1 to: self size withString: self startingAt: 1! asDisplayText "Answer a DisplayText whose text string is the receiver." ^DisplayText text: self asText! asFileName "Answer a string made up from the receiver that is an acceptable file name." ^FileDirectory default checkName: self fixErrors: true! asLowercase "Answer a string made up from the receiver whose characters are all lowercase." | aStream | aStream _ WriteStream on: (String new: self size). self do: [:aCharacter | aStream nextPut: aCharacter asLowercase]. ^aStream contents! asNumber "Answer the number created by interpreting the receiver as the string representation of a number." ^Number readFromString: self! asParagraph "Answer a Paragraph whose text string is the receiver." ^Paragraph withText: self asText! asString "Answer the receiver itself." ^self! asSymbol "Answer the unique symbol whose characters are the characters of the string." ^Symbol intern: self! asText "Answer a Text whose string is the receiver." ^Text fromString: self! asUppercase "Answer a string made up from the receiver whose characters are all uppercase." | aStream | aStream _ WriteStream on: (String new: self size). self do: [:aCharacter | aStream nextPut: aCharacter asUppercase]. ^aStream contents! contractTo: charCount "Shorten by ellipsis if too long" | half | self size > charCount ifTrue: [half _ charCount // 2. ^ self copyReplaceFrom: half to: self size - (charCount-half) + 2 with: '...'] " 'antidisestablishmentarianism' contractTo: 10 'anti...ism' "! withCRs "substitute CRs for backslashes" ^ self collect: [:char | char = $\ ifTrue: [Character cr] ifFalse: [char]]! ! !String methodsFor: 'displaying'! displayAt: aPoint "Show a representation of the receiver as a DisplayText at location aPoint on the display screen." self asDisplayText displayAt: aPoint! displayOn: aDisplayMedium at: aPoint "Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium." self asDisplayText displayOn: aDisplayMedium at: aPoint! ! !String methodsFor: 'private'! compare: s | i len endResult u1 u2 mylen | mylen _ self size. len _ s size. mylen < len ifTrue: [len _ mylen. endResult _ 1] ifFalse: [endResult _ mylen = len ifTrue: [2] ifFalse: [3]]. i _ 0. [(i _ i + 1) <= len] whileTrue: [u1 _ self at: i. u2 _ s at: i. u1 = u2 ifFalse: [u1 _ u1 asUppercase. u2 _ u2 asUppercase. u1 = u2 ifFalse: [^u1 < u2 ifTrue: [1] ifFalse: [3]]]]. ^endResult! 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! stringhash ^self hash! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! String class instanceVariableNames: ''! !String class methodsFor: 'instance creation'! fromString: aString "Answer a new String that is a copy of the argument, aString." | newString | newString _ self new: aString size. 1 to: aString size do: [:i | newString at: i put: (aString at: i)]. ^newString! readFrom: inStream "Answer a new String that is determined by reading the stream, inStream. Embedded double quotes become the quote Character." | outStream char done | outStream _ WriteStream on: (String new: 16). "go to first quote" inStream skipTo: $'. done _ false. [done or: [inStream atEnd]] whileFalse: [char _ inStream next. char = $' ifTrue: [char _ inStream next. char = $' ifTrue: [outStream nextPut: char] ifFalse: [inStream skip: -1. done _ true]] ifFalse: [outStream nextPut: char]]. ^outStream contents! ! !String class methodsFor: 'examples'! stringSampler "To see the string displayed at the cursor point, execute this expression and select a point by pressing a mouse button." "String stringSampler" 'this is some text' displayOn: Display at: Sensor waitButton! ! Model subclass: #StringHolder instanceVariableNames: 'contents isLocked ' classVariableNames: 'Workspace ' poolDictionaries: '' category: 'Interface-Text'! StringHolder comment: 'A model for providing a layer of structure in order to view an aspect of structured information that is a string. Instance variables contents isLocked whether or not the contents has been changed but not stored '! !StringHolder methodsFor: 'initialize-release'! initialize "Initialize the state of the receiver to be unlocked with default contents." isLocked _ false. contents _ self defaultContents! ! !StringHolder methodsFor: 'accessing'! contents "Answer the contents that the receiver is holding--presumably a string." ^contents! contents: aString "Set aString to be the contents of the receiver." contents _ aString string! ! !StringHolder methodsFor: 'doIt/accept/explain'! doItContext "Answer the context in which a text selection can be evaluated." ^nil! doItReceiver "Answer the object that should be informed of the result of evaluating a text selection." ^nil! ! !StringHolder methodsFor: 'lock access'! isLocked "Answer whether the receiver is locked, that is, has the contents of the receiver been modified since the last time it was unlocked." ^isLocked! isUnlocked "Answer whether the receiver is unlocked." ^isLocked not! lock "Note that the receiver has been modified." isLocked _ true! unlock "Unlock the receiver. Any modification has presumably been saved." isLocked _ false! ! !StringHolder methodsFor: 'private'! defaultContents ^ ''! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StringHolder class instanceVariableNames: ''! !StringHolder class methodsFor: 'class initialization'! initialize "The class variables were initialized once, and subsequently filled with information. Re-executing this method is therefore dangerous. workSpace _ StringHolder new. StringHolder initialize"! ! !StringHolder class methodsFor: 'instance creation'! new ^super new initialize! ! !StringHolder class methodsFor: 'workspace constants'! workspace "Answer the model for the system workspace." ^Workspace! ! StringHolder initialize! TextEditor subclass: #StringHolderController instanceVariableNames: 'isLockingOn ' classVariableNames: 'CodeYellowButtonMenu CodeYellowButtonMessages ' poolDictionaries: '' category: 'Interface-Text'! StringHolderController comment: 'I represent a ParagraphEditor for a single paragraph of text, omitting alignment commands. I provide items in the yellow button menu so that the text selection can be evaluated and so that the contents of the model can be stored or restored. doIt -- evaluate the text selection as an expression printIt -- same as doIt but insert a description of the result after the selection accept -- store the contents of the StringHolder into the model cancel -- store the contents of the model into the StringHolder Instance Variables: isLockingOn true if the view has been editted so that it should not be closed without warning the user. '! !StringHolderController methodsFor: 'initialize-release'! initialize super initialize. isLockingOn _ true! ! !StringHolderController methodsFor: 'lock access'! isLockingOff "Answer whether no unsaved modifications have been carried out using the receiver." ^isLockingOn not! isLockingOn "Answer whether unsaved modifications have been carried out using the receiver." ^isLockingOn! lockModel "If the receiver is lock, do so to the receiver's model." isLockingOn ifTrue: [model lock]! turnLockingOff "Turn off the receiver's indication that it is locked." isLockingOn _ false! turnLockingOn "Turn on the receiver's indication that it is locked." isLockingOn _ true! unlockModel "If the receiver is locked, then the model probably is, but should not be, so unlock the model." isLockingOn ifTrue: [model unlock]! ! !StringHolderController methodsFor: 'menu messages'! accept super accept. model contents: paragraph text. self unlockModel! cancel super cancel. self unlockModel! doIt "Treat the current text selection as an expression; evaluate it" | result | self controlTerminate. result _ model doItReceiver class evaluatorClass new evaluate: self selectionAsStream in: model doItContext to: model doItReceiver notifying: self ifFail: [self controlInitialize. ^#failedDoit]. Smalltalk logChange: self selection string. self controlInitialize. ^result! inspectIt "Treat the current text selection as an expression; evaluate it" | result | self controlTerminate. result _ model doItReceiver class evaluatorClass new evaluate: self selectionAsStream in: model doItContext to: model doItReceiver notifying: self ifFail: [self controlInitialize. ^#failedDoit]. Smalltalk logChange: self selection string. result inspect! printIt "Treat the current text selection as an expression; evaluate it. Insert the description of the result of evaluation after the selection and then make this description the new text selection." | result | result _ self doIt. result ~~ #failedDoit ifTrue: [self afterSelectionInsertAndSelect: result printString]! ! !StringHolderController methodsFor: 'model access'! model: aModel super model: aModel. view displayContents == nil ifFalse: [self changeCompositor: view displayContents]! ! !StringHolderController methodsFor: 'editing'! insertAndSelect: aString at: anInteger self selectAt: anInteger. self deselect. self replaceSelectionWith: (' ' , aString) asText. self selectAndScroll! ! !StringHolderController methodsFor: 'private'! afterSelectionInsertAndSelect: aString self insertAndSelect: aString at: stopBlock stringIndex! initializeYellowButtonMenu self yellowButtonMenu: CodeYellowButtonMenu yellowButtonMessages: CodeYellowButtonMessages! replaceSelectionWith: aText super replaceSelectionWith: aText. self lockModel! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StringHolderController class instanceVariableNames: ''! !StringHolderController class methodsFor: 'class initialization'! initialize "Initialize the yellow button pop-up menu and corresponding messages." CodeYellowButtonMenu _ PopUpMenu labels: 'again undo copy cut paste do it print it inspect accept cancel' lines: #(2 5 8). CodeYellowButtonMessages _ #(again undo copySelection cut paste doIt printIt inspectIt accept cancel) "StringHolderController initialize"! ! StringHolderController initialize! View subclass: #StringHolderView instanceVariableNames: 'displayContents ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! StringHolderView comment: 'I am a View of a String that is an aspect of a more structured object. This String should not be changed by any editing unless the user issues the accept command. Thus my instances provide a working copy of the String. This copy is edited. When the user issues the accept command, the String is copied from the working version; or if the user issues the cancel command, the working version is restored from the String. StringHolderController is my default controller. It is initialized specially by passing the string viewed which is then converted to a Paragraph for editing. Instance Variables: displayContents the working copy'! !StringHolderView methodsFor: 'initialize-release'! initialize super initialize. displayContents _ TextCompositor new. displayContents text: '' asText. self insideColor: Form white! ! !StringHolderView methodsFor: 'updating'! update: aSymbol self updateDisplayContents! updateDisplayContents "Make the text that is displayed be the contents of the receiver's model." | contents | contents _ self getContents. displayContents string ~= contents ifTrue: [self editString: contents. self displayView]! updateRequest ^ model isUnlocked or: [(self confirm: 'Contents have not been saved. Are you certain that you want to close?') ifTrue: [model unlock. ^true] ifFalse: [^false]]! ! !StringHolderView methodsFor: 'controller access'! defaultController ^self defaultControllerClass newCompositor: displayContents! defaultControllerClass ^StringHolderController! displayContents ^displayContents! ! !StringHolderView methodsFor: 'displaying'! display "Show the contents of the receiver on the display screen." self isUnlocked ifTrue: [self positionDisplayContents]. super display! displayView self clearInside. (self controller isKindOf: TextEditor) ifTrue: [controller display] ifFalse: [displayContents display]! positionDisplayContents "Presumably the text being displayed changed so that the wrapping box and clipping box should be reset." |displayBox translation| displayBox _ self insetDisplayBox. displayBox extent = displayContents clippingRectangle extent ifTrue: [translation _ displayBox origin - displayContents clippingRectangle origin. displayContents clippingRectangle: displayBox. displayContents setCompositionRectangle: (displayContents compositionRectangle translateBy: translation)] ifFalse: [displayContents recomposeIn: (displayBox insetBy: self paragraphInset) clippingBox: displayBox]! ! !StringHolderView methodsFor: 'model access'! editString: aString "The paragraph to be displayed is created from the characters in aString." displayContents _ TextCompositor withText: aString asText style: TextStyle default copy compositionRectangle: (self insetDisplayBox insetBy: self paragraphInset) clippingRectangle: self insetDisplayBox. (self controller isKindOf: TextEditor) ifTrue: [controller changeCompositor: displayContents]! model: aLockedModel super model: aLockedModel. self editString: self getContents! ! !StringHolderView methodsFor: 'deEmphasizing'! deEmphasizeView (self controller isKindOf: TextEditor) ifTrue: [controller deselect]! ! !StringHolderView methodsFor: 'private'! getContents ^model contents! paragraphInset "Answer the amount to inset the paragraph from the border" ^6@0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StringHolderView class instanceVariableNames: ''! !StringHolderView class methodsFor: 'instance creation'! container "Answer an instance of me with a new instance of StringHolder as the model." ^self container: StringHolder new! container: aContainer "Answer an instance of me whose model is aContainer. Give it a 2-dot border." | aCodeView | aCodeView _ self new model: aContainer. aCodeView borderWidth: 1. ^aCodeView! open "Create a scheduled view of a workspace on the screen." self open: StringHolder new label: 'Workspace'! open: aStringHolder "Create a scheduled view of the argument, aStringHolder, as viewed by an instance of me. The view has label 'StringHolder'." self open: aStringHolder label: 'StringHolder'! open: aStringHolder label: aString "Create a StandardSystemView of the model, aStringHolder, as viewed by an instance of me. The label of the view is aString." | aStringHolderView topView | aStringHolderView _ self container: aStringHolder. topView _ StandardSystemView new. topView borderWidth: 1. topView model: aStringHolderView model. topView addSubView: aStringHolderView. topView label: aString. topView minimumSize: 200 @ 150. topView icon: (Icon constantNamed: #default). topView controller open! ! !StringHolderView class methodsFor: 'workspace constants'! openSystemWorkspace "StringHolderView openSystemWorkspace." "Schedule a view of the system workspace." self open: StringHolder workspace label: 'System Workspace'! ! Model subclass: #Switch instanceVariableNames: 'on onAction offAction ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! Switch comment: 'I represent a selection setting and actions to take depending on a change in the setting. An instance of me has three attributes: state, which is either on or off; on action; and off action. The on and off actions are blocks of code that execute whenever the instance changes state. I am typically used as a menu item in conjunction with a SwitchView and a SwitchController. Instance Variables: on true if the Switch is on onAction or nil offAction or nil '! !Switch methodsFor: 'initialize-release'! release "Set the on and off actions of the receiver to nil ('no action') in order to break possible pointer cycles. It is sent by Switch|deleteDependent: when the last dependent has been deleted from the Switch's list of dependents." super release. onAction _ nil. offAction _ nil! ! !Switch methodsFor: 'dependents access'! removeDependent: aDependent "If aDependent is the only dependent in the list, the receiver sends Switch|release to try to break up possible pointer cycles." super removeDependent: aDependent. self dependents isEmpty ifTrue: [self release]! ! !Switch methodsFor: 'clearing'! clear "Set the state of the receiver to 'off'. If the state of the receiver was previously 'on', then 'self change' is sent. The receiver's off action is NOT executed." self isOn ifTrue: [on _ false. self changed]! ! !Switch methodsFor: 'state'! isOff "Answer whether the receiver is set off or not." ^on not! isOn "Answer whether the receiver is set on or not." ^on! set "Set the state of the receiver to 'on'. If the state of the receiver was previously 'off', then 'self change' is sent. The receiver's on action is NOT executed." self isOff ifTrue: [on _ true. self changed]! switch "Change the state of the receiver from 'on' to 'off' or from 'off' to 'on' (see Switch|turnOn, Switch|turnOff)." self isOn ifTrue: [self turnOff] ifFalse: [self turnOn]! turnOff "Set the state of the receiver to 'off'. If the state of the receiver was previously 'on', then 'self change' is sent and the receiver's off action is executed." self isOn ifTrue: [on _ false. self changed. self doAction: offAction]! turnOn "Set the state of the receiver to 'on'. If the state of the receiver was previously 'off', then 'self change' is sent and the receiver's on action is executed." self isOff ifTrue: [on _ true. self changed. self doAction: onAction]! ! !Switch methodsFor: 'action'! doAction: anAction "Execute anAction if it is non-nil." anAction == nil ifFalse: [anAction value]! offAction: anAction "Set the off action of the receiver to anAction." offAction _ anAction fixTemps! onAction: anAction "Set the on action of the receiver to anAction." onAction _ anAction fixTemps! ! !Switch methodsFor: 'private'! initializeOff on _ false. onAction _ nil. offAction _ nil! initializeOn on _ true. onAction _ nil. offAction _ nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Switch class instanceVariableNames: ''! !Switch class methodsFor: 'instance creation'! new "Answer an instance of me such that the on and off actions are set to nil ('no action'), and the state is set to 'off'." ^self newOff! newOff "Answer an instance of me such that the on and off actions are set to nil ('no action'), and the state is set to 'off'." ^super new initializeOff! newOn "Answer an instance of me such that the on and off actions are set to nil ('no action'), and the state is set to 'on'." ^super new initializeOn! ! Controller subclass: #SwitchController instanceVariableNames: 'selector arguments cursor ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! SwitchController comment: ' I coordinate the interaction of a Switch, a SwitchView, and input events (user actions, see class Sensor). My instances own a message in the form of a selector and an array of arguments. Whenever the Switch is selected, this message is sent to the Switch. Instance Variables: selector arguments '! !SwitchController methodsFor: 'initialize-release'! initialize super initialize. selector _ #switch. arguments _ Array new: 0! ! !SwitchController methodsFor: 'accessing'! addArgument: aValue "Add the argument, aValue, as one of the arguments of the message the receiver sends to its model." arguments _ arguments copyWith: aValue! arguments "Answer the arguments the receiver sends in a message to its receiver." ^arguments! arguments: anArray "The argument, anArray, consists of the arguments of the message the receiver sends to its model." arguments _ anArray! cursor: aCursor cursor _ aCursor! selector "Answer the selector the receiver sends in a message to its receiver." ^selector! selector: aSymbol "Set aSymbol to be the selector the receiver sends in a message to its model." selector _ aSymbol! ! !SwitchController methodsFor: 'basic control sequence'! controlInitialize view indicatorReverse! controlTerminate view indicatorReverse. self viewHasCursor ifTrue: [self sendMessage]! sendMessage "The receiver consists of a selector and possibly of arguments that should be used to create a message to send to the receiver's model." arguments size = 0 ifTrue: [model perform: selector] ifFalse: [model perform: selector withArguments: arguments]! ! !SwitchController methodsFor: 'control defaults'! controlActivity ^ self! isControlActive ^sensor anyButtonPressed & self viewHasCursor! isControlWanted self viewHasCursor ifTrue: [cursor == nil ifFalse: [cursor show]]. ^self viewHasCursor & sensor redButtonPressed! ! View subclass: #SwitchView instanceVariableNames: 'complemented label selector keyCharacter highlightForm arguments emphasisOn ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! SwitchView comment: 'I am a view of a Switch. My instances have labels and display modes (set to "normal" or "complemented"). When one of my instances is displayed in complemented mode, its inside color is reversed. The value of the display mode corresponds to the value of the model so that, for example, when a Switch is off, its SwitchView is displayed with black text (for the label) on a white background, and when the Switch is off, its SwitchView is displayed with white text on a black background. My instances have a key character that can be used for switching on or off. Highlighting can be done specially using a stored form, rather than simply changing all black bits to white and vice versa. My default controller is SwitchController. Instance Variables: complemented true if the model is on label , for example, a DisplayText or a Form selector keyCharacter highlightForm arguments '! !SwitchView methodsFor: 'initialize-release'! initialize super initialize. insideColor _ Form white. complemented _ false. label _ nil. selector _ #isOn. arguments _ #(). emphasisOn _ true! release super release. label release! ! !SwitchView methodsFor: 'accessing'! arguments "Answer the arguments the receiver sends in a message to its receiver." ^arguments! arguments: anArray "The argument, anArray, consists of the arguments of the message the receiver sends to its model." arguments _ anArray! highlightForm: aForm "The argument is the form to be used to highlight the receiver." highlightForm _ aForm! key: aCharacter "Set the receiver to be selected by the argument, aCharacter." keyCharacter _ aCharacter! ! !SwitchView methodsFor: 'testing'! containsKey: aCharacter "Answer whether the receiver can be selected by the argument, aCharacter." ^keyCharacter = aCharacter! ! !SwitchView methodsFor: 'controller access'! defaultControllerClass ^SwitchController! ! !SwitchView methodsFor: 'window access'! defaultWindow "Returns the frame of the SwitchView's label's frame (slightly enlarged) if the label exists, and returns the standard View default window (see View|defaultWindow), otherwise." label == nil ifTrue: [^super defaultWindow] ifFalse: [^label boundingBox expandBy: 6]! window: aWindow super window: aWindow. self centerLabel! ! !SwitchView methodsFor: 'displaying'! displayComplemented "Complement the receiver if its mode is 'normal'." complemented ifFalse: [complemented _ true. self highlight]! displayNormal "Complement the receiver if its mode is 'complemented'." complemented ifTrue: [complemented _ false. self highlight]! displaySpecial complemented ifTrue: [self displaySpecialComplemented]. label == nil ifFalse: [label displayOn: Display transformation: self displayTransformation clippingBox: self insetDisplayBox align: label boundingBox center with: label boundingBox center rule: Form under mask: Form black]! displaySpecialComplemented highlightForm displayOn: Display transformation: self displayTransformation clippingBox: self insetDisplayBox fixedPoint: label boundingBox center! displayView "Does the standard View actions and, in addition, displays the receiver's label based on the current display transformation and inset display box. " | center | self clearInside. label == nil ifFalse: [center _ label boundingBox center. label displayOn: Display at: (label offset + (self displayTransformation applyTo: center) - center) rounded clippingBox: self insetDisplayBox]. complemented _ self interrogateModel. complemented ifTrue: [self highlight]! highlight "Cause the inset display box (the display box excluding the border, see View|insetDisplayBox) of the receiver to complement." highlightForm == nil ifFalse: [^highlightForm displayOn: Display at: self displayBox topLeft clippingBox: self insetDisplayBox rule: Form reverse mask: nil]. emphasisOn ifTrue: [Display reverse: (self insetDisplayBox insetBy: 1)] ifFalse: [Display reverse: (self insetDisplayBox insetBy: 1). Display reverse: (self insetDisplayBox insetBy: 2)]! ! !SwitchView methodsFor: 'updating'! update: aParameter highlightForm == nil ifTrue: [self interrogateModel ifTrue: [self displayComplemented] ifFalse: [self displayNormal]] ifFalse: [self display]! ! !SwitchView methodsFor: 'label access'! centerLabel "Align the center of the frame of the label with the center of the receiver's window." label == nil ifFalse: [label align: label boundingBox center with: self getWindow center]! label "Answer the label, a display object, that is the receiver's screen image." ^label! label: aDisplayObject "Set aDisplayObject to be the label that is the receiver's screen image." label release. label _ aDisplayObject. self centerLabel! ! !SwitchView methodsFor: 'indicating'! indicatorOnDuring: aBlockContext "Indicate the receiver during the execution of aBlockContext by complementing the label (or a portion of the display box if no label is defined). " self indicatorReverse. self highlight. aBlockContext value. self highlight. self indicatorReverse! indicatorReverse "Complement the label (or a portion of the displayBox if no label is defined)." Display reverse: self insetDisplayBox mask: Form gray. Display reverse: (self insetDisplayBox insetBy: 2) mask: Form gray! ! !SwitchView methodsFor: 'selector'! interrogateModel "Answer the result of sending the receiver's model the message created from the receiver's selector and arguments." arguments size = 0 ifTrue: [^model perform: selector] ifFalse: [^model perform: selector withArguments: arguments]! selector "Answer the selector the receiver sends in a message to its receiver." ^selector! selector: aSymbol "Set aSymbol to be the selector the receiver sends in a message to its model." selector _ aSymbol! ! !SwitchView methodsFor: 'deEmphasizing'! deEmphasizeView complemented ifFalse: [^ self]. emphasisOn ifTrue: [self highlight. emphasisOn _ false. self highlight]! emphasizeView complemented ifFalse: [^ self]. emphasisOn ifFalse: [self highlight. emphasisOn _ true. self highlight]! ! String variableByteSubclass: #Symbol instanceVariableNames: '' classVariableNames: 'SingleCharSymbols USTable ' poolDictionaries: '' category: 'Collections-Text'! Symbol comment: 'Symbols are Strings which are created uniquely. Thus, someString asSymbol == someString asSymbol. Instance Variables: *byte indexed* Class Variables: SingleCharSymbols of 128 elements that are 1-character atoms USTable '! !Symbol methodsFor: 'accessing'! at: anInteger put: anObject "Provide an error notification that Symbols can not be modified." self errorNoModification! replaceFrom: start to: stop with: replacement startingAt: repStart "Provide an error notification that Symbols can not be modified." self errorNoModification! ! !Symbol methodsFor: 'comparing'! = anObject "Answer whether the receiver and the argument are the same object (have the same object pointer)." ^self == anObject! hash "Answer a SmallInteger unique to the receiver. Essential. See Object documentation whatIsAPrimitive." ^self! ! !Symbol methodsFor: 'copying'! copy "Answer the receiver, because Symbols are unique." ^self! shallowCopy "Answer the receiver because Symbols are unique." ^self! ! !Symbol methodsFor: 'printing'! isLiteral "Answer whether the receiver is a literal." ^Scanner isLiteralSymbol: self! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." aStream nextPutAll: self! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a symbol similar to the receiver. The general format for symbols is either the literal format #sequence-of-characters or as a message to a string (string) asSymbol." self isLiteral ifTrue: [aStream nextPut: $#. aStream nextPutAll: self] ifFalse: [super storeOn: aStream. aStream nextPutAll: ' asSymbol']! ! !Symbol methodsFor: 'converting'! asString "Answer the receiver converted to a String." | newString index len | newString _ String new: (len _ self size). index _ 1. [index <= len] whileTrue: [newString at: index put: (self at: index). index _index + 1]. ^newString! asSymbol "Answer the receiver." ^self! ! !Symbol methodsFor: 'system primitives'! classPart "The receiver must be a compound selector. Answer the receiver's class name." | i | i _ self indexOf: $. ifAbsent: [self error: 'class part not found']. ^(self copyFrom: 1 to: i-1) asSymbol! isCompound "Answer whether the receiver is of the form Class.foo " ^self includes: $.! isInfix "Answer whether the receiver is an infix message selector." ^(self at: 1) isLetter not! isKeyword "Answer whether the receiver is a message keyword, i.e., ends with colon." self size <= 1 ifTrue: [^false]. ^(self at: self size) = $:! keywords "Answer an array of the keywords that compose the receiver." | result aStream i l char | result _ WriteStream on: (Array new: 10). aStream _ WriteStream on: (String new: 16). i _ 1. l _ self size. [i <= l] whileTrue: [char _ self at: i. aStream nextPut: char. (char = $: or: [i = l]) ifTrue: [result nextPut: aStream contents. aStream reset]. i _ i + 1]. ^result contents! numArgs "Answer the number of arguments that the receiver requires if it is interpreted as a message selector." | len n i | len _ self size. n _ (self at: 1) isLetter ifTrue: [0] ifFalse: [1]. i _ 1. [(i _ i + 1) <= len] whileTrue: "count colons" [(self at: i) = $: ifTrue: [n _ n + 1]]. ^n! precedence "Answer the precedence of this symbol as a message selector: unary=1, binary=2, keyword=3." ^self isKeyword ifTrue: [3] ifFalse: [self isInfix ifTrue: [2] ifFalse: [1]]! selectorPart "Answer just the part after the class name if the receiver is a compound selector, otherwise answer the entire receiver." ^(self copyFrom: (self indexOf: $.) + 1 to: self size) asSymbol! ! !Symbol methodsFor: 'private'! errorNoModification self error: 'symbols can not be modified.'! species ^String! string: aString 1 to: aString size do: [:j | super at: j put: (aString at: j)]. ^self! stringhash ^super hash! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Symbol class instanceVariableNames: ''! !Symbol class methodsFor: 'class initialization'! initialize "Initialize the class variables." "Symbol initialize." | a v | "make up table of 1-char atoms" v _ Array new: 128. a _ String new: 1. 1 to: 128 do: [:i | a at: 1 put: (i - 1) asCharacter. v at: i put: a asSymbol]. SingleCharSymbols _ v. self rehash.! ! !Symbol class methodsFor: 'instance creation'! intern: aString "Answer a unique Symbol whose characters are those of aString." | sym index | self hasInterned: aString ifTrue: [:oldSym | ^oldSym]. "check if already exists" sym _ (aString isMemberOf: Symbol) ifTrue: [aString] "putting old symbol in new table" ifFalse: [(Symbol new: aString size) string: aString]. "create a new one" index _ aString stringhash \\ USTable size + 1. USTable at: index put: ((USTable at: index) copyWith: sym). ^sym! internCharacter: aCharacter "Answer, creating if necessary, a unique Symbol whose characters are just those characters in the receiver." | ascii | (ascii _ aCharacter asciiValue) < 128 ifTrue: [^SingleCharSymbols at: ascii + 1]. ^self intern: (String with: aCharacter)! ! !Symbol class methodsFor: 'accessing'! correctMessage: unknown minimumScore: minScore "Attempt to correct the spelling of an unknown message symbol. Return a collection of Associations, where the key is the proposed correction and the value is the score, sorted by decreasing score." | lc candidates score hasColon nArgs smaller larger | unknown first isLetter ifFalse: [^#()]. lc _ unknown first asLowercase. hasColon _ unknown last = $:. nArgs _ (unknown select: [:char | char = $:]) size. candidates _ OrderedCollection new. smaller _ unknown size - 4. larger _ unknown size + 4. Symbol table do: [:bucket | "fast tests first" bucket do: [:each | (((each at: 1) = lc and: [each size between: smaller and: larger]) and: [(each last = $:) = hasColon and: [each numArgs = nArgs]]) ifTrue: [score _ each spellAgainst: unknown. score >= minScore ifTrue: [candidates add: (Association key: each value: score)]]]]. ^candidates asSortedCollection: [:x :y | x value >= y value]! ! !Symbol class methodsFor: 'user interface'! correctMessage: unknown "Attempt to correct the spelling of an unknown message symbol." | candidates guess | candidates _ self correctMessage: unknown minimumScore: 50. candidates isEmpty ifTrue: [^nil]. guess _ candidates first key. (self confirm: 'Confirm correction to ' , guess) ifTrue: [^ guess asSymbol] ifFalse: [^ nil]! ! !Symbol class methodsFor: 'private'! hasInterned: aString ifTrue: symBlock "Answer with false if aString hasnt been interned (into a Symbol), otherwise supply the symbol to symBlock and answer true." | v ascii i len j vAtI len2| (len2 _ aString size) == 1 ifTrue: [(ascii _ (aString at: 1) asciiValue) < 128 ifTrue: [symBlock value: (SingleCharSymbols at: ascii + 1). ^true]]. v _ USTable at: aString stringhash \\ USTable size + 1. i _ 1. len _ v size. [i <= len] whileTrue: [(vAtI _ (v at: i)) == nil ifFalse: [len2 == vAtI size ifTrue: [j _ 1. [j <= len2] whileTrue: [(aString at: j) == (vAtI at: j) ifFalse: [j _ len2 + 2] ifTrue: [ j _ j + 1]]. (j == (len2 + 1 )) ifTrue: [symBlock value: vAtI. ^true]]]. i _ i + 1]. ^false! rehash "Rebuild the hash table that holds all the unique Symbols." USTable _ USTable collect: [:sym | Array new: 0]. Smalltalk garbageCollect. Symbol allInstancesDo: [:sym | self intern: sym] "Symbol rehash"! table "Access for SystemTracer" ^USTable! table: newArray "Access for SystemTracer" ^USTable _ newArray! ! Symbol initialize! Model subclass: #SyntaxError instanceVariableNames: 'class badText processHandle ' classVariableNames: 'TextMenu ' poolDictionaries: '' category: 'Interface-Debugger'! SyntaxError comment: 'I represent a report of a syntax error when reading class descriptions from a noninteractive source such as an external file. As a StringHolder, the string to be viewed is the code or expression containing the error.'! !SyntaxError methodsFor: 'text'! proceed "Continue the file in, ignoring this section of code, regardless of whether or not the syntax error was corrected." self changeRequest ifTrue: [processHandle proceed]! text ^ badText! textMenu "SyntaxError flushMenus" TextMenu == nil ifTrue: [TextMenu _ ActionMenu labels: 'again\undo\copy\cut\paste\do it\print it\inspect\accept\cancel\proceed' withCRs lines: #(2 5 8 10) selectors: #(again undo copySelection cut paste doIt printIt inspectIt accept cancel proceed)]. ^ TextMenu! ! !SyntaxError methodsFor: 'doIt/accept/explain'! acceptText: aString from: aController "Compile the code in aString and notify aController of any errors. Proceed if successful." (class compile: aString classified: ClassOrganizer defaultProtocol notifying: aController) == nil ifTrue: [^false] ifFalse: [^true]! doItContext ^ nil! doItReceiver ^ nil! doItValue: ignored! ! !SyntaxError methodsFor: 'dependents access'! removeDependent: aDependent super removeDependent: aDependent. self dependents isEmpty "detect when closing" ifTrue: [processHandle release]! ! !SyntaxError methodsFor: 'private'! setClass: aClass code: aString processHandle: aProcessHandle class _ aClass. processHandle _ aProcessHandle. badText _ aString asText! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SyntaxError class instanceVariableNames: ''! !SyntaxError class methodsFor: 'instance creation'! errorInClass: aClass withCode: aString errorString: errorString "Answer a StandardSystemView whose model is an instance of me. The syntax error occurred in trying to add code, aString, to class, aClass." | aSyntaxError topView | Cursor normal show. aSyntaxError _ self new setClass: aClass code: aString processHandle: (ProcessHandle on: Processor activeProcess at: thisContext interrupted: false). topView _ StandardSystemView model: aSyntaxError label: 'Syntax Error' minimumSize: 300 @ 180. topView addSubView: (CodeView on: aSyntaxError aspect: #text change: #acceptText:from: menu: #textMenu initialSelection: errorString) in: (0@0 extent: 1@1) borderWidth: 1. topView controller openNoTerminateDisplayAt: Display extent // 2. Processor activeProcess suspend! ! !SyntaxError class methodsFor: 'initialization'! flushMenus TextMenu _ nil! ! Object variableSubclass: #SystemCall instanceVariableNames: 'operationCode errorNumber returnValue ' classVariableNames: '' poolDictionaries: 'RoutineCodes ' category: 'System-Support'! SystemCall comment: 'Class SystemCall represents a call to the operating system kernel. It provides several class messages for creating instances which look very similar to the operating system calls. Instances of class SystemCall are invoked by sending one of the messages in the ''execution'' protocol. WARNING: Little or no type checking, and absolutely no consistency checking is performed by either the Smalltalk execution code or the primitive system call routine when a system call is invoked. The primitive will perform simple minded translations into simple os data structures, but nothing more. Use this class with extreme caution, or use one of the safe abstractions provided in the system. Instance Variables: *indexed* operationCode -- the index of the system call. errorNumber -- the error number returned by the call. returnValue -- the result of invoking the system call.'! !SystemCall methodsFor: 'initialize-release'! ! !SystemCall methodsFor: 'accessing'! argument: argumentNumber "Answer the argument whose index is argumentNumber." ^self at: argumentNumber! argument: argumentNumber put: newValue "Answer the argument whose index is argumentNumber." ^self at: argumentNumber put: newValue! errorMessage "Answer the message associated with the last error generated. Error messages are reset to the null string for successful calls." ^'SystemCall error: ' , (self class errorStringFor: errorNumber)! errorNumber "Answer the number of the last error generated. Error numbers are reset to zero for successful calls." ^errorNumber! operationName "Answer the name of the operation I represent." ^self class nameOfOperationNumber: operationCode! operationNumber "Answer the number of the operation I represent." ^operationCode! returnValue "Answer the value returned from the last invocation of ourself." ^returnValue! ! !SystemCall methodsFor: 'error messages'! tooManyArguments "Report to the user that too many arguments were specified when the receiver was being given arguments." ^self error: 'Too many arguments.'! ! !SystemCall methodsFor: 'execution'! invoke "Invoke the receiver." ^self invokeIfFail: [self primitiveFailed]! invokeIfFail: aBlock "Invoke the receiver and invoke aBlock if the system call fails." ^aBlock value! value "Invoke the receiver, answering the value of the call as my value. Report the error if one occurs." ^self valueOnError: [self error: self errorMessage]! valueOnError: errorBlock "Invoke the receiver, returning the value of the call as my value. Invoke the error block to handle any errors that may occur." self invokeIfFail: [self primitiveFailed]. errorNumber == 0 ifTrue: [^returnValue] ifFalse: [^errorBlock value]! ! !SystemCall methodsFor: 'initialization'! initialize "Initialize the static portions of the receiver." operationCode _ 0. errorNumber _ 0. returnValue _ 0! operation: operation "Change the receiver to be the given operation, but do not change the arguments." operationCode _ operation! operation: operation withArguments: argumentArray "Initialize the receiver to be the operation indicated by the operationCode, having the arguments given as parameters. (Clear the rest of the parameters to avoid problems.)" | index len | self operation: operation. argumentArray size > self size ifTrue: [^self tooManyArguments]. index _ 1. len _ argumentArray size. [index <= len] whileTrue: [self at: index put: (argumentArray at: index). index _ index + 1]. len _ self size. [index <= len] whileTrue: [self at: index put: 0. index _ index + 1]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SystemCall class instanceVariableNames: ''! !SystemCall class methodsFor: 'class initialization'! initialize "Initialize constants." "SystemCall initialize." self initializeRoutineCodes! initializeRoutineCodes "Initialize the Dictionary of routine names." "SystemCall initializeRoutineCodes" RoutineCodes at: #close put: 10. RoutineCodes at: #creat put: 12. RoutineCodes at: #fsync put: 23. RoutineCodes at: #ftruncate put: 24. RoutineCodes at: #lseek put: 50. RoutineCodes at: #mkdir put: 52. RoutineCodes at: #open put: 57. RoutineCodes at: #read put: 62. RoutineCodes at: #rename put: 69. RoutineCodes at: #rmdir put: 70. RoutineCodes at: #sync put: 98. RoutineCodes at: #unlink put: 103. RoutineCodes at: #write put: 110. RoutineCodes at: #getWorkingDirectory put: 1003. RoutineCodes at: #suspend put: 1005. RoutineCodes at: #ringBell put: 1006. RoutineCodes at: #snapshotFile put: 1008. RoutineCodes at: #statusOfFileNamed put: 1009. RoutineCodes at: #enumerateFileReset put: 1010. RoutineCodes at: #enumerateFileNext put: 1011. RoutineCodes at: #enumerateFileClose put: 1012. RoutineCodes at: #errorString put: 1013. RoutineCodes at: #statusOfFile put: 1014. RoutineCodes at: #resetDA put: 2000. RoutineCodes at: #enumerateDA put: 2001. RoutineCodes at: #openDA put: 2002. RoutineCodes at: #putScrap put: 2003. RoutineCodes at: #getScrap put: 2004. RoutineCodes at: #enumerateVolumes put: 2005. RoutineCodes at: #ejectVolume put: 2006. RoutineCodes at: #printFile put: 2007. RoutineCodes at: #setCreatorAndType put: 2008. RoutineCodes at: #resetCreatorAndType put: 2009! ! !SystemCall class methodsFor: 'instance creation'! new "Create an instance of a system call with no operation code." ^(super new: 6) initialize! new: argumentCount "Create an instance of a system call with the specified number of parameters." argumentCount <= 6 ifTrue: [^self new] ifFalse: [^self error: 'System calls may not have more than 6 arguments']! operation: operationCode "Create an instance of a system call with the given operation code and no arguments." ^self new operation: operationCode! operation: operationCode with: anArgument "Create an instance of a system call with the given operation code and arguments." ^self new operation: operationCode withArguments: (Array with: anArgument)! operation: operationCode with: firstArgument with: secondArgument "Create an instance of a system call with the given operation code and arguments." ^self new operation: operationCode withArguments: (Array with: firstArgument with: secondArgument)! operation: operationCode with: firstArgument with: secondArgument with: thirdArgument "Create an instance of a system call with the given operation code and arguments." ^self new operation: operationCode withArguments: (Array with: firstArgument with: secondArgument with: thirdArgument)! operation: operationCode with: firstArgument with: secondArgument with: thirdArgument with: fourthArgument "Create an instance of a system call with the given operation code and arguments." ^self new operation: operationCode withArguments: (Array with: firstArgument with: secondArgument with: thirdArgument with: fourthArgument)! operation: operationCode withArguments: argumentArray "Create an instance of a system call with the given operation code and arguments." ^self new operation: operationCode withArguments: argumentArray! operationCalled: operationName "Create an instance of a system call with the given operation name and no arguments." ^self operation: (self operationNamed: operationName)! operationCalled: operationName with: anArgument "Create an instance of a system call with the given operation code and arguments." ^self operation: (self operationNamed: operationName) withArguments: (Array with: anArgument)! operationCalled: operationName with: firstArgument with: secondArgument "Create an instance of a system call with the given operation code and arguments." ^self operation: (self operationNamed: operationName) withArguments: (Array with: firstArgument with: secondArgument)! operationCalled: operationName with: firstArgument with: secondArgument with: thirdArgument "Create an instance of a system call with the given operation code and arguments." ^self operation: (self operationNamed: operationName) withArguments: (Array with: firstArgument with: secondArgument with: thirdArgument)! operationCalled: operationName with: firstArgument with: secondArgument with: thirdArgument with: fourthArgument "Create an instance of a system call with the given operation code and arguments." ^self operation: (self operationNamed: operationName) withArguments: (Array with: firstArgument with: secondArgument with: thirdArgument with: fourthArgument)! operationCalled: operationName withArguments: argumentList "Create an instance of a system call with the given operation code and arguments." ^self operation: (self operationNamed: operationName) withArguments: argumentList! ! !SystemCall class methodsFor: 'accessing'! nameOfOperationNumber: operationNumber "Answer the code name for the operation whose number is given." ^RoutineCodes keyAtValue: operationNumber ifAbsent: ['']! operationNamed: operationName "Answer the code number for the operation whose name is given." ^RoutineCodes at: operationName ifAbsent: [0]! ! !SystemCall class methodsFor: 'file manipulation'! close: fileDescriptor "Delete a descriptor." self mustBeInteger: fileDescriptor. ^self operation: close with: fileDescriptor! creat: fileName mode: aMode "Create a new file." self mustBeString: fileName. self mustBeInteger: aMode. ^self operation: creat with: (self cStringFrom: fileName) with: aMode! fsync: fileDescriptor "Synchronize a file's in-core state with that on disk." self mustBeInteger: fileDescriptor. ^self operation: fsync with: fileDescriptor! ftruncate: fileDescriptor to: length "Truncate a file to a specified length." self mustBeInteger: fileDescriptor. self mustBeInteger: length. ^self operation: ftruncate with: fileDescriptor with: length! getWorkingDirectoryInto: directoryBuffer "Get the current working directory. Not a standard system call." self mustBeString: directoryBuffer. ^self operation: getWorkingDirectory with: directoryBuffer with: directoryBuffer size! lseek: fileDescriptor by: offset how: seekMethod "Move the read/write pointer." self mustBeInteger: fileDescriptor. self mustBeInteger: offset. self mustBeInteger: seekMethod. ^self operation: lseek with: fileDescriptor with: offset with: seekMethod! mkdir: fileName mode: fileMode "Make a directory file." self mustBeString: fileName. self mustBeInteger: fileMode. ^self operation: mkdir with: (self cStringFrom: fileName) with: fileMode! open: fileName for: flags mode: fileMode "Open a file for reading or writing, or create a new file." self mustBeString: fileName. self mustBeInteger: flags. self mustBeInteger: fileMode. ^self operation: open with: (self cStringFrom: fileName) with: flags with: fileMode! read: fileDescriptor into: buffer count: byteCount "Read input." self mustBeInteger: fileDescriptor. self mustBeInteger: byteCount. self mustBeString: buffer ofLength: byteCount. ^self operation: read with: fileDescriptor with: buffer with: byteCount! rename: fileName to: newName "Change the name of a file." self mustBeString: fileName. self mustBeString: newName. ^self operation: rename with: (self cStringFrom: fileName) with: (self cStringFrom: newName)! rmdir: fileName "Remove a directory file." self mustBeString: fileName. ^self operation: rmdir with: (self cStringFrom: fileName)! snapshotFile: fileName "Make the snapshot file name be fileName." self mustBeString: fileName. ^self operation: snapshotFile with: (self cStringFrom: fileName)! sync "Update the file system." ^self operation: sync! unlink: fileName "Remove a directory entry." self mustBeString: fileName. ^self operation: unlink with: (self cStringFrom: fileName)! write: fileDescriptor from: buffer count: byteCount "Write on a file." self mustBeInteger: fileDescriptor. self mustBeInteger: byteCount. self mustBeString: buffer ofMaxLength: byteCount. ^self operation: write with: fileDescriptor with: buffer with: byteCount! ! !SystemCall class methodsFor: 'type checking'! canNotTranslateType "Inform the user that one of the arguments can not be translated into an OS equivalent." [true] whileTrue: [self error: 'Can not translate type to OS.']! cStringFrom: aString "Answer a copy of the argument with a null byte at the end." | newString | newString _ String new: aString size + 1. newString replaceFrom: 1 to: aString size with: aString startingAt: 1. newString at: newString size put: 0 asCharacter. ^newString! mustBeInteger: anArg "Check the argument to a SystemCall to make sure that it can be translated into an integer." [anArg class == SmallInteger] whileFalse: [self error: 'Integer argument expected.']! mustBeString: anArg "Check the argument to a SystemCall to make sure that it can be translated into a Cstring." [anArg class == String] whileFalse: [self error: 'String argument expected.']! mustBeString: anArg ofLength: length "Check the argument to a SystemCall to make sure that it can be translated into a Cstring." [anArg class == String or: [anArg class == ByteArray]] whileFalse: [self error: 'String argument expected.']. [anArg size = length] whileFalse: [self error: 'String argument incorrect size.']! mustBeString: anArg ofMaxLength: length "Check the argument to a SystemCall to make sure that it can be translated into a Cstring." [anArg class == String or: [anArg class == ByteArray]] whileFalse: [self error: 'String argument expected.']. [anArg size >= length] whileFalse: [self error: 'String argument incorrect size.']! mustBeStructure: anArg "Check the argument to a UnixSystemCall to make sure that it can be translated into a Unix structure." [anArg class == ByteArray] whileFalse: [self error: 'Structure argument expected.']! mustBeStructure: anArg ofLength: length "Check the argument to a UnixSystemCall to make sure that it can be translated into a Unix structure." [anArg class == ByteArray] whileFalse: [self error: 'Structure argument expected.']. [anArg size = length] whileFalse: [self error: 'Structure argument incorrect size.']! ! !SystemCall class methodsFor: 'constants'! createDirectoryMask "Answer the mask used in creating directorys." ^8r755! createFileMask "Answer the protection mask used in creating files." ^8r644! createIfAbsent "Answer the constant used to create the file if absent." ^8r1000! default "Return the default system call class." ^SystemCall! preferredBufferSizeSlot ^7! readMode ^0! readWriteMode ^2! writeMode ^1! ! !SystemCall class methodsFor: 'simple interface'! canReadFile: fileName "Answer true if the file can be read." | status | status _ self statusForFileNamed: fileName. status == nil ifTrue: [^false] ifFalse: [^status at: 5]! canWriteFile: fileName "Answer true if the file can be written." | status | status _ self statusForFileNamed: fileName. status == nil ifTrue: [^false] ifFalse: [^status at: 6]! closeFile: handle "Close the file" ^(self default close: handle) value! createFile: aName "Create the file." ^self createFile: aName mode: self default createFileMask! createFile: aName mode: anInteger "Create the file." ^(self default creat: aName mode: anInteger) value! creationOfFileNamed: fileNamed "Return the creation date (in seconds since Dec 31, 1901 ) of the file named fileName." | status | status _ self statusForFileNamed: fileNamed. status == nil ifTrue: [^self error: 'file does not exist'] ifFalse: [^status at: 2]! creatorOfFileNamed: fileNamed "Return the 4 character designator for the creator of the file named fileName. i.e. PSST " | status | status _ self statusForFileNamed: fileNamed. status == nil ifTrue: [^self error: 'file does not exist'] ifFalse: [^status at: 8]! currentWorkingDirectory "Answer the string representing the current working directory." | cwd size | cwd _ String new: 255. size _ (self default getWorkingDirectoryInto: cwd) value. ^cwd copyFrom: 1 to: size! directoryContentsFor: aDirectoryName "Answer an OrderedCollection containing all of the files within the receiver." | enumerationHandle collection fileName err dname enumerator | collection _ OrderedCollection new: 128. dname _ aDirectoryName. err _ Array new: 1. enumerationHandle _ SystemCall primEnumerateFileReset: dname errorBuf: err. enumerationHandle == nil ifTrue: [^collection]. enumerator _ (self operation: enumerateFileNext with: enumerationHandle with: nil). [(fileName _ enumerator valueOnError: [nil]) == nil] whileFalse: [collection add: fileName]. self primEnumerateFileClose: enumerationHandle. ^collection! enumerateVolumes " Repeated calls step through current mounted Volumes. This call will return a string or nil when there are no further volumes to list." ^(self default operation: enumerateVolumes) valueOnError: [nil]! errorStringFor: aNumber "Answer an os dependent error message." ^(self operation: errorString with: aNumber) value! existsFile: fileName "Answer true if the file can be written." | status | status _ self statusForFileNamed: fileName. ^(status == nil) not! flushAllFilesToDisk "Synchronize all file's in-core state with that on disk." ^(self default sync) value! flushToDisk: fileDescriptor "Synchronize a file's in-core state with that on disk." ^(self default fsync: fileDescriptor) value! getVolumeNames "Answer an ordered collection of the currently mounted volumes" | eVol oc sep | eVol _ self enumerateVolumes. eVol == nil ifFalse: [sep _ ''. oc _ OrderedCollection new. [eVol notNil] whileTrue: [oc add: eVol. eVol _ self enumerateVolumes]] ifTrue: [sep _ FileDirectory separatorString. oc _ self directoryContentsFor: sep. oc _ (oc select: [:dir | self isDirectory: sep, dir]) collect: [:dir | sep, dir]]. ^oc! getVolumes "Answer a string with the Volume the user selectes from the currently mounted volumes, or nil if no selection was made." | index oc ws number | ws _ WriteStream with: (String new: 100). oc _ self getVolumeNames asArray. index _ 1. [index > oc size] whileFalse: [ws nextPutAll: (oc at: index); nextPut: Character cr. index _ index + 1]. ws skip: -1. number _ (PopUpMenu labels: ws contents) startUp. number > 0 ifTrue: [^oc at: number]. ^nil! isDirectory: fileName "Answer true if the file is a directory." | status | status _ self statusForFileNamed: fileName. status == nil ifTrue: [^false] ifFalse: [^status at: 4]! isEmptyDirectory: aDirectoryName "Answer true if the directory aDirectoryName is empty." ^(self directoryContentsFor: aDirectoryName) size <= 0! makeDirectory: aDirectoryName "Make a new directory." (self default mkdir: aDirectoryName mode: self default createDirectoryMask) value.! modDateOfFileNamed: fileNamed "Return the last modification date (in seconds since December 31, 1901) of the file named fileName." | status | status _ self statusForFileNamed: fileNamed. status == nil ifTrue: [^self error: 'file does not exist'] ifFalse: [^status at: 3]! openFile: aName for: aMode "Open the file." ^self openFile: aName for: aMode mode: self default createFileMask! openFile: aName for: aMode mode: anInteger "Open the file." ^(self default open: aName for: aMode mode: anInteger) value! read: handle into: aBuffer amount: bufferSize "Read from the file into aBuffer the number of characters specified by bufferSize." ^(self default read: handle into: aBuffer count: bufferSize) value! removeDirectory: aDirectoryName "Remove the directory." ^(self default rmdir: aDirectoryName) value! removeFile: fileName "Remove the file." ^(self default unlink: fileName) value! renameFile: oldName to: newName "Change the name of the old file to the new file name." ^(self default rename: oldName to: newName) value! setFile: handle toPosition: aPosition how: anInteger "Set the absolute position of the file." ^(self default lseek: handle by: aPosition how: anInteger) value! shortenFile: handle toPosition: aPosition "Shorten the file to an absolute position." ^(self default ftruncate: handle to: aPosition) value! sizeOfFile: fileHandle "Answer the size of the file named fileName." | status | status _ self statusForFile: fileHandle. status == nil ifTrue: [^self error: 'file does not exist'] ifFalse: [^status at: 1]! sizeOfFileNamed: fileNamed "Answer the size of the file named fileName." | status | status _ self statusForFileNamed: fileNamed. status == nil ifTrue: [^self error: 'file does not exist'] ifFalse: [^status at: 1]! snapshotFileName: aFileName "Set the name to use as the snapshot file." ^(self default snapshotFile: aFileName) invoke! statusForFile: fileHandle "Answer a status array for fileor nil if the file does not exist." "The stucture is: (array at: 1) = file size in bytes. (array at: 2) = file last access time (seconds since Jan 1, 1901). (array at: 3) = file last modify time (seconds since Jan 1, 1901). (array at: 4) = true if file is a directory." | statArray| statArray _ Array new: 4. ^self primStatusOfFile: fileHandle into: statArray! statusForFileNamed: fileName "Answer a status array for fileName or nil if the file does not exist." "The stucture is: (array at: 1) = file size in bytes. (array at: 2) = file last access time (seconds since Jan 1, 1901). (array at: 3) = file last modify time (seconds since Jan 1, 1901). (array at: 4) = true if file is a directory. (array at: 5) = true if file is readable. (array at: 6) = true if file is writable. [optional] (array at: 7) = recommended buffer size. (array at: 8) = creator. (array at: 9) = file type." | statArray| statArray _ Array new: 9. ^self primStatusOfFileNamed: fileName into: statArray! typeOfFileNamed: fileNamed "Return the string designator for the type of the file named fileName." | status | status _ self statusForFileNamed: fileNamed. status == nil ifTrue: [^self error: 'file does not exist'] ifFalse: [^status at: 8]! write: handle from: aBuffer amount: anInteger "Write to the file from aBuffer the number of characters specified by anInteger." ^(self default write: handle from: aBuffer count: anInteger) value! ! !SystemCall class methodsFor: 'tools'! bell " Returns a pseudo reference number ( menuHandle ) in preparation for enumerating the Desk Accessories that are available." ^(self default operation: ringBell ) valueOnError: [nil]! ejectVolume: aVolume "Flush and eject the volume described by the string aVolume" ^(self default operation: ejectVolume with: (self cStringFrom: (aVolume, FileDirectory separatorString))) value! enumerateDeskTop: menuHandle " Repeated calls step through current Desk Accessories. This call will return a string (or nil when there are no further accessories to list)." ^(self default operation: enumerateDA with: menuHandle) valueOnError: [nil]! getScrap "Copy the System scrap buffer text into the paste buffer" "SystemCall getScrap" | selection | selection _ (self default operation: getScrap) valueOnError: [nil]. selection == nil ifFalse: [ParagraphEditor new copySelection: selection asText]! getSelection "Copy the System scrap buffer text into the paste buffer" "SystemCall getSelection" | selection | selection _ (self default operation: getScrap) valueOnError: [nil]. selection == nil ifFalse: [ParagraphEditor new copySelection: selection asText]! openDeskTopNumbered: aNumber "Open a Desk Accessory. This desk accessory must have a separate view, not just a menu. The number required is a number returned from repeated calls to SystemCall enumerateDeskTop" SystemCall putScrap. (self default operation: openDA with: aNumber) value. SystemCall getScrap! printFile: fileName "Print a postscript file to a postscript printer." ^(self default operation: printFile with: (self cStringFrom: fileName)) valueOnError: [nil]! printFile: fileName encapsulate: aBoolean "Print a postscript file to a postscript printer. aBoolean indicates whether the file needs to be encapsulated to protect it from the Apple Printing Manager. Non-Smalltalk postscript files should be encapsulated. " ^(self default operation: printFile with: (self cStringFrom: fileName) with: aBoolean) valueOnError: [nil]! putScrap "Copy the current paste buffer into System Scrap as text." "SystemCall putScrap" | current | current _ ParagraphEditor currentSelection asString. ^(self default operation: putScrap with: (self cStringFrom: current)) valueOnError: [nil]! putSelection "Copy the current paste buffer into System Scrap as text." "SystemCall putSelection" | current | current _ ParagraphEditor currentSelection asString. ^(self default operation: putScrap with: (self cStringFrom: current)) valueOnError: [nil]! resetCreatorAndType "Reset the default Creator and Type to Smalltalk. Must be invoked after calling setCreator:andType." ^(self default operation: resetCreatorAndType) valueOnError: [nil]! resetDeskAccessory " Returns a pseudo reference number ( menuHandle ) in preparation for enumerating the Desk Accessories that are available." ^(self default operation: resetDA ) valueOnError: [nil]! setCreator: creator andType: type "Set the default Creator and Type of a file. Be sure to send the message resetCreatorAndType after invoking this method." ^(self default operation: setCreatorAndType with: (self cStringFrom: creator) with: (self cStringFrom: type)) valueOnError: [nil]! suspendSmalltalk "Suspend Smalltalk" (self operationCalled: #suspend) invoke.! ! !SystemCall class methodsFor: 'private'! primEnumerateFileClose: enumerationHandle "Close the enumeration handle opened with primEnumerateFileReset " ^(self operation: enumerateFileClose with: enumerationHandle) valueOnError: [nil]! primEnumerateFileNext: enumerationHandle into: array "The argument is a file enumeration handle. The result is a String containg the next file name in the enumeration, or nil if the enumeration is finished. If array is not nil, the following 4 values are placed in the fields of the second argument (array): (array at: 1) = file size in bytes. (array at: 2) = file last access time (seconds since Jan 1, 1901). (array at: 3) = file last modify time (seconds since Jan 1, 1901). (array at: 4) = true if file is a directory. The following error conditions exist: invalid or obsolete enumeration handle." ^(self operation: enumerateFileNext with: enumerationHandle with: array) valueOnError: [nil]! primEnumerateFileReset: pathName errorBuf: errorBuf "The argument is a directory path name. The result is an integer file enumeration handle, or nil if an error occurred. Fails the primitive if: name not bytes; name too long." ^(self operation: enumerateFileReset with: pathName with: errorBuf) valueOnError: [nil]! primStatusOfFile: fileHandle into: array "The first argument is a file handle. If the file exists, the following 3 values are placed in the fields of the second argument (array): (array at: 1) = file size in bytes. (array at: 2) = file last access time (seconds since Jan 1, 1901). (array at: 3) = file last modify time (seconds since Jan 1, 1901). (array at: 4) = true if file is a directory. If an error occurs, (array at: 1) is set to an error code, and the result is nil. Otherwise, the result is array. Fails the primitive if: name not bytes; name too long; array not pointer; array too small." ^(self operation: statusOfFile with: fileHandle with: array) valueOnError: [nil]! primStatusOfFileNamed: fileName into: array "The first argument is a file name. If the file exists, the following 6 values are placed in the fields of the second argument (array): (array at: 1) = file size in bytes. (array at: 2) = file last access time (seconds since Jan 1, 1901). (array at: 3) = file last modify time (seconds since Jan 1, 1901). (array at: 4) = true if file is a directory. (array at: 5) = true if file is readable. (array at: 6) = true if file is writable. If the file does not exist or an error occurs, (array at: 1) is set to an error code, and the result is nil. Otherwise, the result is array. Fails the primitive if: name not bytes; name too long; array not pointer; array too small." ^(self operation: statusOfFileNamed with: fileName with: array) valueOnError: [nil]! ! SystemCall initialize! Dictionary variableSubclass: #SystemDictionary instanceVariableNames: '' classVariableNames: 'BytesLeftLimit CachedClassNames Frills LowSpaceProcess LowSpaceSemaphore OopsLeftLimit SpecialSelectors SystemChanges ' poolDictionaries: '' category: 'System-Support'! SystemDictionary comment: 'Class SystemDictionary represents a special dictionary that supports protocol for asking questions about the structure of the system. The sole instance is Smalltalk. Class Variables: BytesLeftLimit CachedClassNames of all class names ConsolePollingProcess not used Frills used to indicate whether some of the functionality considered extra should not be used because of the slower speed of the hardware LowSpaceProcess for monitoring the amount of core left and number of remaining objects LowSpaceSemaphore OopsLeftLimit SpecialSelectors of selectors SystemChanges into which any changes such as method adds, removals, or renames, is remembered'! !SystemDictionary methodsFor: 'initialize-release'! install "Get connected back up to the hardware after a snapshot or quit." "Call the initialization code that depends on system parameters, in case we are coming up on a system different from the one that we quit or snapshot on." CompiledMethod initialize. SmallInteger initialize. LargePositiveInteger initialize. LargeNegativeInteger initialize. DisplayScreen resetExtent. Cursor currentCursor: Cursor currentCursor. InputSensor install. LowSpaceProcess == nil ifFalse: [LowSpaceProcess terminate]. LowSpaceSemaphore _ Semaphore new. LowSpaceProcess _ [self lowSpaceNotificationLoop] newProcess. LowSpaceProcess priority: Processor lowIOPriority. LowSpaceProcess resume. self resetSpaceLimits. SourceFiles == nil ifFalse: [ (SourceFiles at: 2 ) reopen]! ! !SystemDictionary methodsFor: 'accessing'! at: aKey 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." "Override from Dictionary so that can check Undeclared and fix up references of undeclared variables." | index element | index _ self findKeyOrNil: aKey. element _ self basicAt: index. element == nil ifTrue: [self valueAtNewKey: aKey put: anObject atIndex: index declareFrom: Undeclared] ifFalse: [element value: anObject]. ^anObject! valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary "Handle overriding atKey:put: from Dictionary so that adding something new to a system dictionary such as Smalltalk checks Undeclared and fixes up all references to the undeclared variable" (aDictionary includesKey: aKey) ifTrue: [self atNewIndex: index put: ((aDictionary associationAt: aKey) value: anObject). aDictionary removeKey: aKey] ifFalse: [self atNewIndex: index put: (Association key: aKey value: anObject)]. self flushClassNameCache! ! !SystemDictionary methodsFor: 'enumerating'! allBehaviorsDo: aBlock "Evaluate the argument, aBlock, for each kind of Behavior in the system (that is, Object and its subclasses)." aBlock value: Object. Object allSubclassesDo: aBlock! allClassesDo: aBlock "Evaluate the argument, aBlock, for each class in the system." (self classNames collect: [:name | Smalltalk at: name]) do: aBlock! pointersTo: anObject do: aBlock "Evaluate the argument aBlock for each pointer to anObject in the system. " ^self quickPointersTo: anObject do: aBlock! quickPointersTo: anObject do: aBlock "Evaluate the argument aBlock for each pointer to anObject in the system." | owner me caller myBlock | me _ thisContext. caller _ me sender. owner _ anObject firstOwner. myBlock _ nil. myBlock _ [(owner == me or: [owner == caller or: [owner == myBlock]]) ifFalse: [aBlock value: owner]. (owner _ anObject ownerAfter: owner) == nil]. myBlock whileFalse. me _ caller _ myBlock _ nil "Break cycles"! ! !SystemDictionary methodsFor: 'browsing'! browseAllCallsOn: aSymbol "Create and schedule a message browser on each method that calls on aSymbol." "For example, Smalltalk browseAllCallsOn: #open:label:. " | 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 initialSelection: key asSymbol keywords first! browseAllCallsOn: literal1 and: literal2 "Create and schedule a message browser on each method that calls on the two Symbols, literal1 and literal2." "For example, Smalltalk browseAllCallsOn: #at: and: #at:pt:. " BrowserView openListBrowserOn: (self allCallsOn: literal1 and: literal2) label: literal1 printString , literal2 printString initialSelection: literal1 asSymbol keywords first! browseAllImplementorsOf: selector "Create and schedule a message browser on each method that implements the message whose selector is the argument, selector. For example, Smalltalk browseAllImplementorsOf: #at:put:. " BrowserView openListBrowserOn: (self allImplementorsOf: selector) label: 'Implementors of ' , selector! browseAllSelect: aBlock "Create and schedule a message browser on each method that, when used as the block argument to aBlock gives a true result. For example, Smalltalk browseAllSelect: [:method | method numLiterals > 10] " BrowserView openListBrowserOn: (self allSelect: aBlock) label: 'selected messages'! browseChangedMessages "Create a browser on the changed message list." "Smalltalk browseChangedMessages" BrowserView openListBrowserOn: SystemChanges changedMessageList label: 'Changed Messages'! showMenuThenBrowse: selectorCollection "Show a menu of the given selectors, abbreviated to 20 characters. Create and schedule a message set browser of all implementors of the message chosen. Do nothing if no message is chosen." | aStream index | selectorCollection isEmpty ifTrue: [^Transcript cr; show: 'No messages sent.']. aStream _ WriteStream on: (String new: 200). selectorCollection do: [:sel | aStream nextPutAll: (sel contractTo: 20); cr]. aStream skip: -1. index _ (PopUpMenu labels: aStream contents) startUp. index > 0 ifTrue: [Smalltalk browseAllImplementorsOf: (selectorCollection at: index)]! ! !SystemDictionary methodsFor: 'retrieving'! allCallsOn: aLiteral "Answer a SortedCollection of all the methods that call on aLiteral." | aSortedCollection special byte | aSortedCollection _ SortedCollection new. special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:bytex | byte _ bytex]. Cursor execute showWhile: [self allBehaviorsDo: [:class | (class whichSelectorsReferTo: aLiteral special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSortedCollection add: class name , ' ' , sel]]]]. ^aSortedCollection! allCallsOn: firstLiteral and: secondLiteral "Answer a SortedCollection of all the methods that call on both aLiteral and secondLiteral." | aCollection secondArray firstSpecial secondSpecial firstByte secondByte | aCollection _ SortedCollection new. firstSpecial _ self hasSpecialSelector: firstLiteral ifTrueSetByte: [:byte1 | firstByte _ byte1]. secondSpecial _ self hasSpecialSelector: secondLiteral ifTrueSetByte: [:byte2 | secondByte _ byte2]. Cursor execute showWhile: [self allBehaviorsDo: [:class | secondArray _ class whichSelectorsReferTo: secondLiteral special: secondSpecial byte: secondByte. ((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select: [:aSel | (secondArray includes: aSel)]) do: [:sel | aCollection add: class name , ' ' , sel]]]. ^aCollection! allClassesImplementing: aSelector "Answer an Array of all classes that implement the message aSelector." | aCollection | aCollection _ ReadWriteStream on: Array new. self allBehaviorsDo: [:class | (class includesSelector: aSelector) ifTrue: [aCollection nextPut: class]]. ^ aCollection contents! allImplementedMessages "Answer a Set of all the messages that are sent by a method in the system but are not implemented." | aSet | aSet _ Set new: (Symbol instanceCount * 1.5) truncated. Cursor execute showWhile: [self allBehaviorsDo: [:cl | cl selectors do: [:aSelector | aSet add: aSelector]]]. ^aSet! allImplementorsOf: aSelector "Answer a SortedCollection of all the methods that implement the message aSelector." | aCollection | aCollection _ SortedCollection new. Cursor execute showWhile: [self allBehaviorsDo: [:class | (class includesSelector: aSelector) ifTrue: [aCollection add: class name, ' ', aSelector]]]. ^aCollection! allSelect: aBlock "Answer a SortedCollection of each method that, when used as the block argument to aBlock, gives a true result." | aCollection | aCollection _ SortedCollection new. Cursor execute showWhile: [self allBehaviorsDo: [:class | class selectors do: [:sel | (aBlock value: (class compiledMethodAt: sel)) ifTrue: [aCollection add: class name , ' ' , sel]]]]. ^aCollection! collectPointersTo: anObject "Answer an Array of all occurrences in the system of pointers to the argument anObject." "(Smalltalk collectPointersTo: Browser) inspect." | some me | some _ OrderedCollection new. me _ thisContext. self pointersTo: anObject do: [:obj | (obj ~~ me) & (obj ~~ some) ifTrue: [some add: obj]]. me _ nil. "to avoid circularity" ^some asArray! ! !SystemDictionary methodsFor: 'class names'! classNames "Answer a SortedCollection of all class names. Use cached copy if available." CachedClassNames == nil ifTrue: [^self newClassNames]. ^CachedClassNames! flushClassNameCache "Invalidate cached copy of classnames (see classNames)" CachedClassNames _ nil! newClassNames "Compute a sorted collection of class names and cache it for efficiency." | names | names _ OrderedCollection new: self size. self do: [:cl | (cl isKindOf: Class) ifTrue: [names add: cl name]]. ^CachedClassNames _ names asSortedCollection! ! !SystemDictionary methodsFor: 'compiling'! recompileAllFrom: firstName "Recompile all classes, starting with given name." "Smalltalk recompileAllFrom: 'Aardvark'." Smalltalk forgetDoIts. self allClassesDo: [:class | class name >= firstName ifTrue: [Transcript show: class name; cr. class compileAll]]! recompileCallsOn: aLiteral "Recompile every message in the system that refers to aLiteral." | special byte | special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:bytex | byte _ bytex]. Cursor execute showWhile: [self allBehaviorsDo: [:class | (class whichSelectorsReferTo: aLiteral special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [class recompile: sel]]]]! recompileMethodsForWhich: aBlock "Recompile all methods in the system for which aBlock evaluates to true." "For example, Smalltalk recompileMethodsForWhich: [:meth | meth size=6]" Cursor execute showWhile: [self allBehaviorsDo: [:class | class selectors do: [:sel | (aBlock value: (class compiledMethodAt: sel)) ifTrue: [Transcript show: class name , ' ' , sel; cr. class recompile: sel]]]]! ! !SystemDictionary methodsFor: 'change management'! changes "Answer the current system ChangeSet." ^SystemChanges! logChange: aStringOrText "Write the argument, a String or Text, onto the changes file." | aFileStream aString | SourceFiles == nil ifTrue: [^self]. (aStringOrText isMemberOf: Text) ifTrue: [aString _ aStringOrText string] ifFalse: [aString _ aStringOrText]. (aString isMemberOf: String) ifFalse: [self error: 'cant log this change']. (aString findFirst: [:char | char isSeparator not]) = 0 ifTrue: [^self]. "null doits confuse replay" aFileStream _ SourceFiles at: 2. aFileStream setToEnd; readWrite. aFileStream cr; cr; nextChunkPut: aString. aFileStream readOnly! newChanges: aChangeSet "Set the system ChangeSet to be aChangeSet." SystemChanges _ aChangeSet! noChanges "Initialize the system ChangeSet." SystemChanges initialize! recover: nCharacters "Schedule an editable text view on the last n characters of changes." | changes numberToSkip| changes _ SourceFiles at: 2. numberToSkip _ nCharacters min: changes size. changes setToEnd; skip: numberToSkip negated. (FileStream fileNamed: 'st80.recent') nextPutAll: changes; close; edit! removeClassNamed: className "Remove the class with the name className, and all of its subclasses, from the system, and note the removal in the system ChangeSet." | class | class _ self at: className asSymbol ifAbsent: [^self]. class subclasses do: [:subclass | self removeClassNamed: subclass name]. "remove subclasses first" SystemChanges removeClass: class. SystemOrganization removeElement: className. self removeKey: className asSymbol. self flushClassNameCache. class obsolete! renameClass: aClass as: newName "Rename the class, aClass, to have the title newName." | oldref | SystemOrganization classify: newName under: aClass category. SystemOrganization removeElement: aClass name. SystemChanges renameClass: aClass as: newName. oldref _ self removeKey: aClass name. oldref key: newName. (Undeclared includesKey: newName) ifTrue: [self at: newName put: aClass] ifFalse: [self add: oldref "Preserve old reference"]. self flushClassNameCache! ! !SystemDictionary methodsFor: 'memory space'! core "Answer an Array containing the number of objects in the system and the number of bytes they occupy. This is implementation dependent." "Smalltalk core" | n nobjects nbytes isBytes isPointers | nobjects _ nbytes _ 0. Smalltalk allBehaviorsDo: [:class | class isVariable ifTrue: [n _ 0. isBytes _ class isBytes. isPointers _ class isPointers. class allInstancesDo: [:inst | n _ n + 1. nbytes _ nbytes + (isPointers ifTrue: [inst basicSize*4] ifFalse: [isBytes ifTrue: [inst basicSize + 1 // 2 * 2] ifFalse: [inst basicSize*2]])]] ifFalse: [n _ class isMeta ifTrue: ["quicker" 1] ifFalse: [class instanceCount]]. nobjects _ nobjects + n. n = 0 ifFalse: [nbytes _ nbytes + (class instSize * n*4) +6]. "for header; this doesn't count the extra four bytes that large object have."]. ^Array with: nobjects with: nbytes! coreLeft "Answer the number of unallocated bytes in the object space. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! coreLeftLimit "Answer the threshold at which the user is to be notified that the system is low in core space." ^BytesLeftLimit! coreLeftLimit: newLimit "Set newLimit to be the threshold at which the user is to be notified that the system is low in core space." BytesLeftLimit _ newLimit. self resetLowSpaceSignal. ^newLimit! frills "Answer whether the current Smalltalk is willing to work harder - on slow machines, you may want to set Smalltalk frills: false" ^Frills! frills: aBoolean "Set to true for more functionality on fast machines - but on slow machines, you may want to set Smalltalk frills: false." ^Frills _ aBoolean! garbageCollect "Do a mark and sweep garbage collection of the entire Smalltalk system, eliminating any unreferencable objects. Smalltalk garbageCollect " | time startOops startCore result endOops endCore | Cursor garbage showWhile: [Transcript cr; show: 'Garbage collecting system (please wait)...'. time _ Time millisecondsToRun: [startCore _ self coreLeft. startOops _ self oopsLeft. result _ self primGarbageCollect. endOops _ self oopsLeft. endCore _ self coreLeft]. "note LargeInteger variables takes up oops and space" result isNil ifTrue: [Transcript cr; nextPutAll: '[Note: GC primitive not implemented]']. Transcript cr; nextPutAll: 'reclaimed '; print: (endOops - startOops max: 0); nextPutAll: ' oops, '; print: (endCore - startCore max: 0); nextPutAll: ' bytes in '; print: time//100/10.0; nextPutAll: ' sec.'; cr; print: endOops; nextPutAll: ' free oops, '; print: endCore; nextPutAll: ' free bytes.'; cr; endEntry. ].! growOTBy: anInteger ^self primitiveFailed! oopsLeft "Answer the number of unallocated object pointers in the object table. Equal to the net number of objects which can be created before the object table is full. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! oopsLeftLimit "Answer the threshold at which the user is to be notified that the system is low in number of oops." ^OopsLeftLimit! oopsLeftLimit: newLimit "Set newLimit to be the threshold at which the user is to be notified that the system is low in number of oops." OopsLeftLimit _ newLimit. self resetLowSpaceSignal. ^newLimit! primGarbageCollect "Do a mark and sweep garbage collection of the entire system, eliminating all unreferencable objects. Takes approximately several seconds even on fast hosts. Answer the number of objects that were marked during the collection. ie: The number of referencable objects in the system at that time. If not implemented, answer nil. Optional. See also documentation in Object metaclass." ^nil! resetLowSpaceSignal "The thresholds for notifying the user the space is low have changed so update the system." self signal: LowSpaceSemaphore atOopsLeft: OopsLeftLimit bytesLeft: BytesLeftLimit! resetSpaceLimits "Reset the threshold on the number of oops and the core space at which point the user should be notified." OopsLeftLimit _ self oopsLeft // 4. BytesLeftLimit _ self coreLeft // 4. self resetLowSpaceSignal! signal: aSemaphore atOopsLeft: numOops bytesLeft: numWords "Tell the object memory to signal the Semaphore when either the number of object pointers remaining drops below numOops, or the number of bytes in the object space remaining drops below numWords. Fail if the frist argument is neither a Semaphore nor nil. Fail if numOops is not a 16-bit Integer, or if numWords is not a 32-bit LargePositiveInteger. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !SystemDictionary methodsFor: 'special selectors'! hasSpecialSelector: aLiteral ifTrueSetByte: aBlock 1 to: self specialSelectorSize do: [:index | (self specialSelectorAt: index) == aLiteral ifTrue: [aBlock value: index + 16rAF. ^true]]. ^false! specialNargsAt: anInteger "Answer the number of arguments for the special selector at anInteger." ^SpecialSelectors at: anInteger * 2! specialSelectorAt: anInteger "Answer the special message selector stored at location anInteger in the system dictionary." ^SpecialSelectors at: anInteger * 2 - 1! specialSelectorSize "Answer the number of special selectors in the system." ^SpecialSelectors size // 2! ! !SystemDictionary methodsFor: 'system backup/out'! copyChangesTo: newFileName "If the file name supplied is different than the current changes file name, copy the changes file and install the new copy as the changes file." | oldName newFile | SourceFiles == nil ifTrue: [^self]. oldName _ (SourceFiles at: 2) name. oldName last = $. ifTrue: [oldName _ oldName copyFrom: 1 to: oldName size-1]. (FileDirectory includesKey: oldName) ifFalse: [(FileStream newFileNamed: oldName) nextPutAll: ''; close]. (newFileName sameAs: oldName) ifFalse: [Transcript cr; show: 'Copying ', oldName, ' to ', newFileName, '...'. (SourceFiles at: 2) close. Cursor write showWhile: [FileDirectory copyFileNamed: oldName to: newFileName]. newFile _ FileStream fileNamed: newFileName. newFile readOnly. SourceFiles at: 2 put: newFile. Transcript show: ' done'; cr]! exitSmalltalk | menu index imagePrefix | menu _ PopUpMenu labels: ' Save, then quit Quit, without saving Continue ' lines: #(1 2). index _ menu startUpAndWaitForSelectionAt: (Display boundingBox center). index = 1 ifTrue: [imagePrefix _ Smalltalk getImagePrefix. imagePrefix isEmpty ifTrue: [^self]. Smalltalk saveAs: imagePrefix thenQuit: true]. index = 2 ifTrue: [Smalltalk quit]! getImagePrefix "Prompt the user for a snapshot file name. Persist until a legal name is supplied." | default newPrefix prompt index | prompt _ 'Enter name for image file:'. SourceFiles == nil ifTrue: [default _ 'snapshot'] ifFalse: [default _ (SourceFiles at: 2) name. 1 to: default size do: [:i | (default at: i) == $. ifTrue: [index _ i]]. default _ index == nil ifTrue: [default] ifFalse: [default copyFrom: 1 to: index-1]]. newPrefix _ ''. FillInTheBlank request: prompt displayAt: Sensor cursorPoint centered: true action: [:response | newPrefix _ response] initialAnswer: default. [newPrefix isEmpty or: [(FileDirectory isLegalFileName: newPrefix, '.changes') not]] whileTrue: [newPrefix isEmpty ifTrue: [^newPrefix]. FillInTheBlank request: prompt displayAt: Sensor cursorPoint centered: true action: [:response | newPrefix _ response] initialAnswer: default. (newPrefix size > 2 and: [(newPrefix copyFrom: newPrefix size-2 to: newPrefix size) sameAs: '.im']) ifTrue: [newPrefix _ newPrefix copyFrom: 1 to: newPrefix size-3]. prompt _ 'Illegal file name: ', newPrefix, ' Enter name for image file:'. default _ FileDirectory default checkName: newPrefix, '.changes' fixErrors: true. default _ default copyFrom: 1 to: default size - 8]. ^newPrefix! quit "Close open files then exit to another operating system on the host machine, if one exists. All state changes in the object space since the last snapshot are lost." SystemCall putScrap. self releaseExternalViews. self changed: #aboutToQuit. self quitPrimitive! saveAs: imagePrefix thenQuit: quitIfTrue "Copy the changes file to the new name if necessary, then create a matching image file. Answer true if the image file was just created." SourceFiles == nil ifFalse: [(imagePrefix sameAs: 'snapshot') ifFalse: [self copyChangesTo: imagePrefix, '.changes']]. ^self snapshotAs: imagePrefix thenQuit: quitIfTrue! shutdown "Shut off the low space signal so that the Vmem writer can be sure the system is stable while it is tracing." self coreLeftLimit: 0. self oopsLeftLimit: 0! snapshot "Write the OT and Data of this Smalltalk out on the external file snapshot.im." self snapshotAs: 'snapshot' thenQuit: false! snapshotAs: imageFilePrefix thenQuit: quitIfTrue "Write the OT and Data of this Smalltalk out on an external file. Answer true if the snapshot was just created." | fName justSnapped msg | fName _ imageFilePrefix, '.', InterpreterName. (FileDirectory canWriteFile: fName) ifFalse: [^self error: 'snapshot file can not be written ']. SystemCall snapshotFileName: fName. SystemCall putSelection. Cursor execute show. quitIfTrue ifTrue: [self changed: #aboutToSnapshotAndQuit] ifFalse: [self changed: #aboutToSnapshot]. self logChange: '''----SNAPSHOT----'''. msg _ fName, ' created at ', Time dateAndTimeNow printString. self logChange: '"', msg, '"'. self releaseExternalViews. Transcript cr; show: msg. ScheduledControllers flushDisplayBits. Delay preSnapshot. Cursor wait show. justSnapped _ self snapshotPrimitive. justSnapped == nil ifTrue: [quitIfTrue ifTrue: [self quitPrimitive]]. self install. Cursor normal show. Delay postSnapshot. "may wake up other processes" SystemCall getSelection. ScheduledControllers restore. justSnapped == nil ifTrue: [self changed: #finishedSnapshot] "i.e., no quit or return was done" ifFalse: [quitIfTrue ifTrue: [self changed: #returnFromSnapshotAndQuit] ifFalse: [self changed: #returnFromSnapshot]. justSnapped == #primitiveFailed ifTrue: [self error: 'Snapshot primitive failed']]! suspend "Allow the system to prepare for a Suspend and resume with proper states." self changed: #aboutToSuspend. self releaseExternalViews. Cursor blank show. Display white. Delay preSnapshot. SystemCall suspendSmalltalk. self install. Delay postSnapshot. ScheduledControllers restore. self changed: #returnFromSuspend! ! !SystemDictionary methodsFor: 'time/versions'! copyright "The Smalltalk-80 system copyright: Copyright (c) 1987, 1988 ParcPlace Systems, Inc. All Rights Reserved. Smalltalk-80 is a trademark of ParcPlace Systems, Inc. " ^'Copyright (c) 1987, 1988 ParcPlace Systems, Inc. All Rights Reserved. Smalltalk-80 is a trademark of ParcPlace Systems, Inc.'! timeStamp: aStream "Writes system version and current time on stream aStream." | dateTime | dateTime _ Time dateAndTimeNow. aStream nextPutAll: 'From ', Smalltalk version, ' on ', (dateTime at: 1) printString, ' at ', (dateTime at: 2) printString! version "Answer the version of this Smalltalk release." ^'Smalltalk-80, Version 2.3 of 13 June 1988'! versionName "Answer the version identification, e.g. Smalltalk-80" ^'Smalltalk-80'! ! !SystemDictionary methodsFor: 'system compression'! condenseChanges "Move all the changes onto a compacted sources file. Smalltalk condenseChanges." | f fileName | f _ FileStream fileNamed: 'temp.changes'. f timeStamp. Smalltalk allBehaviorsDo: [:class | class moveChangesTo: f]. f close. f readOnly. fileName _ (SourceFiles at: 2) name. (SourceFiles at: 2) close. SourceFiles at: 2 put: f. FileDirectory removeKey: fileName. f file rename: fileName! forgetDoIts "get rid of old DoIt methods" "Smalltalk forgetDoIts" Smalltalk allBehaviorsDo: [:class | class removeSelectorSimply: #DoIt; removeSelectorSimply: #DoItIn:]! newSourceFile: vers "Make a new source file" self newSourceFile: vers without: (Array new)! newSourceFile: vers without: setOfClasses "Make a new source file omitting references to any classes in the set, setOfClasses. Smalltalk newSourceFile: Smalltalk versionName without: (Array new). Make sure versionName is updated. Then rename the image similarly, and delete the old sources and changes." | oldFile newFile class | oldFile _ SourceFiles at: 1. newFile _ FileStream fileNamed: vers , '.sources'. oldFile name = newFile name ifTrue: [self error: 'Do not overwrite the current source file!!']. newFile timeStamp. Smalltalk classNames do: [:className | class _ Smalltalk at: className. (setOfClasses includes: class) ifFalse: [class fileOutOn: newFile moveSource: true toFile: 1. newFile nextPut: Character newPage]]. newFile shorten; readOnly. SourceFiles at: 1 put: newFile. SourceFiles at: 2 put: (FileStream fileNamed: vers , '.changes'). (SourceFiles at: 2) shorten; readOnly! renameSystemFiles: newVersion "Rename the sources and changes and image files." "Smalltalk renameSystemFiles: Smalltalk versionName." | oldVersion file | oldVersion _ self getFileNamePrefixFor: (SourceFiles at: 1) name. (SourceFiles at: 1) close. SourceFiles at: 1 put: nil. (SourceFiles at: 2) close. SourceFiles at: 2 put: nil. #('.sources' '.changes' ) do: [:ext | (FileStream fileNamed: oldVersion , ext) file rename: newVersion , ext]. 1 to: 2 do: [:i | file _ FileStream fileNamed: newVersion , (#('.sources' '.changes' ) at: i). file readOnly. SourceFiles at: i put: file]! ! !SystemDictionary methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." "Intercepted to avoid infinite recursion when #Smalltalk is reached." | tooMany | tooMany _ aStream position + self maxPrint. aStream nextPutAll: self class name, ' keys ('. self keysDo: [:key | aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self]. key printOn: aStream. aStream space]. aStream nextPut: $)! ! !SystemDictionary methodsFor: 'private'! exitToDebugger "Enter the machine language debugger, if one exists. Essential. See Object documentation whatIsAPrimitive. " self primitiveFailed! getFileNamePrefixFor: aName | index | 1 to: aName size do: [:i | (aName at: i) == $. ifTrue: [index _ i]]. ^index == nil ifTrue: [aName] ifFalse: [aName copyFrom: 1 to: index - 1]! lowSpaceNotificationLoop [true] whileTrue: [LowSpaceSemaphore wait. ScheduledControllers interruptName: 'Space warning objects left: ', self oopsLeft printString, ' bytes left: ', self coreLeft printString. self resetSpaceLimits]! quitPrimitive "Exit to another operating system on the host machine, if one exists. All state changes in the object space since the last snapshot are lost. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! releaseExternalViews FileDirectory releaseExternalReferences! snapshotPrimitive "Write the current state of the object memory on a file in the same format as the Smalltalk-80 release. The file can later be resumed, returning you to this exact state. Return normally after writing the file. Essential. See Object documentation whatIsAPrimitive." ^#primitiveFailed! specialSelectors "Used by SystemTracer only" ^SpecialSelectors! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SystemDictionary class instanceVariableNames: ''! !SystemDictionary class methodsFor: 'class initialization'! initialize Project current noChanges "SystemDictionary initialize"! ! SystemDictionary initialize! ClassOrganizer subclass: #SystemOrganizer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Support'! SystemOrganizer comment: 'Class SystemOrganizer provides an organization for the classes in the system just as ClassOrganizer organizes the messages within a class. The only difference is the filout/printing messages.'! !SystemOrganizer methodsFor: 'fileIn/Out'! fileOutCategory: category "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." | aFileStream | aFileStream _ FileStream fileNamed: (category , '.st.') asFileName. self fileOutCategory: category on: aFileStream. aFileStream shorten; close! fileOutCategory: category on: aFileStream "File a description of the receiver's category onto the stream aFileStream." | first | first _ true. (self superclassOrder: category) do: [:class | first ifTrue: [first _ false] ifFalse: [aFileStream cr; nextPut: Character newPage; cr]. class fileOutOn: aFileStream moveSource: false toFile: 0. class removeFromChanges]! printOutCategory: category "Create a file with readable version of the classes in this category." "Default to fileOut." self fileOutCategory: category! superclassOrder: category "Answer an ordered collection containing the classes in category (a string). The classes are ordered with superclasses first so they can be filed in." | list | list _ (self listAtCategoryNamed: category asSymbol) collect: [:title | Smalltalk at: title]. ^ ChangeSet superclassOrder: list! ! !SystemOrganizer methodsFor: 'accessing'! changeFromString: aString "Intercept to notify the system change set of the system reorganization." | file | SourceFiles == nil ifFalse: [file _ SourceFiles at: 2. file setToEnd; readWriteShorten. file cr; nextChunkPut: 'SystemOrganization changeFromString: ', SystemOrganization printString storeString. file cr; readOnly]. Smalltalk changes reorganizeSystem. super changeFromString: aString.! ! TextCollector subclass: #Terminal instanceVariableNames: 'displayProcess serialPort localEcho ignoreLF characterLimit ' classVariableNames: 'PortYellowButtonMenu ShellYellowButtonMenu ' poolDictionaries: '' category: 'Interface-Terminal'! Terminal comment: 'I am a collector of text that comes from an ExternalPort Instance Variables: displayProcess "A handle to our background process." displayProcessRunning "Is the background process still running?" serialPort "Holds the serial port currently being used." '! !Terminal methodsFor: 'initialize-release'! initialize super initialize. ignoreLF _ false. localEcho _ false. characterLimit _ 30000! release self close. super release! ! !Terminal methodsFor: 'accessing'! characterLimit ^characterLimit! serialPort ^serialPort! ! !Terminal methodsFor: 'port control'! close (serialPort notNil and: [serialPort isOpen]) ifTrue: [serialPort removeDependent: self. serialPort release. serialPort close]! reset (serialPort notNil and: [serialPort isOpen]) ifTrue: [serialPort reset]! ! !Terminal methodsFor: 'character writing'! backspace "remove the last character from the text." entryStream isEmpty ifTrue: [contents size = 0 ifFalse: [contents _ contents copyFrom: 1 to: contents size-1. self changed: #backspace]] ifFalse: [entryStream skip: -1]! ! !Terminal methodsFor: 'updating'! update: parameter "Process a dependency message" parameter == #closeBeforeSnapshot ifTrue: [^displayProcess terminate]. parameter == #openAfterSnapshot ifTrue: [^self startReceiveProcess]. parameter == #externalPortError ifTrue: [self close. ^self changed: #externalPortError]! ! !Terminal methodsFor: 'private'! displayCharacters "If there are characters waiting to be displayed, show them." | char cr str bs lf bell | cr _ Character cr. lf _ Character lf. bs _ Character backspace. bell _ 7 asCharacter. [serialPort atEnd] whileFalse: [char _ (serialPort next bitAnd: 127) asCharacter. char == lf ifFalse: [char == bs ifTrue: [self backspace] ifFalse: [char == bell ifTrue: [SystemCall bell] ifFalse: [self nextPut: char]]]]. self endEntry. Processor yield! ignoreLF: aFlag ignoreLF _ aFlag! localEcho: aFlag localEcho _ aFlag.! sendAll: aString "Send out some of the user's input, echoed locally if required. Catches backspaces and swaps Cr and Lf." | bs cr lf len i | bs _ Character backspace. (serialPort notNil and: [aString size > 0]) ifTrue: [localEcho ifTrue: [ aString do: [:c | c = bs ifTrue: [self backspace] ifFalse: [self nextPut: c]]. self endEntry.]. ignoreLF ifTrue: [cr _ Character cr. lf _ Character lf. i _ 0. len _ aString size. [(i _ i + 1) <= len] whileTrue: [(aString at: i) == cr ifTrue: [aString at: i put: lf]]]. ^(serialPort sendBuffer: aString) ~~ nil] ifFalse: [^false]! setSerialPort: aSerialPort serialPort isNil ifFalse: [serialPort removeDependent: self]. serialPort _ aSerialPort . serialPort addDependent: self.! startReceiveProcess "Fires up the background process that will run in parallel with the user's input. " displayProcess _ [serialPort notNil ifTrue: [[serialPort isOpen] whileTrue: [serialPort receiveBuffer. self displayCharacters]. self cr; endEntry]] newProcess. displayProcess priority: Processor userSchedulingPriority. displayProcess resume.! yellowButtonMenu "Sets up our yellow button commands." (serialPort isKindOf: RS232Port) ifTrue: [PortYellowButtonMenu == nil ifTrue: [PortYellowButtonMenu _ ActionMenu labels: 'again\copy\paste\doit\inspect\speed\dial\reset' withCRs lines: #(1 3 5 7 ) selectors: #(again copySelection sendPasteBuffer doIt inspectIt baud dial reset )]. ^PortYellowButtonMenu] ifFalse: [ShellYellowButtonMenu == nil ifTrue: [ShellYellowButtonMenu _ ActionMenu labels: 'again\copy\paste\doit\inspect\reset' withCRs lines: #(1 3 5 ) selectors: #(again copySelection sendPasteBuffer doIt inspectIt reset )]. ^ShellYellowButtonMenu]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Terminal class instanceVariableNames: ''! !Terminal class methodsFor: 'instance creation'! openCsh "Terminal openCsh" | aTerminal port aCshNumber | CShellPort SerialHasShell ifFalse: [^self openPort: 1]. port _ nil. aTerminal _ self new. aCshNumber _ 1. [port isNil] whileTrue: [ port _ CShellPort open: aCshNumber. aCshNumber _ aCshNumber + 1. aCshNumber > 8 ifTrue: [ ^self error: 'Unable to open csh ' , aCshNumber printString , '.']]. aTerminal setSerialPort: port. aTerminal localEcho: false. aTerminal ignoreLF: true. self openViewOn: aTerminal label: 'Terminal '! openCsh: aCshNumber "Terminal openCsh: 1" | aTerminal port | aTerminal _ self new. port _CShellPort open: aCshNumber. port isNil ifTrue: [^self error: 'Unable to open csh ' , aCshNumber printString , '.']. aTerminal setSerialPort: port. aTerminal localEcho: false. aTerminal ignoreLF: true. self openViewOn: aTerminal label: 'Terminal'! openPort: aPortNumber "Terminal openPort: 1" | aTerminal rs232Port | aTerminal _ self new. rs232Port _ RS232Port open: aPortNumber. rs232Port isNil ifTrue: [^'Unable to open port ' , aPortNumber printString , '.']. aTerminal setSerialPort: rs232Port. aTerminal localEcho: false. aTerminal ignoreLF: false. self openViewOn: aTerminal label: 'Terminal on port ', aPortNumber printString! openPort: aPortNumber setSpeed: aBaudRate "Terminal openPort: 1" | aTerminal rs232Port | aTerminal _ self new. rs232Port _ RS232Port open: aPortNumber. rs232Port isNil ifTrue: [^'Unable to open port ' , aPortNumber printString , '.']. rs232Port setSpeed: aBaudRate. aTerminal setSerialPort: rs232Port. aTerminal localEcho: false. aTerminal ignoreLF: false. self openViewOn: aTerminal label: 'Terminal on port ', aPortNumber printString! ! !Terminal class methodsFor: 'private'! openViewOn: aTerminal label: aString "Creates a StandardSystemView with a TextCollectorView as a subview, both having aTerminal as their model. " | topView aView style| topView _ StandardSystemView new. topView model: aTerminal. topView label: aString. topView minimumSize: 160@120. topView borderWidth: 1. aView _ TerminalView new model: aTerminal. topView addSubView: aView in: (0@0 extent: 1@1) borderWidth: 1. style _ TextStyle styleNamed: #fixed ifAbsent: [nil]. style == nil ifTrue: [style _ TextStyle default]. aView displayContents textStyle: style. topView controller openNoTerminate. topView icon: (Icon constantNamed: #default). aTerminal startReceiveProcess. Cursor normal show. Processor terminateActive! ! TextCollectorController subclass: #TerminalController instanceVariableNames: '' classVariableNames: 'SavedInterruptKey ' poolDictionaries: '' category: 'Interface-Terminal'! TerminalController comment: 'The TerminalController''s job is: (a) to set-up and maintain a useful ASCII keyboard map, and (b) to set-up and handle the yellow button commands for the Terminal. Class Variables: KeyboardMap "Holds our own version of the keyboard map." '! !TerminalController methodsFor: 'initialize-release'! release "Overridden to allow some necessary clean-up by Terminals." super release. model release! ! !TerminalController methodsFor: 'basic control sequence'! controlInitialize "Save the key that interrupts the system and install a different one so I can have a different meaning for control c." SavedInterruptKey _ InputState interruptKey. InputState interruptKey: 162. "L3 key" ^super controlInitialize! controlTerminate "Return the interrupt key to its saved value." InputState interruptKey: SavedInterruptKey. ^super controlTerminate! ! !TerminalController methodsFor: 'control defaults'! controlActivity "this is needed to make the caret show" selectionShowing ifFalse: [self select]. super controlActivity! yellowButtonActivity | index menu selector | menu _ model yellowButtonMenu. index _ menu startUp. index ~= 0 ifTrue: [selector _ menu selectorAt: index. self perform: selector. ]! ! !TerminalController methodsFor: 'editing'! readKeyboard "Sends keyboard characters to the model (a Terminal)." | buffer | buffer _ WriteStream on: (String new: 20). [sensor keyboardPressed] whileTrue: [buffer nextPut: sensor keyboard. ]. (model sendAll: buffer contents) ifFalse: [view flash].! ! !TerminalController methodsFor: 'menu messages'! baud | result | "Request a number to be dial and send it to the model" result _ model serialPort getSpeed. FillInTheBlank request: 'Type new Baud Rate' displayAt: view insetDisplayBox center centered: true action: [:res | result _ res ] initialAnswer: result printString. result size > 0 ifTrue: [self controlTerminate. model serialPort setSpeed: result asNumber. self controlInitialize] ifFalse: [ view flash ].! close model close. "close the port."! dial | result | "Request a number to be dial and send it to the model" FillInTheBlank request: 'Type number to Dial' displayAt: view insetDisplayBox center centered: true action: [:res | result _ res ] initialAnswer: ''. result size > 0 ifTrue: [self controlTerminate. model serialPort dialUp: result asString. self controlInitialize] ifFalse: [ view flash ].! reset model reset. self cancel! sendPasteBuffer "send paste buffer to model" (model sendAll: CurrentSelection asString) ifFalse: [view flash].! ! !TerminalController methodsFor: 'entry control'! removeLastCharacter "Remove the last character from the editable text." view topView isCollapsed ifTrue: [paragraph text replaceFrom: 1 to: paragraph text size with: model contents] ifFalse: [self deselect. startBlock _ paragraph characterBlockForIndex: paragraph text size. stopBlock _ paragraph characterBlockForIndex: paragraph text size + 1. self replaceSelectionWith: Text new. self selectWithoutComp: paragraph text size + 1. self selectAndScroll. self deselect]! ! !TerminalController methodsFor: 'private'! checkInterruptKey "Check that the interruptKey state is correct." SavedInterruptKey == InputState interruptKey ifFalse: [InputState interruptKey: SavedInterruptKey]! initializeYellowButtonMenu "Sets up our yellow button commands." self yellowButtonMenu: (PopUpMenu labels: 'again\copy\paste\doit\inspect\speed\dial\reset' withCRs lines: #(1 3 5 7)) yellowButtonMessages: #(again copySelection sendPasteBuffer doIt inspectIt baud dial reset)! ! TextCollectorView subclass: #TerminalView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Terminal'! TerminalView comment: 'I am a the default controller for a TerminalView'! !TerminalView methodsFor: 'emphasis'! deEmphasizeView "Check that the interruptKey state is correct." self controller checkInterruptKey. super deEmphasizeView! ! !TerminalView methodsFor: 'controller access'! defaultControllerClass ^TerminalController! ! !TerminalView methodsFor: 'updating'! update: aParameter aParameter == #backspace ifTrue: [^controller removeLastCharacter]. super update: aParameter! ! ArrayedCollection subclass: #Text instanceVariableNames: 'string runs ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Collections-Text'! Text comment: 'Class Text handles protocol for treating strings of characters as displayable characters that can have emphasis and font changes. Instance Variables: string of Characters runs of emphasis codes The emphasis codes indicate abstract changes in character appearance. Actual display is performed in the presence of a TextStyle which indicates, for each abstract code, an actual font to be used'! !Text methodsFor: 'accessing'! at: index "Answer the Character stored in the field of the receiver indexed by the argument." ^string at: index! at: index put: character "Store the argument aCharacter in the field of the receiver indicated by the index. Answer aCharacter. Fail if the index is not an Integer or is out of bounds, or if the argument is not a Character. " ^string at: index put: character! findString: aString startingAt: start "Answer the index of subString within the receiver, starting at position start. If the receiver does not contain subString, answer 0." ^string findString: aString asString startingAt: start! replaceFrom: start to: stop with: aText string _ string copyReplaceFrom: start to: stop with: aText string. runs _ runs copyReplaceFrom: start to: stop with: aText runs! size "Answer how many elements the receiver contains." ^string size! string "Answer the string representation of the receiver." ^string! ! !Text methodsFor: 'comparing'! = anotherText "Answer whether the string receiver and that of the argument are equal." anotherText species == Text ifFalse: [ ^false ]. ^string = anotherText string! ! !Text methodsFor: 'copying'! copy "Answer another instance just like the receiver." ^self deepCopy! copyFrom: start to: stop "Answer with a copied subrange of this text" | realStart realStop | stop > self size ifTrue: [realStop _ self size] "handle selection at end of string" ifFalse: [realStop _ stop]. start < 1 ifTrue: [realStart _ 1] "handle selection before start of string" ifFalse: [realStart _ start]. ^Text string: (string copyFrom: realStart to: realStop) runs: (runs copyFrom: realStart to: realStop)! copyReplaceFrom: start to: stop with: aText ^self shallowCopy replaceFrom: start to: stop with: aText! ! !Text methodsFor: 'converting'! asDisplayText "Answer a DisplayText whose text is the receiver." ^DisplayText text: self! asLowercase string _ string asLowercase! asNumber "Answer the number created by interpreting the receiver as the textual representation of a number." ^string asNumber! asParagraph "Answer a Paragraph whose text is the receiver." ^Paragraph withText: self! asString "Answer a String representation of the textual receiver." ^string! asText "Answer the receiver itself." ^self! asUppercase string _ string asUppercase! ! !Text methodsFor: 'emphasis'! allBold self emphasizeFrom: 1 to: self size with: 2! emphasisAt: characterIndex "Answer the code for characters in the run beginning at characterIndex." self size = 0 ifTrue: [^1]. "null text tolerates access" ^runs at: characterIndex! emphasizeFrom: start to: stop with: emphasis "Set the emphasis for characters in the interval start-stop." runs _ runs copyReplaceFrom: start to: stop with: (RunArray new: stop - start + 1 withAll: emphasis)! makeSelectorBoldIn: aClass "For formatting Smalltalk source code, set the emphasis of that portion of the receiver's string that parses as a message selector to be bold." | parser | string size = 0 ifTrue: [^self]. (parser _ aClass parserClass new) parseSelector: string. self emphasizeFrom: 1 to: (parser endOfLastToken min: string size) with: 2! runLengthFor: characterIndex "Answer the count of characters remaining in run beginning with characterIndex." ^runs runLengthAt: characterIndex! ! !Text methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver. The format is Text for sequence-of-characters." aStream nextPutAll: 'Text for '. string printOn: aStream! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates text similar to the receiver." aStream nextPutAll: '(Text string: '; store: string; nextPutAll: ' runs: '; store: runs; nextPut: $)! ! !Text methodsFor: 'private'! runs ^runs! setString: aString setRuns: anArray string _ aString. runs _ anArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Text class instanceVariableNames: ''! !Text class methodsFor: 'class initialization'! initialize "Initialize constants shared by classes associated with text display." "Text initialize." (Smalltalk includesKey: #TextConstants) ifFalse: [Smalltalk at: #TextConstants put: (Dictionary new: 32)]. self initTextConstants! initTextConstants "Initialize constants shared by classes associated with text display, e.g., space, tab, cr, bs, esc." "Text initTextConstants." | tempArray | TextConstants at: #FontKeys "CTL-1 thru 9, and 0, CTLSHIFT 1 and CTRL@" put: #(209 210 211 212 213 214 215 216 217 208 193 0 ). TextConstants at: #EncloseKeys " controls ( [ < { DoubbleQuote ' " put: # (200 27 220 251 194 199 ). TextConstants at: #Space put: (32 asCharacter). TextConstants at: #Tab put: (9 asCharacter). TextConstants at: #CR put: (13 asCharacter). TextConstants at: #BS put: (8 asCharacter). TextConstants at: #BS2 put: (179 asCharacter). TextConstants at: #Ctrlw put: (23 asCharacter). TextConstants at: #ESC put: (27 asCharacter). TextConstants at: #Cut put: (127 asCharacter). TextConstants at: #Paste put: (10 asCharacter). TextConstants at: #Ctrlt put: (20 asCharacter). TextConstants at: #Ctrlf put: (6 asCharacter). TextConstants at: #Ctrlz put: (26 asCharacter). "in case font doesn't have a width for space character" "some plausible numbers-- are there right ones?" TextConstants at: #DefaultSpace put: 4. TextConstants at: #DefaultTab put: 24. TextConstants at: #DefaultLineGrid put: 16. TextConstants at: #DefaultBaseline put: 12. TextConstants at: #DefaultRule put: Form over. TextConstants at: #DefaultMask put: Form black. TextConstants at: #CtrlMinus put: (205 asCharacter). TextConstants at: #CtrlShiftMinus put: (31 asCharacter). TextConstants at: #Ctrlb put: (2 asCharacter). TextConstants at: #CtrlB put: (226 asCharacter). TextConstants at: #Ctrld put: (4 asCharacter). TextConstants at: #Ctrli put: (9 asCharacter). TextConstants at: #CtrlI put: (233 asCharacter). TextConstants at: #Ctrlx put: (24 asCharacter). tempArray _ Array new: Display width // DefaultTab. 1 to: tempArray size do: [:i | tempArray at: i put: DefaultTab * i]. TextConstants at: #DefaultTabsArray put: tempArray. tempArray _ Array new: (Display width // DefaultTab) // 2. 1 to: tempArray size do: [:i | tempArray at: i put: (Array with: (DefaultTab*i) with: (DefaultTab*i))]. TextConstants at: #DefaultMarginTabsArray put: tempArray. "Text initTextConstants2." TextConstants at: #Ctrlh put: (8 asCharacter). TextConstants at: #CtrlH put: (232 asCharacter). TextConstants at: #Ctrls put: (19 asCharacter). TextConstants at: #CtrlS put: (243 asCharacter). TextConstants at: #Ctrln put: (14 asCharacter). TextConstants at: #CtrlN put: (238 asCharacter). TextConstants at: #Ctrlp put: (16 asCharacter). TextConstants at: #CtrlTopBlank put: (176 asCharacter). TextConstants at: #CtrlMiddleBlank put: (177 asCharacter). TextConstants at: #CtrlBottomBlank put: (178 asCharacter). "location of non-character stop conditions" TextConstants at: #EndOfRun put: 257. TextConstants at: #CrossedX put: 258. "values for alignment" TextConstants at: #LeftFlush put: 0. TextConstants at: #RightFlush put: 1. TextConstants at: #Centered put: 2. TextConstants at: #Justified put: 3. "subscripts for a marginTabsArray tuple" TextConstants at: #LeftMarginTab put: 1. TextConstants at: #RightMarginTab put: 2. "font faces" TextConstants at: #Basal put: 0. TextConstants at: #Bold put: 1. TextConstants at: #Italic put: 2. TextConstants at: #BoldItalic put: 3. TextConstants at: #Underlined put: 4. TextConstants at: #OverStruck put: 8. TextConstants at: #Subscripted put: 16. TextConstants at: #Superscripted put: 32. TextConstants at: #SubscriptedUnderlined put: 20. TextConstants at: #SuperscriptedUnderlined put: 36. TextConstants at: #UnderlinedBit put: 3. TextConstants at: #OverStruckBit put: 4. TextConstants at: #SubscriptedBit put: 5. TextConstants at: #SuperscriptedBit put: 6. TextConstants at: #SubSuperscriptMask put: 48. TextConstants at: #NonFaceEmphasisMask put: 52. "overstrike not supported" TextConstants at: #FamilyName put: 1. TextConstants at: #PointSize put: 2. TextConstants at: #Face put: 3.! ! !Text class methodsFor: 'instance creation'! fromString: aString "Answer an instance of the receiver whose characters are those of the argument, aString." ^self string: aString emphasis: 1! fromUser "Answer an instance of the receiver obtained by requesting the user to type some characters into a View." | result | FillInTheBlank request: 'Type text followed by carriage return' displayAt: (50@ Display boundingBox height//2) centered: false action: [:res | result _ res] initialAnswer: ''. ^self fromString: result! new: stringSize "Answer a new instance of the receiver whose length is stringSize." ^self fromString: (String new: stringSize)! string: aString emphasis: code "Answer an instance of the receiver whose characters are those of the argument, aString. Use the font whose index into the default TextStyle font array is code." ^self string: aString runs: (RunArray new: aString size withAll: code)! ! !Text class methodsFor: 'private'! string: aString runs: anArray ^self basicNew setString: aString setRuns: anArray! ! Text initialize! TextDisplayScanner subclass: #TextAlignScanner instanceVariableNames: 'compositionScanner ' classVariableNames: '' poolDictionaries: '' category: 'Interface-TextEditor'! TextAlignScanner comment: 'I support the text alignment functions (justification, centering and right flush). I hold a CompositionScanner to get a TextLineInterval which contains some paddingWidth. I don''t return the stopping CharacterBlock. Instance Variables: compositionScanner A scanner which measures a line and determines where the line breaks and space padding should occur.'! !TextAlignScanner methodsFor: 'initialize-release'! initializeFromCompositor: aCompositor stop: newStop super initializeFromCompositor: aCompositor stop: newStop. compositionScanner == nil ifTrue: [compositionScanner _ CompositionScanner new]! ! !TextAlignScanner methodsFor: 'stop conditions'! cr lastIndex_ lastIndex + 1. ^false! crossedX self checkEmphasis. ^true! endOfRun | 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! 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 _ (spaceIndex _ 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! ! !TextAlignScanner methodsFor: 'scanning'! displayOneLine: lineIndex start: startIndex in: aCompositor "Display a line whose start caracter index and line index are startIndex lineIndex, and return the character index of next line start." | runLength | compositionScanner in: aCompositor. line _ compositionScanner composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aCompositor. lastIndex _ line first. self setStopConditions. offsetX _ aCompositor compositionRectangle left. offsetY _ aCompositor topAtLineIndex: lineIndex. rightMargin _ (aCompositor rightMarginForDisplay) - offsetX. runX _ spaceX _ destX _ leftMargin _ (aCompositor leftMarginForDisplayForLine: lineIndex) - offsetX. lineY _ destY _ 0. destY _ lineY + self fontAscentDelta. runLength _ text runLengthFor: line first. (runStopIndex _ lastIndex + (runLength - 1)) > line last ifTrue: [runStopIndex _ line last]. spaceCount _ 0. displaying _ true. self clearLineFormAt: 0@0. [self perform: (self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions displaying: displaying)] whileFalse: []. self copyLineFormOnDisplayMediumAt: offsetX @ offsetY. ^line last + 1! nextLineStart: startIndex line: lineIndex in: aCompositor "Return the character index of start of the next line." compositionScanner in: aCompositor. line _ compositionScanner composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aCompositor. ^line last + 1! ! CharacterBlockScanner subclass: #TextCharacterBlockScanner instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-TextEditor'! TextCharacterBlockScanner comment: ' I am a subclass of CharacterBlockScanner to return a CharacterBlock of the stopping character which is not within the view. '! !TextCharacterBlockScanner methodsFor: 'private'! buildCharacterBlockIn: aParagraph | lineIndex runLength lineStop done stopCondition | (characterIndex ~~ nil and: [characterIndex >= aParagraph nextChar]) ifTrue: [aParagraph nextChar = (text size + 1) "end of text is visible" ifTrue: [characterIndex _ aParagraph nextChar] ifFalse: [^CharacterBlock stringIndex: characterIndex character: nil topLeft: aParagraph compositionRectangle right @ aParagraph clippingRectangle bottom extent: 0 @ textStyle lineGrid]]. (characterIndex ~~ nil and: [characterIndex < (aParagraph lines at: 1)]) ifTrue: [^CharacterBlock stringIndex: characterIndex character: nil topLeft: aParagraph compositionRectangle left @ (aParagraph compositionRectangle top - textStyle lineGrid - textStyle baseline) extent: 0 @ textStyle lineGrid]. "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. textStyle alignment = LeftFlush ifFalse: [line _ self computeLine: lineIndex start: line first in: aParagraph]. 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]]! computeLine: lineIndex start: iStart in: aCompositor | compositionScanner | compositionScanner _ CompositionScanner new in: aCompositor. ^compositionScanner composeLine: lineIndex fromCharacterIndex: iStart inParagraph: aCompositor! ! StringHolder subclass: #TextCollector instanceVariableNames: 'entryStream ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Transcript'! TextCollector comment: 'I represent a StringHolder into which text can also be gathered by sending messages using Stream protocol. Instance Variables entryStream '! !TextCollector methodsFor: 'initialize-release'! initialize super initialize. self beginEntry! ! !TextCollector methodsFor: 'accessing'! next: anInteger put: aCharacter "Insert the character, aCharacter, at position anInteger in the text." ^entryStream next: anInteger put: aCharacter! nextPut: aCharacter "Append aCharacter to the text." ^entryStream nextPut: aCharacter! nextPutAll: aCollection "Append all the characters in aCollection to the text." ^entryStream nextPutAll: aCollection! show: aString "Append all the characters in aCollection to the text and display the text." self nextPutAll: aString. self endEntry! ! !TextCollector methodsFor: 'clearing'! clear "Re-initialize the text to contain no characters." contents _ Text new. self beginEntry. self changed: #update "Transcript clear"! refresh "Bring window to front on screen" self changed: #refresh "Transcript refresh"! ! !TextCollector methodsFor: 'entry control'! appendEntry "Append the text contents of the receiver's WriteStream to its text." contents _ contents , self nextEntry asText. contents size > self characterLimit ifTrue: [contents _ contents copyFrom: contents size - (self characterLimit // 2) to: contents size]. self beginEntry! beginEntry "To speed up appending information to the receiver, a WriteStream is maintained. Initialize it." entryStream _ WriteStream on: (String new: 200)! endEntry "If the receiver's WriteStream is not empty, then reinitialize it. Send all depends a message that the streaming has changed." entryStream isEmpty ifFalse: [self changed: #appendEntry. self beginEntry]! nextEntry "Answer the text contents of the receiver's WriteStream." ^entryStream contents! ! !TextCollector methodsFor: 'character writing'! cr "Append a carriage return to the text." ^entryStream cr! crtab "Append a carriage return and a tab to the text." ^entryStream crtab! crtab: anInteger "Append a carriage return and anInteger number of tabs to the text." ^entryStream crtab: anInteger! space "Append a space to the text." ^entryStream space! tab "Append a tab to the text." ^entryStream tab! ! !TextCollector methodsFor: 'printing'! print: anObject "Append a description of the object, anObject, to the text." ^entryStream print: anObject! store: anObject "Have anObject print on me for rereading." anObject storeOn: self! ! !TextCollector methodsFor: 'private'! characterLimit ^10000! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextCollector class instanceVariableNames: ''! !TextCollector class methodsFor: 'system'! newTranscript: aTextCollector "Store aTextCollector as the value of the system global Transcript." Smalltalk at: #Transcript put: aTextCollector. ^aTextCollector! ! !TextCollector class methodsFor: 'examples'! transcript "This example demonstrates how TextCollectors support WriteStream protocol for appending characters to the System Transcript. Leave the System Transcript in view so you can see the result of trying the example." "TextCollector transcript" Transcript show: (3 + 4) printString; cr. Transcript nextPutAll: '3+4 ='; space; print: 3 + 4; cr; endEntry! ! StringHolderController subclass: #TextCollectorController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Transcript'! TextCollectorController comment: 'I am a kind of StringHolderController (a ParagraphEditor) that adds the doIt, printIt, accept, and cancel commands. I do not change the yellow button menu. I do add methods for accepting text that was generated from Stream-like messages to the model, a TextCollector'! !TextCollectorController methodsFor: 'entry control'! appendEntry "Append new text to my end." view topView isCollapsed ifTrue: [paragraph text replaceFrom: 1 to: paragraph text size with: model contents asText] ifFalse: [view displaySafe: [self deselect. paragraph text size > model characterLimit ifTrue: [paragraph removeFirstChars: paragraph text size - (model characterLimit // 2)]. self selectWithoutComp: paragraph text size + 1. self replaceSelectionWith: model nextEntry asText. self selectWithoutComp: paragraph text size + 1. self selectAndScrollUp. self deselect. model contents: paragraph text]]! changeText: aText "The paragraph to be edited is changed to aText." view displaySafe: [self deselect. paragraph replaceFrom: 1 to: paragraph textSize with: aText. self selectWithoutComp: paragraph text size + 1. self selectAndScroll. self deselect]! viewToTop "Bring the view to top in z of screen." "view topView isCollapsed ifFalse: [view display]."! ! !TextCollectorController methodsFor: 'private'! selectWithoutComp: characterIndex startBlock _ paragraph characterBlockForIndex: characterIndex. stopBlock _ startBlock copy! ! StringHolderView subclass: #TextCollectorView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Transcript'! TextCollectorView comment: 'I am a StringHolderView of the description of the contents of a TextCollector or Transcript. TextCollectorController is my default controller.'! !TextCollectorView methodsFor: 'updating'! update: aParameter self topView isCollapsed ifTrue: [model appendEntry]. (self controller isKindOf: TextCollectorController) ifTrue: [aParameter == #appendEntry ifTrue: [^controller appendEntry]. aParameter == #update ifTrue: [^controller changeText: model contents asText]. aParameter == #refresh ifTrue: [^controller viewToTop]]! ! !TextCollectorView methodsFor: 'controller access'! defaultControllerClass ^TextCollectorController! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextCollectorView class instanceVariableNames: ''! !TextCollectorView class methodsFor: 'instance creation'! open "Answer an instance of me on a new TextCollector. Schedule it." ^self open: TextCollector new label: 'TextCollector'! open: aTextCollector label: aString "Answer an instance of me on the argument, aTextCollector. The label of the StandardSystemView should be aString." | topView aView | topView _ StandardSystemView new. topView model: aTextCollector. topView label: aString. topView minimumSize: 160 @ 55. aView _ self new model: aTextCollector. aView insideColor: Form white. aView borderWidth: 1. topView borderWidth: 1. topView addSubView: aView. topView icon: (Icon constantNamed: #default). topView controller open! ! Object subclass: #TextCompositor instanceVariableNames: 'text textStyle offset form clippingRectangle compositionRectangle destinationForm rule mask marginTabsLevel firstIndent restIndent rightIndent outputMedium lines lastLine nextChar textSize lineLength scanner charsPerLine ' classVariableNames: 'DefaultCompositionRectangle ' poolDictionaries: 'TextConstants ' category: 'Interface-TextEditor'! TextCompositor comment: 'I compose text and display it within compositionRectangle. The compositionRectangle is an inset box of clippingRectangle. I use lines, nextChar, lineLength, scanner for composition. instance variables: text textStyle offset form clippingRectangle A Rectangle in CurrentDisplay coordinates. Its intersection with the compositionRectangle in turn intersected with the destinationForm is the area in which characters are constrained to be displayed. compositionRectangle A display region rectangle that is invariant as long as the user does not reframe or move the view. The compositionRectangle is inset from the clippingRectangle. destinationForm The Form into which the characters are scanned. Typically CurrentDisplay. rule The rule according to which character display behaves. mask The form with which each character is combined by the scanner before applying the rule for display. marginTabsLevel The margin tabs give the left and right indent values for a specified marginTabsLevel. The marginTabsLevel is sometimes referred to as the nesting level and is an index into the marginTabsArray of the stringStyle. firstIndent Amount to inset from the left margin for the first line of a paragraph. Initialized in the textStyle. restIndent Amount to inset from the left margin for all but the first line of a paragraph. Initialized in the textStyle. rightIndent Amount to inset from the right margin for all the lines of the paragraph. Initialized in the textStyle. outputMedium Either #Display or #DisplayPrinterWidths. 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. Also used for some margin and grid computations. lines Keeps the first character index of each line of the compositionRectangle. If any character is not displayed, that entry in the array lines is nil. The last entry of lines which is not nil is nextChar. lastLine The index of the last validly composed line in the lines array. nextChar The last characterIndex displayed within the compositionRectangle plus one. When end of text is within the compositionRectangle, nextChar = text size + 1. When end of text is beyond the compositionRectangle, nextChar < text size + 1. textSize lineLength The size of lines which can be displayed within the compositionRectangle. scanner Object to scan and display one line. charsPerLine A default value used for scrolling. Composition algorithm: 1. update lines before scanning text, the delta change due to insertion or deletion is added to each entry after the scanning start line. 2. composition and display scanning is done by giving the scanner a character index where to start scanning. The scanner returns a character index of next line''s start. Then it become a character index where to start next line scanning. This scanning corresponds to one line. Displaying is done with scanning at the same time. 3. compare next index with entry in lines During scanning, this compares a returned index with an entry in lines. Scanning is continued until each entry in lines is correct. After each line scan, the returned index is put into entry in line as the new value. If the returned index matches the entry in lines, then scanning stops. If the entry is nil, then put the right index into the entry in lines and display the line. 4. move down (text insertion) before the display scanning of each line, the start index of scanning and start index of next line is less than the entry in lines, move down all lines that follow the scanning line. 5. move up (text deletion) before the display scanning of each line, try to find a entry which can be moved up, that is, if the next index which scanning starts from is greater than the current entry in lines, try to find the next matched entry until the index is less than the entry in lines. If any matched entry is found, then move the lines which are below the matched start line up to the index line. Then the scanning line is set to be next to the moved lines. 6. end of composition Composition can be stopped if the next index matches the next entry in lines, or by scanning up to end of text, or lastLine of compositionRectangle. Composition returns a CharacterBlock. 7. exeption In the following case, return a characterBlock imediately and no composition will happen. Both starting index and stopping index are: below bottom above top or text size = 0.'! !TextCompositor methodsFor: 'initialize-release'! resetState "Establish the initial conditions" lines _ Array new: lineLength + 1. lines at: 1 put: 1. nextChar _ 1. lastLine _ 0. textSize _ 0.! ! !TextCompositor methodsFor: 'accessing'! baseline "Answer the baseline of the receiver's text style." ^textStyle baseline! clippingRectangle "Answer the rectangle, defined in absolute coordinates, whose intersection with the destinationForm is the area in which the characters are constrained to display." ^clippingRectangle! clippingRectangle: aRectangle "Set the rectangle, defined in absolute coordinates, whose intersection with the destinationForm is the area in which the characters are constrained to display." clippingRectangle _ aRectangle! compositionRectangle "Answer the rectangle whose width is the dimension, modified by indents and tabsLevels, against which line wraparound is measured." ^compositionRectangle! compositionRectangle: compRectangle compositionRectangle _ compRectangle! destinationForm "Answer the Form into which the characters are scanned." ^destinationForm! destinationForm: aFormOrRectangle "Set the Form or Rectangle into which the characters are scanned. " destinationForm _ aFormOrRectangle! form "Answer the form or caching the bit representation of the receiver's composed text." ^form! height "Answer the height of the composition rectangle." ^compositionRectangle height! lastLine "Answer the number of lines in the displayed text." ^lastLine! lineGrid "Answer the lineGrid of my TextStyle." ^textStyle lineGrid! lineLength "Answer the number of lines which can be displayed in the view." ^lineLength! lines "Answer the table which contains line start character indices." ^lines! mask "Answer the form with which each character is combined by the scanner before applying the rule for display." ^mask! mask: maskForm "Set the argument, maskForm, to be the form with which each character is combined by the scanner before applying the rule for display." mask _ maskForm.! numberOfLines "Answer the number of lines in the displayed text." ^lastLine! offset "Answer the offset of the receiver." ^offset! offset: aPoint "Set the offset to be the argument aPoint." offset _ aPoint! outputMedium "Answer the outputMedium for the receiver." ^outputMedium! outputMedium: aSymbol "Set the argument to be the output medium for the receiver." outputMedium _ aSymbol. textStyle outputMedium: aSymbol! replaceFrom: start to: stop with: aText "Replace the receiver's text starting at position start, stopping at stop, by the characters in aText." text replaceFrom: start to: stop with: aText. ^self update: start to: stop withSize: aText size! rule "Answer the rule according to which character display behaves. For example, rule may equal over, under, reverse." ^rule! rule: ruleInteger "Set the rule according to which character display behaves." rule _ ruleInteger.! setCompositionRectangle: compRectangle "Set the rectangle whose width is the dimension, modified by indents and tabsLevels, against which line wraparound is measured." compositionRectangle _ compRectangle.! 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 text displayed by the receiver." text _ aText! textSize "Answer the receiver's text size." ^textSize! 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. firstIndent _ textStyle firstIndent. restIndent _ textStyle restIndent. rightIndent _ textStyle rightIndent. form _ nil. self newLines. self changed.! ! !TextCompositor methodsFor: 'displaying'! display "Show the text of the receiver on the display screen." self displayOn: Display! displayAt: aPoint "Display the receiver located at aPoint within its clipping rectangle and according to the receiver's rule and mask." "Because Paragraphs cache so much information, computation is avoided and displayAt: 0@0 is not appropriate here" self displayOn: destinationForm at: aPoint clippingBox: clippingRectangle rule: rule mask: mask! displayMoveLines: topLine to: destLine "Move the paragraph such that line index topLine is set to line index destLine." | box move bottomLine firstClearLine lineIndex startIndex | box _ self compositionRectangle intersect: destinationForm boundingBox. move _ box left @ (self topAtLineIndex: topLine) corner: box corner. destinationForm copyBits: move from: destinationForm at: move left @ (self topAtLineIndex: destLine) clippingBox: box rule: Form over mask: nil. bottomLine _ self lineIndexOfTop: box corner y. topLine > destLine ifTrue: "up" [firstClearLine _ lineLength + 1 + destLine - topLine. destinationForm white: (box left @ (self topAtLineIndex: firstClearLine) corner: self clippingRectangle corner). "In case that the view intersects bottom of the display screen." box corner y < compositionRectangle corner y ifTrue: [lineIndex _ bottomLine + destLine - topLine max: 1. destinationForm white: (box left @ (self topAtLineIndex: lineIndex) corner: box right @ (self topAtLineIndex: firstClearLine)). startIndex _ lines at: lineIndex. [startIndex < nextChar] whileTrue: [startIndex _ scanner displayOneLine: lineIndex start: startIndex in: self. lineIndex _ lineIndex + 1]]] ifFalse: "down" [destinationForm white: (move origin corner: box right @ (self topAtLineIndex: destLine))]! displayOn: aDisplayMedium "Display on a new destination medium" self displayOn: aDisplayMedium at: compositionRectangle topLeft clippingBox: clippingRectangle rule: rule mask: mask! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "Default display message when aDisplayPoint is in absolute screen coordinates. " destinationForm _ aDisplayMedium. clippingRectangle _ clipRectangle. rule _ ruleInteger. mask _ aForm. compositionRectangle moveTo: aDisplayPoint. self setScanner. self displayLines! 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." self "Assumes offset has been set!!!!!!!!!!" displayOn: aDisplayMedium at: (offset + (displayTransformation applyTo: relativePoint) - alignmentPoint) rounded clippingBox: clipRectangle rule: ruleInteger mask: aForm.! ! !TextCompositor methodsFor: 'display box access'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^offset extent: compositionRectangle extent! computeBoundingBox "Answer the minimum enclosing rectangle around the composed test of the paragraph." ^offset extent: compositionRectangle extent! ! !TextCompositor methodsFor: 'composition'! compositionRectangle: compositionRect text: aText style: aTextStyle offset: aPoint outputMedium: aSymbol "Set the initial values in the TextCompositor." compositionRectangle _ compositionRect copy. text _ aText. textStyle _ aTextStyle. firstIndent _ textStyle firstIndent. restIndent _ textStyle restIndent. rightIndent _ textStyle rightIndent. marginTabsLevel _ 0. outputMedium _ aSymbol. rule _ DefaultRule. mask _ DefaultMask. destinationForm _ Display. clippingRectangle _ destinationForm boundingBox. offset _ aPoint. textSize _ text size. self newLines. self setScanner! recomposeIn: compositionRect clippingBox: clippingRect "Set the composition rectangle for the receiver so that the lines wrap within the rectangle, compositionRect, and the display of the text is clipped by the rectangle, clippingRect." self compositionRectangle: compositionRect copy text: text style: textStyle offset: offset outputMedium: #Display. self adjustCompositionRectangle. clippingRectangle _ clippingRect copy! update: start to: stop withSize: size "Update the receiver after a replacement has occurred in the text starting at character index start, stopping at character index stop with a text whose size is size. The main composition algorithm is in this method. See the class comment." | delta newStop i j iNext lineStart nextStart nc | textSize _ text size. textSize = 0 ifTrue: [self clearRestLinesFrom: 1. lines at: 1 put: 1. nextChar _ 1. lastLine _ 0. ^self characterBlockForIndex: 1]. i _ self startingLineAfterReplacingAt: start. delta _ size - (stop - start + 1). delta = 0 ifFalse: [self updateLinesBelow: i at: start delta: delta]. newStop _ start + size. (start > nextChar and: [nextChar < (textSize + 1)]) "below bottom" ifTrue: [^self characterBlockForIndex: newStop]. newStop < (lines at: 1) ifTrue: [^nil]. "above top" scanner initializeFromCompositor: self stop: newStop. iNext _ lines at: i. [i <= lineLength] whileTrue: [((lineStart _ lines at: i) == nil or: [lineStart = nextChar "extra line scanning" or: [lineStart = iNext "only first line scanning"]]) ifFalse: [iNext < lineStart ifTrue: [j _ i. nextStart _ iNext. [j < lineLength and: [(nextStart _ scanner nextLineStart: nextStart line: j in: self) <= lineStart]] whileTrue: [j _ j + 1]. j > i ifTrue: "move down" [self moveLines: i to: j. (nc _ lines at: lineLength + 1) ~~ nil ifTrue: [nextChar _ nc]]] ifFalse: [iNext >= newStop ifTrue: "can be moved up, only after scanning through the stopIndex because of getting the stopBox." [j _ i. [(j _ j +1) <= lineLength and: [j > i and: [(nextStart _ lines at: j) ~~ nil and: [iNext >= nextStart]]]] whileTrue: [iNext = nextStart ifTrue: "move up" [self moveLines: j to: i. nextChar = (textSize +1) ifTrue: "end of text" [self updateLastLine. ^scanner stopBox]. iNext _ nextChar. i _ lineLength +1 - (j - i) "skip moved lines"] ]]]]. lines at: i put: iNext. iNext _ scanner displayOneLine: i start: iNext in: self. iNext = (textSize + 1) ifTrue: "end of text" [self clearRestLinesFrom: i + 1. nextChar _ iNext. (lines at: i) = iNext ifFalse: [lines at: i + 1 put: iNext]. self updateLastLine. lastLine = 0 ifTrue: [self setTopPosition: ((lines at: 1) - 1 max: 1)]. ^scanner stopBox]. i _ i + 1. (i < lineLength and: [(lines at: i) = iNext and: [(lines at: i + 1) ~= iNext and: [newStop <= iNext]]]) ifTrue: "encountered the right lines entry, no more scanning" [self updateLastLine. ^scanner stopBox] ]. "scanned the whole lines" nextChar _ iNext. lines at: i put: iNext. self updateLastLine. iNext < newStop ifTrue: "the stop position is below bottom" [^self characterBlockForIndex: newStop]. ^scanner stopBox! ! !TextCompositor methodsFor: 'character location'! characterBlockAtPoint: aPoint "Answer a CharacterBlock for characters in the text at point aPoint. It is assumed that aPoint has been transformed into coordinates appropriate to the receiver's destinationForm rectangle and the compositionRectangle." ^TextCharacterBlockScanner new characterBlockAtPoint: aPoint in: self! characterBlockForIndex: targetIndex "Answer a CharacterBlock for character in the text at targetIndex. The coordinates in the CharacterBlock will be appropriate to the receiver's destinationForm rectangle and the compositionRectangle." ^TextCharacterBlockScanner new characterBlockForIndex: targetIndex in: self! ! !TextCompositor methodsFor: 'selecting'! crIsLast "Answer true if the last character in the displayed text is cr." (textSize > 0 and: [nextChar > 1 and: [(text at: nextChar - 1) = $ ]]) ifTrue: [^true]. ^false! displayCaretAt: aPoint "Display CaretForm located at aPoint with default settings for rule and halftone." Cursor caret displayOn: destinationForm at: aPoint clippingBox: clippingRectangle rule: Form reverse mask: Form black! displayCaretForBlock: aCharacterBlock "Show caret at proper place for aCharacterBlock" self displayCaretAt: (aCharacterBlock topLeft + (0@textStyle baseline))! dyForPoint: pt "See if pt is above or below clippingRectangle, return scroll amount" | dy dc | self updateCharsPerLine. ((dy _ pt y - clippingRectangle top) < 0 and: [(dc _ 1 - (lines at: 1)) < 0]) ifTrue: [dy _ dy // textStyle lineGrid * charsPerLine. ^(dy max: dc) - charsPerLine]. ((dy _ pt y - clippingRectangle bottom) > 0 and: [(dc _ textSize + 1 - nextChar) > 0]) ifTrue: [dy _ dy // textStyle lineGrid * charsPerLine. ^(dy min: dc) + charsPerLine]. ^0! mouseSelect: previousStartBlock to: previousStopBlock "Answer with an Array of two CharacterBlocks that represent the text selection that the user makes. Allow for scrolling to extend selections." | pivotBlock startBlock stopBlock showingCaret dy pt okToScroll scrollDelay word | startBlock _ stopBlock _ pivotBlock _ self characterBlockAtPoint: Sensor cursorPoint. self displayCaretForBlock: pivotBlock. showingCaret _ true. okToScroll _ true. scrollDelay _ Delay forMilliseconds: 250. [Sensor redButtonPressed] whileTrue: [ pt _ Sensor cursorPoint. (okToScroll and: [(dy _ self dyForPoint: pt) ~= 0]) ifTrue: [ [okToScroll _ false. scrollDelay wait. okToScroll _ true] forkAt: Processor userInterruptPriority. showingCaret ifTrue: [ self displayCaretForBlock: pivotBlock. showingCaret _ false] ifFalse: [self reverseFrom: startBlock to: pivotBlock]. self scrollBy: dy. pt _ dy < 0 ifTrue: [clippingRectangle topLeft] ifFalse: [clippingRectangle bottomRight]. pivotBlock _ self characterBlockForIndex: pivotBlock stringIndex. startBlock _ pivotBlock ]. stopBlock _ self characterBlockAtPoint: pt. stopBlock = startBlock ifFalse: [ showingCaret ifTrue: [ self displayCaretForBlock: pivotBlock. showingCaret _ false]. self reverseFrom: startBlock to: stopBlock. startBlock _ stopBlock] ]. (showingCaret not and: [pivotBlock = stopBlock]) ifTrue: [self displayCaretForBlock: pivotBlock]. scrollDelay disable. (previousStartBlock = previousStopBlock and: [pivotBlock = stopBlock and: [stopBlock = previousStopBlock]]) ifTrue: "select a word or bracketed range" [word _ self selectWord: pivotBlock stringIndex. word first = word last ifFalse: [self displayCaretForBlock: pivotBlock. pivotBlock _ self characterBlockForIndex: word first. stopBlock _ self characterBlockForIndex: word last. self reverseFrom: pivotBlock to: stopBlock]]. stopBlock < pivotBlock ifTrue: [^Array with: stopBlock with: pivotBlock] ifFalse: [^Array with: pivotBlock with: stopBlock]! reverseFrom: characterBlock1 to: characterBlock2 "Reverse area between the two character blocks given as arguments." | start stop | characterBlock1 = characterBlock2 ifTrue: [^self]. characterBlock1 < characterBlock2 ifTrue: [start _ characterBlock1. stop _ characterBlock2] ifFalse: [start _ characterBlock2. stop _ characterBlock1]. start top = stop top ifTrue: [ ^self reverseRectangle: (start origin corner: stop bottomLeft)]. self reverseRectangle: (start origin corner: compositionRectangle right @ start bottom). self reverseRectangle: (compositionRectangle left@start bottom corner: compositionRectangle right@stop top). self reverseRectangle: (compositionRectangle left@stop top corner: stop bottomLeft).! reverseRectangle: aRectangle "Highlight the part of aRectangle which is visible" | rect | rect _ aRectangle intersect: self visibleRectangle. destinationForm fill: rect rule: Form reverse mask: mask.! selectWord: stringIndex "Select delimited text or word--the result of double-clicking." | openDelimiter closeDelimiter direction match level leftDelimiters rightDelimiters string here hereChar start stop | string _ text string. here _ stringIndex. (here between: 2 and: string size) ifFalse: ["if at beginning or end, select entire string" ^ 1 to: string size + 1]. leftDelimiters _ '([{<''" '. rightDelimiters _ ')]}>''" '. openDelimiter _ string at: here - 1. match _ leftDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on left -- match to the right" start _ here. direction _ 1. here _ here - 1. closeDelimiter _ rightDelimiters at: match] ifFalse: [openDelimiter _ string at: here. match _ rightDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on right -- match to the left" stop _ here - 1. direction _ -1. closeDelimiter _ leftDelimiters at: match] ifFalse: ["no delimiters -- select a token" direction _ -1]]. level _ 1. [level > 0 and: [direction > 0 ifTrue: [here < string size] ifFalse: [here > 1]]] whileTrue: [hereChar _ string at: (here _ here + direction). match = 0 ifTrue: ["token scan goes left, then right" hereChar tokenish ifTrue: [here = 1 ifTrue: [start _ 1. "go right if hit string start" direction _ 1]] ifFalse: [direction < 0 ifTrue: [start _ here + 1. "go right if hit non-token" direction _ 1] ifFalse: [level _ 0]]] ifFalse: ["bracket match just counts nesting level" hereChar = closeDelimiter ifTrue: [level _ level - 1"leaving nest"] ifFalse: [hereChar = openDelimiter ifTrue: [level _ level + 1"entering deeper nest"]]]]. level > 0 ifTrue: ["in case ran off string end" here _ here + direction]. direction > 0 ifTrue: [^ start to: here] ifFalse: [^ here + 1 to: stop + 1]! ! !TextCompositor methodsFor: 'scrolling'! scrollBy: charsToMove "Move the paragraph by the amount, charsToMove." | chars newIndex startIndex lineIndex preIndex first | chars _ charsToMove. chars _ chars max: self compositionRectangleDelta. chars abs >= (lineLength * self updateCharsPerLine) ifTrue: [startIndex _ (1 max: ((lines at: 1) + chars)) min: textSize. newIndex _ scanner scanLine: startIndex direction: #left. lineIndex _ 1. [newIndex < startIndex] whileTrue: [preIndex _ newIndex. newIndex _ scanner nextLineStart: newIndex line: lineIndex in: self]. first _ (newIndex = startIndex ifTrue: [newIndex] ifFalse: [preIndex]). lines at: 1 put: first. self displayLines. ^self]. chars < 0 ifTrue: "Moving down." [self scrollDownBy: chars negated] ifFalse: "Moving up." [self scrollUpBy: chars].! scrollDown: linesToMove "Scroll the paragraph down by the amount, linesToMove." | deltaLines tempLines delta realLinesToMove tempLinesPos stopIndex startIndex newIndex lineIndex first i | stopIndex _ first _ lines at: 1. (first = 1 or: [linesToMove <= 0]) ifTrue: [^self]. deltaLines _ linesToMove. lineLength <= 1 ifTrue: [deltaLines _ lineLength]. tempLines _ Array new: deltaLines. self updateCharsPerLine. delta _ charsPerLine * deltaLines. lineIndex _ 0. [stopIndex ~= 1 and: [lineIndex < deltaLines]] whileTrue: [startIndex _ (delta >= stopIndex ifTrue: [1] ifFalse: [stopIndex - delta]). newIndex _ scanner scanLine: startIndex direction: #left. [newIndex < stopIndex] whileTrue: [(lineIndex _ lineIndex + 1) > deltaLines ifTrue: [tempLines replaceFrom: 1 to: deltaLines - 1 with: tempLines startingAt: 2. lineIndex _ deltaLines]. tempLines at: lineIndex put: newIndex. newIndex _ scanner nextLineStart: newIndex line: lineIndex in: self]. stopIndex _ tempLines at: 1. lineIndex < deltaLines ifTrue: [i _ lineIndex + 1. deltaLines _ deltaLines - lineIndex. [(i _ i - 1) > 0] whileTrue: [tempLines at: i + deltaLines put: (tempLines at: i)]. lineIndex _ 0. delta _ charsPerLine * deltaLines. tempLinesPos _ i + deltaLines] ifFalse: [tempLinesPos _ 0]]. realLinesToMove _ linesToMove - tempLinesPos. self moveLines: 1 to: realLinesToMove + 1. startIndex _ tempLines at: tempLinesPos + 1. stopIndex _ first. lineIndex _ 0. [(lineIndex _ lineIndex + 1) <= lineLength and: [startIndex < stopIndex]] whileTrue: [lines at: lineIndex put: startIndex. startIndex _ scanner displayOneLine: lineIndex start: startIndex in: self]. lines at: lineIndex put: startIndex. self updateLastLine. nextChar _ lines at: lastLine + 1! scrollDownBy: charsToMove "Scroll the paragraph down by the amount, charsToMove." | characterIndex | textSize = 0 ifTrue: [^self]. characterIndex _ (charsToMove >= (lines at: 1) ifTrue: [1] ifFalse: [(lines at: 1) - charsToMove]). self setTopPosition: characterIndex! scrollUp: linesToMove "Scroll the paragraph up by the amount, linesToMove." | deltaLines startIndex lineIndex stopIndex | (textSize = 0 or: [linesToMove <= 0]) ifTrue: [^self]. deltaLines _ linesToMove. deltaLines >= lastLine ifTrue: [deltaLines _ lastLine - 1]. lineLength <= 1 ifTrue: [deltaLines _ lineLength]. self moveLines: deltaLines + 1 to: 1. startIndex _ nextChar. lineIndex _ lastLine - deltaLines. stopIndex _ textSize. [(lineIndex _ lineIndex + 1) <= lineLength and: [startIndex <= stopIndex]] whileTrue: [lines at: lineIndex put: startIndex. startIndex _ scanner displayOneLine: lineIndex start: startIndex in: self]. startIndex = nextChar ifFalse: [nextChar _ startIndex. lines at: lineIndex put: startIndex]. self updateLastLine! scrollUpBy: charsToMove "Scroll the paragraph up by the amount, charsToMove." | startIndex linesToMove newIndex | linesToMove _ 1. startIndex _ lines at: 1. charsToMove > (nextChar - startIndex) ifTrue: [newIndex _ ((lines at: 1) + charsToMove) min: textSize. newIndex _ scanner scanLine: newIndex direction: #left. lines at: 1 put: newIndex. self displayLines. ^self]. [charsToMove > ((lines at: linesToMove + 1) - startIndex) and: [linesToMove <= lastLine]] whileTrue: [linesToMove _ linesToMove + 1]. self scrollUp: linesToMove! scrollUpPosition: characterIndex "Scroll up until the charcter whose index is characterIndex is at the bottom of the view." | tempLines startIndex lineIndex stopIndex ring | tempLines _ Array new: lineLength. startIndex _ nextChar. lineIndex _ 0. stopIndex _ (characterIndex > textSize ifTrue: [textSize] ifFalse: [characterIndex]). ring _ false. [startIndex <= stopIndex] whileTrue: [(lineIndex _ lineIndex + 1) > lineLength ifTrue: [lineIndex _ 1. ring _ true]. tempLines at: lineIndex put: startIndex. startIndex _ scanner nextLineStart: startIndex line: lineIndex in: self]. lineIndex = lineLength ifTrue: [lineIndex _ 0. ring _ true]. ring ifTrue: [self clearVisibleRectangle. startIndex _ tempLines at: lineIndex + 1. lineIndex _ 0] ifFalse: [self moveLines: lineIndex + 1 to: 1. startIndex _ nextChar. lineIndex _ lineLength - lineIndex]. stopIndex _ textSize. [(lineIndex _ lineIndex + 1) <= lineLength and: [startIndex <= stopIndex]] whileTrue: [lines at: lineIndex put: startIndex. startIndex _ scanner displayOneLine: lineIndex start: startIndex in: self]. nextChar _ startIndex. lines at: lineIndex put: startIndex. self updateLastLine! setBottomPosition: characterIndex "Scroll until the charcter whose index is characterIndex is at the bottom of the view." | stopIndex first deltaLines tempLines delta lineIndex scroll startIndex newIndex tempNextChar i linesToMove tempLinesPos | stopIndex _ first _ (characterIndex > (textSize + 1) ifTrue: [textSize + 1] ifFalse: [characterIndex]). (characterIndex = 1 or: [lineLength = 0]) ifTrue: [^self]. deltaLines _ lineLength. tempLines _ Array new: deltaLines + 1. delta _ self updateCharsPerLine. lineIndex _ 0. scroll _ false. [scroll not and: [lineIndex < deltaLines]] whileTrue: [startIndex _ (delta >= stopIndex ifTrue: [1] ifFalse: [stopIndex - delta]). newIndex _ scanner scanLine: startIndex direction: #left. [newIndex < stopIndex] whileTrue: [((lineIndex _ lineIndex + 1) > deltaLines and: [newIndex ~= stopIndex]) ifTrue: [tempLines replaceFrom: 1 to: deltaLines - 1 with: tempLines startingAt: 2. lineIndex _ deltaLines]. tempLines at: lineIndex put: newIndex. newIndex _ scanner nextLineStart: newIndex line: lineIndex in: self. newIndex = nextChar ifTrue: [scroll _ true]]. stopIndex = first ifTrue: [tempNextChar _ newIndex]. stopIndex _ tempLines at: 1. lineIndex < deltaLines ifTrue: [i _ lineIndex + 1. deltaLines _ deltaLines - lineIndex. [(i _ i - 1) > 0] whileTrue: [tempLines at: i + deltaLines put: (tempLines at: i)]. lineIndex _ 0]]. i _ lineLength + 1. [(i _ i -1) > 0 and: [(tempLines at: i) ~= nextChar]] whileTrue: []. linesToMove _ lineLength + 1 - i min: lineLength. scroll ifTrue: [self moveLines: linesToMove + 1 to: 1. tempLinesPos _ lineLength - linesToMove + 1. startIndex _ tempLines at: tempLinesPos. lineIndex _ tempLinesPos - 1] ifFalse: [self clearVisibleRectangle. startIndex _ tempLines at: 1. lineIndex _ 0]. lines at: lineLength + 1 put: (nextChar _ tempNextChar). stopIndex _ textSize. [(lineIndex _ lineIndex + 1) <= lineLength and: [startIndex <= stopIndex]] whileTrue: [lines at: lineIndex put: startIndex. startIndex _ scanner displayOneLine: lineIndex start: startIndex in: self]. self updateLastLine! setTopPosition: characterIndex "Scroll until the charcter whose index is characterIndex is at the top of the view." | stopIndex newIndex startIndex preIndex first lineIndex | stopIndex _ lines at: 1. (characterIndex >= stopIndex and: [characterIndex < nextChar]) ifTrue: [^self]. characterIndex >= nextChar ifTrue: [stopIndex _ textSize]. newIndex _ scanner scanLine: characterIndex direction: #left. [newIndex < characterIndex] whileTrue: [preIndex _ newIndex. newIndex _ scanner nextLineStart: newIndex line: 1 in: self]. startIndex _ first _ (newIndex = characterIndex ifTrue: [newIndex] ifFalse: [preIndex]). lineIndex _ 0. [(lineIndex _ lineIndex + 1) <= lineLength and: [startIndex < stopIndex]] whileTrue: [startIndex _ scanner nextLineStart: startIndex line: lineIndex in: self]. startIndex = stopIndex ifTrue: [self moveLines: 1 to: lineIndex] ifFalse: [self clearVisibleRectangle. stopIndex _ textSize. lines at: lineIndex put: startIndex "extra line"]. lineIndex _ 0. startIndex _ first. [(lineIndex _ lineIndex + 1) <= lineLength and: [startIndex < stopIndex]] whileTrue: [lines at: lineIndex put: startIndex. startIndex _ scanner displayOneLine: lineIndex start: startIndex in: self]. lines at: lineIndex put: startIndex. self updateLastLine. nextChar _ lines at: lastLine + 1! ! !TextCompositor methodsFor: 'alignment'! centered "Set the alignment for the style with which the receiver displays its text so that text is centered in the composition rectangle." textStyle alignment: Centered.! justified "Set the alignment for the style with which the receiver displays its text so that the characters in each of text end on an even border in the composition rectangle." textStyle alignment: Justified.! leftFlush "Set the alignment for the style with which the receiver displays its text so that the characters in each of text begin on an even border in the composition rectangle. This is also known as ragged-right." textStyle alignment: LeftFlush.! rightFlush "Set the alignment for the style with which the receiver displays its text so that the characters in each of text end on an even border in the composition rectangle but the beginning of each line does not (ragged-left)." textStyle alignment: RightFlush! toggleAlignment "Set the alignment for the style with which the receiver displays its text so that it moves from centered to justified to leftFlush to rightFlush and back to centered again." textStyle alignment: textStyle alignment + 1.! ! !TextCompositor methodsFor: 'tab and margins'! clearIndents "Reset all the indention settings to be 0." self firstIndent: 0. self restIndent: 0. self rightIndent: 0! deltaMarginTabsLevel: anInteger "Delta the depth of 'nesting' for this paragraph -- an index into the marginTabsArray in the textStyle." self marginTabsLevel: anInteger + marginTabsLevel.! firstIndent "Answer the horizontal indenting of the first line of a paragraph in the style of the receiver." ^firstIndent! firstIndent: anInteger "Set the horizontal indenting of the first line of a paragraph in the style of the receiver to be anInteger." firstIndent _ (anInteger max: 0) min: (compositionRectangle width - DefaultSpace - rightIndent)! leftMarginForCompositionForLine: lineIndex "Build the left margin for composition of a line. Depends upon marginTabsLevel and the indent." | scale | scale _ 1. lineIndex = 1 ifTrue: [^(firstIndent + (textStyle leftMarginTabAt: marginTabsLevel)) * scale] ifFalse: [^(restIndent + (textStyle leftMarginTabAt: marginTabsLevel)) * scale].! leftMarginForDisplayForLine: lineIndex "Build the left margin for display of a line. Depends upon leftMarginForComposition, compositionRectangle left, the outputMedium and the alignment." | pad scale line compositionScanner | scale _ 1. (textStyle alignment = LeftFlush or: [textStyle alignment = Justified]) ifTrue: [^((compositionRectangle left * scale) + (self leftMarginForCompositionForLine: lineIndex))]. "When called from character location code and entire string has been cut, there are no valid lines, hence following nil check." text size = 0 ifFalse: [compositionScanner _ CompositionScanner new in: self. line _ compositionScanner composeLine: lineIndex fromCharacterIndex: (lines at: lineIndex) inParagraph: self]. (lineIndex <= lineLength and: [line ~~ nil]) ifTrue: [pad _ line paddingWidth] ifFalse: [pad _ compositionRectangle width - firstIndent - rightIndent]. textStyle alignment = Centered ifTrue: [^((compositionRectangle left * scale) + (self leftMarginForCompositionForLine: lineIndex)) + (pad // 2)]. textStyle alignment = RightFlush ifTrue: [^((compositionRectangle left * scale) + (self leftMarginForCompositionForLine: lineIndex)) + pad]. self error: ['no such alignment']! marginTabsLevel "Answer the depth of 'nesting' for this paragraph -- an index into the marginTabsArray in the textStyle." ^marginTabsLevel! marginTabsLevel: anInteger "Set the depth of 'nesting' for this paragraph -- an index into the marginTabsArray in the textStyle." marginTabsLevel _ (anInteger max: 0) min: textStyle nestingDepth. "Check if we've nested so far that there is no room between the effective margins." [(self leftMarginForCompositionForLine: 1) >= (self rightMarginForComposition) and: [marginTabsLevel > 0]] whileTrue: [marginTabsLevel _ (marginTabsLevel - 1 max: 0)]. [(self leftMarginForCompositionForLine: 2) >= (self rightMarginForComposition) and: [marginTabsLevel > 0]] whileTrue: [marginTabsLevel _ (marginTabsLevel - 1 max: 0)]! restIndent "Answer the indent for all but the first line of a paragraph in the style of the receiver." ^restIndent! restIndent: anInteger "Set the indent for all but the first line of a paragraph in the style of the receiver to be anInteger." restIndent _ (anInteger max: 0) min: (compositionRectangle width - DefaultSpace - rightIndent)! rightIndent "Answer the right margin indent for the lines of a paragraph in the style of the receiver." ^rightIndent! rightIndent: anInteger "Set the right margin indent for the lines of a paragraph in the style of the receiver to be anInteger." | maxRightIndent | firstIndent > restIndent ifTrue: [maxRightIndent _ (compositionRectangle width- DefaultSpace - firstIndent) max: 1] ifFalse: [maxRightIndent _ (compositionRectangle width- DefaultSpace - restIndent) max: 1]. rightIndent _ anInteger min: maxRightIndent! rightMarginForComposition "Build the right margin for a line. Depends upon compositionRectangle width, marginTabsLevel, and right indent." | scale | scale _ 1. ^(compositionRectangle width - (textStyle rightMarginTabAt: marginTabsLevel) - rightIndent) * scale! rightMarginForDisplay "Build the right margin for a line. Depends upon compositionRectangle rightSide, marginTabsLevel, and right indent." | scale | scale _ 1. ^(compositionRectangle right - rightIndent - (textStyle rightMarginTabAt: marginTabsLevel)) * scale! ! !TextCompositor methodsFor: 'indicating'! flash "Complement twice the visible area in which the receiver displays." Display flash: self visibleRectangle! outline "Display a border around the visible area in which the receiver presents its text." clippingRectangle bottom <= compositionRectangle bottom ifTrue: [Display border: (clippingRectangle intersect: compositionRectangle) width: 2] ifFalse: [Display border: (clippingRectangle intersect: destinationForm boundingBox) width: 2].! ! !TextCompositor methodsFor: 'utilities'! clearVisibleRectangle "Display the area in which the receiver presents its text so that the area is all one tone--in this case, all white." destinationForm fill: self visibleRectangle rule: rule mask: Form white.! fit "Make the bounding rectangle of the receiver contain all the text without changing the width of the receiver's composition rectangle." [(self lineIndexOfTop: clippingRectangle top) = 1] whileFalse: [self scrollBy: charsPerLine]. clippingRectangle bottom: compositionRectangle bottom! gridWithLead: leadInteger "Set the line grid of the receiver's style for displaying text to the height of the first font in the receiver's style + the argument, leadInteger." textStyle gridForFont: (text emphasisAt: 1) withLead: leadInteger. "assumes only one font referred to by runs"! ! !TextCompositor methodsFor: 'line access'! lineAt: lineIndex "Return the textLineInterval for the specified line" | i start stop | i _ lineIndex. start _ lines at: i. [start == nil] whileTrue: [start _ lines at: (i _ i - 1)]. start = nextChar ifTrue: [self crIsLast ifTrue: [stop _ start] ifFalse: [stop _ start - 1. start _ lines at: i - 1]] ifFalse: [stop _ (lines at: i + 1) -1]. ^TextLineInterval start: start stop: stop internalSpaces: 0 paddingWidth: 0! lineIndexOfCharacterIndex: characterIndex "line index for a given characterIndex" | i lineIndex| i _ characterIndex. i <= (lines at: 1) ifTrue: [^1]. i > nextChar ifTrue: [i _ nextChar]. lineIndex _ 1. [(lines at: lineIndex) < i] whileTrue: [lineIndex _ lineIndex +1]. ^((lines at: lineIndex) = i) ifTrue: [lineIndex] ifFalse: [lineIndex -1]! lineIndexOfTop: top "line index at a given top y" ^(top - compositionRectangle top // textStyle lineGrid + 1 max: 1) min: lastLine! textAt: lineIndex "Return the text for the specified line (subclasses may override)" ^ text! topAtLineIndex: lineIndex "top y of given line" ^compositionRectangle top + (lineIndex - 1 * textStyle lineGrid)! ! !TextCompositor methodsFor: 'converting'! asForm "Answer a new Form made up of the bits that represent the receiver's displayable text." | aForm saveDestinationForm | aForm _ Form new extent: compositionRectangle extent. saveDestinationForm _ destinationForm. self displayOn: aForm at: 0 @ 0 clippingBox: aForm boundingBox rule: Form over mask: Form black. aForm offset: offset. destinationForm _ saveDestinationForm. ^aForm! asParagraph "Answer a Paragraph whose text and style are identical to that of the receiver." ^Paragraph withText: text style: textStyle copy! asString "Answer the string of characters of the receiver's text." ^text string! asText "Answer the receiver's text." ^text! ! !TextCompositor methodsFor: 'private'! adjustCompositionRectangle "Adjust the compositionRectangle height so that it fits lineLength lines." compositionRectangle _ compositionRectangle height: textStyle lineGrid * lineLength.! charsPerLine "Answer guess value, the number of characters per line." ^charsPerLine! clearRestLinesFrom: lineIndex | destY i linesLength | destY _ self topAtLineIndex: lineIndex. destinationForm white: (compositionRectangle left@destY corner: (compositionRectangle bottomRight)). i _ lineIndex. linesLength _ lines size. [i <= linesLength] whileTrue: [lines at: i put: nil. i _ i + 1]! composeForm "Cache the form for displaying the paragraph." form _ self asParagraph asForm! compositionRectangleDelta "A handy number -- mostly for scrolling" ^(lines at: 1) negated! displayLines "Redisplay the paragraph." | startIndex stopIndex lineIndex | lineIndex _ 1. stopIndex _ textSize _ text size. startIndex _ lines at: lineIndex. scanner initializeFromCompositor: self stop: stopIndex + 1. self clearVisibleRectangle. [startIndex <= stopIndex and: [lineIndex <= lineLength]] whileTrue: [startIndex _ scanner displayOneLine: lineIndex start: startIndex in: self. lines at: (lineIndex _ lineIndex + 1) put: startIndex]. [lineIndex <= lineLength] whileTrue: [lines at: (lineIndex _ lineIndex + 1) put: nil]. nextChar _ startIndex. self updateLastLine! moveLines: start to: stop "Move the paragraph such that line index start is set to line index stop." | delta linesToMove i firstClearLine linesToClear limit | (start = stop or: [lineLength <= 1]) ifTrue: [^self]. delta _ stop - start. linesToMove _ lines size - (start max: stop) + 1. delta > 0 ifTrue: "move down" [i _ start + linesToMove. [(i _ i - 1) >= start] whileTrue: [lines at: i + delta put: (lines at: i)]. firstClearLine _ start. linesToClear _ delta] ifFalse: "move up" [i _ start. limit _ start + linesToMove. [i < limit] whileTrue: [lines at: i + delta put: (lines at: i). i _ i + 1]. firstClearLine _ stop + linesToMove. linesToClear _ delta negated]. i _firstClearLine. limit _ firstClearLine + linesToClear. [i < limit] whileTrue: [lines at: i put: nil. i _ i + 1]. self displayMoveLines: start to: stop! newLines "Create a line table which maintains line start caracter indices." | newLineLengh start | newLineLengh _ compositionRectangle height // textStyle lineGrid. lineLength == nil ifTrue: [lines _ Array new: (newLineLengh + 1). lineLength _ newLineLengh. lines at: 1 put: 1. nextChar _ 1] ifFalse: [start _ lines at: 1. lines _ Array new: (newLineLengh + 1). lineLength _ newLineLengh. lines at: 1 put: start]! nextChar "Answer next character index in the displayed text." ^nextChar! removeFirstChars: numberOfChars "Remove a number of characters from the beginning of the receiver, adjusting the composition rectangle so the displayed text moves as little as possible. Special kludge for TextCollectorController." | delta scrollDelta | delta _ numberOfChars -1. scrollDelta _ self compositionRectangleDelta negated. delta > scrollDelta ifTrue: [delta _ scrollDelta. self clearVisibleRectangle]. self replaceFrom: 1 to: numberOfChars with: '' asText.! repositionAt: aPoint clippingBox: clippingBox compositionRectangle moveTo: aPoint. clippingRectangle _ clippingBox.! setScanner textStyle alignment = LeftFlush ifTrue: [scanner _ TextDisplayScanner new] ifFalse: [scanner _ TextAlignScanner new]. scanner setDisplayMediumFrom: self! setText: aText textStyle: aTextStyle offset: aPoint "Initialize the instance variables." text _ aText. textStyle _ aTextStyle. offset _ aPoint. form _ nil! startingLineAfterReplacingAt: startIndex "Return the line index at which recomposition must start after a replacement has occured at the character index startIndex" | lineIndex string start i char | lineIndex _ self lineIndexOfCharacterIndex: startIndex. lineIndex <= 1 ifTrue: [^lineIndex]. string _ text string. char _ string at: (start _ lines at: lineIndex) - 1. char == $ ifTrue: [^lineIndex]. i _ startIndex. [(i _ i - 1) >= start] whileTrue: [char _ string at: i. (char == $ or: [char == $ ]) ifTrue: [^lineIndex]]. ^lineIndex - 1! updateCharsPerLine "Compute guess value, the number of characters per line." charsPerLine _ ((nextChar - (lines at: 1)) asFloat / (lastLine max: 1) asFloat * 1 asFloat) rounded. ^charsPerLine max: 1! updateLastLine "Compute the number of lines in the displayed text." | i | nextChar = (textSize + 1) ifTrue: [i _ lines size. [(lines at: i) == nil] whileTrue: [i _ i - 1]. lastLine _ i - 1] ifFalse: [lastLine _ lineLength]! updateLinesBelow: lineIndex at: start delta: delta "Update start index in the lines after a replacement has occurred at character index, start with text size delta." | linesLength i oldSize pos | linesLength _ lineLength + 1. oldSize _ textSize - delta. ((start >= nextChar and: [nextChar ~= 1]) and: [nextChar < (oldSize + 1)]) ifTrue: [^self]. "below bottom, no update" i _ lineIndex. start < (lines at: 1) ifTrue: [i _ 0]. i _ i + 1. [i <= linesLength and: [(lines at: i) ~~ nil]] whileTrue: [(delta < 0 and: [delta abs > (lines at: i)]) ifTrue: [pos _ 1] ifFalse: [pos _ (lines at: i) + delta]. lines at: i put: pos. i _ i + 1]. nextChar _ nextChar + delta max: start! visibleRectangle ^ clippingRectangle intersect: destinationForm boundingBox! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextCompositor class instanceVariableNames: ''! !TextCompositor class methodsFor: 'instance creation'! initialize "TextCompositor initialize." DefaultCompositionRectangle _ 0@0 corner: 100@100.! new "Do not allow an uninitialized view. Create with text that has no characters." ^self withText: '' asText! withText: aText "Answer an instance of me with text set to aText and style set to the system's default text style." ^self withText: aText style: DefaultTextStyle copy! withText: aText style: aTextStyle "Answer an instance of me with text set to aText and style set to aTextStyle." ^super new compositionRectangle: DefaultCompositionRectangle text: aText style: aTextStyle offset: (0@0) outputMedium: #Display! withText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect | para | para _ super new compositionRectangle: compRect text: aText style: aTextStyle offset: (0@0) outputMedium: #Display. para clippingRectangle: clipRect. ^para! ! TextCompositor initialize! TextEditor subclass: #TextController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! TextController comment: 'This subclass of the paragraphEditor uses actionMenus for model control protocol. It also makes a stab (localMenuItem:) at the problem of distinguishing user control directed at the model from that directed at the view/controller. This controller is more tightly connected to its view (for example it asks it for its yellowButtonMenu), because the view is the current site for "pluggable" parameterization.'! !TextController methodsFor: 'menu messages'! accept (self textHasChanged and: [model changeRequestFrom: view]) ifFalse: [^view flash]. self controlTerminate. (view accept: self text from: self) ifTrue: [super accept] ifFalse: [view flash]. self controlInitialize! localMenuItem: selector ^ #(cut paste copySelection again undo cancel accept) includes: selector! ! !TextController methodsFor: 'editing'! insertAndSelect: aString at: anInteger self selectAt: anInteger. self deselect. self replaceSelectionWith: (' ' , aString) asText. self selectAndScroll! ! !TextController methodsFor: 'accessing'! paragraph ^ paragraph! textHasChanged ^ self text ~= initialText! ! !TextController methodsFor: 'control activity'! yellowButtonActivity | index menu selector | menu _ view yellowButtonMenu. menu == nil ifTrue: [view flash. super controlActivity] ifFalse: [index _ menu startUp. index ~= 0 ifTrue: [selector _ menu selectorAt: index. "editing to self, rest to model" (self localMenuItem: selector) ifTrue: [self perform: selector] ifFalse: [self controlTerminate. selector numArgs = 2 ifTrue: [model perform: selector with: self text with: self] ifFalse: [model perform: selector]. self controlInitialize]]]! ! !TextController methodsFor: 'composition'! wrappingBox: wrapRectangle clippingBox: clipRectangle | translation| clipRectangle extent = paragraph clippingRectangle extent ifTrue: [translation _ clipRectangle origin - paragraph clippingRectangle origin. paragraph clippingRectangle: clipRectangle. paragraph setCompositionRectangle: (paragraph compositionRectangle translateBy: translation)] ifFalse: [paragraph recomposeIn: wrapRectangle clippingBox: clipRectangle]! ! CompositionScanner subclass: #TextDisplayScanner instanceVariableNames: 'lineY runX displaying stop stopBox offsetX offsetY bitblt displayMedium ' classVariableNames: '' poolDictionaries: '' category: 'Interface-TextEditor'! TextDisplayScanner comment: 'I behave like both a CompositionScanner and a DisplayScanner. I scan and display text at the same time. Scanning is done for each line one-at-a-time. After scanning, I return a CharacterBlock which contains the stopBox (stopping) character index and location. If scanning doesn''t pass the stopping index, return nil. The location is given as (topLeft position extent: 0 @ lineGrid). I don''t have any justification function. This can be implemented in a subclass. Instance Variables: lineY Top of line currently being displayed or scanned. runX Left of the first character in the current run--allows for underlining or similar emphasis. displaying A switch for displaying or measuring. stop Index of new stopping character - 1. stopBox A CharacterBlock of the new stopping character. offsetX X position of compositionRectangle origin on the DisplayScreen. offsetY Y position of compositionRectangle origin on the DisplayScreen. bitblt Used to copy lineForm on the DisplayScreen or clear the lineForm. displayMedium a destination form that lineForm is copied on. '! !TextDisplayScanner methodsFor: 'initialize-release'! initializeFromCompositor: aCompositor stop: newStop self setTextStyleFrom: aCompositor. stop _ newStop - 1. stopBox _ nil! ! !TextDisplayScanner methodsFor: 'accessing'! stopBox "Answer the stopping CharacterBlock that specifies the location of the cursor." ^stopBox! ! !TextDisplayScanner methodsFor: 'stop conditions'! cr "Answer true. Set up values for the stopping CharacterBlock that specify the location of the cursor." displaying ifTrue: [self checkEmphasis. lastIndex = stop ifTrue: [stopBox _ CharacterBlock stringIndex: stop + 1 character: nil topLeft: (leftMargin + offsetX) @(lineY + textStyle lineGrid + offsetY) extent: 0 @ textStyle lineGrid]]. lastIndex _ lastIndex + 1. spaceX _ destX. ^true! crossedX "Answer true. Wrap around from last space to end of line." displaying ifTrue: [self checkEmphasis]. spaceCount > 0 ifTrue: [lastIndex _ spaceIndex + 1. destX _ spaceX. displaying ifTrue: [self clearLineFormAt: destX@lineY. (lastIndex - 1) = stop ifTrue: [stopBox _ CharacterBlock stringIndex: lastIndex character: nil topLeft: (leftMargin + offsetX) @(lineY + textStyle lineGrid + offsetY) extent: 0 @ textStyle lineGrid]]]. ^true! endOfRun "Answer true if scanning has reached the end of the paragraph. Otherwise set stop conditions (to install a new font) or set up values for the CharacterBlock." | runLength | displaying ifTrue: [self checkEmphasis]. lastIndex = text size ifTrue: [lastIndex = stop ifTrue: [stopBox _ CharacterBlock stringIndex: stop + 1 character: nil topLeft: (destX + offsetX)@(lineY + offsetY) extent: 0 @ textStyle lineGrid]. lastIndex _ lastIndex + 1. spaceX _ destX. ^true] ifFalse: [lastIndex < stop ifTrue: [runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). runStopIndex _ lastIndex + (runLength - 1). self setStopConditions. destY _ lineY + self fontAscentDelta. runX _ destX. runStopIndex > stop ifTrue: [runStopIndex _ stop]. ^false]. lastIndex = stop ifTrue: [stopBox _ CharacterBlock stringIndex: stop + 1 character: nil topLeft: (destX + offsetX)@(lineY + offsetY) extent: 0 @ textStyle lineGrid. runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). runStopIndex _ lastIndex + (runLength - 1). self setStopConditions. destY _ lineY + self fontAscentDelta. runX _ destX. ^false]. (displaying not or: [lastIndex > stop]) ifTrue: [runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). runStopIndex _ lastIndex + (runLength - 1). self setStopConditions. destY _ lineY + self fontAscentDelta. runX _ destX. ^false]].! ! !TextDisplayScanner methodsFor: 'scanning'! displayOneLine: lineIndex start: startIndex in: aCompositor "Display a line whose start caracter index and line index are startIndex, lineIndex and return the character index of start of the next line" | runLength | lastIndex _ startIndex. self setStopConditions. offsetX _ aCompositor compositionRectangle left. offsetY _ aCompositor topAtLineIndex: lineIndex. rightMargin _ aCompositor compositionRectangle width. runX _ spaceX _ destX _ leftMargin _ 0. lineY _ destY _ 0. destY _ lineY + self fontAscentDelta. runLength _ text runLengthFor: lastIndex. runStopIndex _ lastIndex + (runLength - 1). (lastIndex <= (stop + 1) and: [runStopIndex > stop]) ifTrue: [runStopIndex _ stop]. displaying _ true. spaceCount _ 0. self clearLineFormAt: 0@0. [self perform: (self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions displaying: displaying)] whileFalse: []. self copyLineFormOnDisplayMediumAt: offsetX @ offsetY. ^lastIndex! nextLineStart: startIndex line: lineIndex in: aCompositor "Return the character index of start of the next line." | runLength | lastIndex _ startIndex. self setStopConditions. rightMargin _ aCompositor compositionRectangle width. runX _ spaceX _ destX _ leftMargin _ 0. lineY _ destY _ offsetX _ offsetY _ 0. "These are not used" runLength _ text runLengthFor: lastIndex. runStopIndex _ lastIndex + (runLength - 1). spaceCount _ 0. displaying _ false. [self perform: (self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions displaying: displaying)] whileFalse: []. ^lastIndex! scanLine: startIndex direction: rightOrLeft "Return the character index of the rightOrLeft edge of the line." rightOrLeft == #left ifTrue: [^self scanLineLeft: startIndex]. rightOrLeft == #right ifTrue: [^self scanLineRight: startIndex]. self error: 'argument is not #right or #left'! scanLineLeft: startIndex "Return the character index of the left edge of the line." | sourceString stopIndex c | lastIndex _ startIndex - 1. sourceString _ text string. stopIndex _ 1. [lastIndex >= stopIndex] whileTrue: [c _ sourceString at: lastIndex. c == $ ifTrue: [^lastIndex + 1]. lastIndex _ lastIndex - 1]. ^lastIndex + 1! scanLineRight: startIndex "Return the character index of the right edge of the line." | sourceString stopIndex c | lastIndex _ startIndex. sourceString _ text string. stopIndex _ sourceString size. [lastIndex <= stopIndex] whileTrue: [c _ sourceString at: lastIndex. c == $ ifTrue: [^lastIndex]. lastIndex _ lastIndex + 1]. ^lastIndex! ! !TextDisplayScanner methodsFor: 'private'! checkEmphasis "Check any emphasis (underlining, italic, bold face) and synthesize font." | 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]! clearLineFormAt: aPoint bitblt destForm: destForm; sourceForm: nil; mask: Form white; destOrigin: aPoint; clipWidth: destForm width; clipHeight: destForm height. bitblt copyBits.! copyLineFormOnDisplayMediumAt: aPoint bitblt destForm: displayMedium; sourceForm: destForm; mask: nil; destOrigin: aPoint; clipWidth: displayMedium width; clipHeight: displayMedium height. bitblt copyBits.! 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! setDisplayMediumFrom: aCompositor destForm _ Form extent: aCompositor compositionRectangle width @ aCompositor textStyle lineGrid. halftoneForm _ aCompositor mask. outputMedium _ aCompositor outputMedium. displayMedium _ aCompositor destinationForm. self combinationRule: aCompositor rule. self clipRect: (0@0 extent: aCompositor compositionRectangle width @ aCompositor textStyle lineGrid). bitblt _ BitBlt new. bitblt sourceOrigin: 0@0; width: destForm width; height: destForm height; combinationRule: Form over. bitblt clipX: 0; clipY: 0! setTextStyleFrom: aCompositor text _ aCompositor text. textStyle _ aCompositor textStyle. sourceY _ 0! ! ParagraphEditor subclass: #TextEditor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-TextEditor'! TextEditor comment: ' I hold a TextCompositor instead of a Paragraph. After replacing text, I eliminate characterBlock scanning for getting startBlock and stopBlock. Because I receive a stopBlock from a TextCompositor, the startBlock''s characterIndex and topLeft position which are used for selection have not been changed even after replacing text. My Scroll bar behaves differently from my superclass''. The scroll frame represents the length of the document and the gray box occupies a region according to portion of character size visible in the compositionRectangle. The scroll amount is determined by size of characters to move.'! !TextEditor methodsFor: 'initialize-release'! changeCompositor: aCompositor "Install aCompositor as my instance variable." paragraph _ aCompositor. self resetState! ! !TextEditor methodsFor: 'scrolling'! scrollAbsolute | oldMarker delta newMarkerRegion oldCursorY cursorY offsetY | self changeCursor: Cursor marker. oldCursorY _ marker center y. self canScroll & sensor anyButtonPressed ifTrue: [[sensor anyButtonPressed] whileTrue: [oldMarker _ marker copy. cursorY _ sensor cursorPoint y. delta _ ((marker center y - cursorY) asFloat / scrollBar inside height asFloat * (paragraph textSize max: 1) asFloat) truncated. (oldCursorY - cursorY) * delta <= 0 ifTrue: [delta _ 0]. self scrollView: delta. oldCursorY _ cursorY. newMarkerRegion _ self computeMarkerRegion. offsetY _ (((paragraph lines at: 1) - 1) asFloat / (paragraph textSize max: 1) asFloat * scrollBar inside height asFloat) rounded min: scrollBar inside height - newMarkerRegion height. marker region: (marker left@(scrollBar inside top + offsetY) extent: newMarkerRegion corner). (oldMarker areasOutside: marker), (marker areasOutside: oldMarker) do: [:region | Display fill: region rule: Form reverse mask: Form gray]]. scrollBar display. self moveMarker]! scrollAmount | lineLength | lineLength _ paragraph lineLength. lineLength <= 1 ifTrue: [^lineLength]. ^lineLength - 1 min: (((sensor cursorPoint y - scrollBar inside top) asFloat / paragraph lineGrid asFloat) truncated max: 1)! scrollBy: charsToMove "Move the paragraph by the amount, charsToMove, and reset the text selection." self deselect. paragraph scrollBy: charsToMove. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. self select! scrollDown self changeCursor: Cursor down. sensor anyButtonPressed ifTrue: [self canScroll ifTrue: [self scrollViewDown. self updateMarker]]. sensor waitNoButton! scrollToTop "Scroll so that the paragraph is at the top of the view." self scrollView: (paragraph lines at: 1)! scrollUp self changeCursor: Cursor up. sensor anyButtonPressed ifTrue: [self canScroll ifTrue: [self scrollViewUp. self updateMarker]]. sensor waitNoButton! scrollView: anInteger | maximumAmount minimumAmount amount | maximumAmount _ (paragraph lines at: 1) max: 0. minimumAmount _ (paragraph lines at: 1) - paragraph textSize - 1 min: 0. amount _ (anInteger min: maximumAmount) max: minimumAmount. amount ~= 0 ifTrue: [self deselect. self scrollBy: amount negated. self select].! scrollViewDown "Scroll the receiver's view down the default amount." self deselect. paragraph scrollDown: self scrollAmount. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. self select! scrollViewUp "Scroll the receiver's view up the default amount." self deselect. paragraph scrollUp: self scrollAmount. startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex. self select! ! !TextEditor methodsFor: 'marker adjustment'! computeMarkerRegion "Answer the rectangular area in which the gray area of the scroll bar should be displayed." paragraph textSize = 0 ifTrue: [^0@0 extent: 10 @ scrollBar inside height] ifFalse: [^0@0 extent: 10 @ ((((paragraph nextChar - (paragraph lines at: 1)) asFloat / (paragraph textSize max: 1) asFloat * scrollBar inside height asFloat) rounded min: scrollBar inside height) max: 10)]! markerDelta ^marker top - scrollBar inside top - (((paragraph lines at: 1) - 1) asFloat / (paragraph textSize max: 1) asFloat * scrollBar inside height asFloat) rounded! updateMarker "Redisplay the marker in the scrollbar." | newMarkerRegion | newMarkerRegion _ self computeMarkerRegion. newMarkerRegion extent ~= marker region extent ifTrue: [self markerRegion: newMarkerRegion. self moveMarker]. self markerDelta = 0 ifFalse: [self moveMarker]! ! !TextEditor methodsFor: 'displaying'! display "Show the paragraph of the receiver on the display screen." | selectionState | selectionState _ selectionShowing. self deselect. paragraph displayOn: Display. self recomputeSelection. selectionState ifTrue: [self select]! ! !TextEditor methodsFor: 'menu messages'! cancel "Restore the text of the paragraph to be the text saved since initialization or the last accept." self controlTerminate. UndoSelection _ paragraph text. view clearInside. paragraph resetState. self changeCompositor: (paragraph text: initialText). paragraph displayOn: Display. self scrollToTop. self controlInitialize! ! !TextEditor methodsFor: 'editing'! changeEmphasis: characterStream key: aChar "Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change." | oldCode newCode | oldCode _ paragraph text emphasisAt: startBlock stringIndex. ((newCode _ FontKeys indexOf: (aChar asciiValue)) = 0) ifTrue: [newCode _ self emphasisDefault: oldCode keyedTo: aChar]. (((paragraph textStyle isFontUnderlined: oldCode) and: [aChar ~= CtrlShiftMinus "--unUnderline"]) and: [aChar ~= Ctrlx "clear emphasis"]) ifTrue: ["If font being replaced was underlined, use underlined version of new font, unless unUnderline has just been struck" newCode _ paragraph textStyle underlinedFontFor: newCode]. startBlock stringIndex = stopBlock stringIndex ifTrue: "only change emphasisHere while typing" [emphasisHere _ newCode. self select. ^true]. self replaceSelectionWith: (Text string: self selection asString emphasis: (newCode max: 1)). startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. self closeTypeIn. self select. ^true! ! !TextEditor methodsFor: 'selecting'! find: aString | index | index _ paragraph text findString: aString startingAt: stopBlock stringIndex. index = 0 ifTrue: [^false]. startBlock _ startBlock stringIndex: index. stopBlock _ stopBlock stringIndex: index + aString size. ^true! reverseSelection "Reverse the valence of the current selection highlighting." selectionShowing _ selectionShowing not. startBlock = stopBlock ifTrue: [paragraph displayCaretAt: stopBlock topLeft + (0 @ paragraph textStyle baseline)] ifFalse: [paragraph reverseFrom: startBlock to: stopBlock]! selectAndScroll "Scroll until the selection is in the view and then highlight it." | first start stop | first _ paragraph lines at: 1. start _ startBlock stringIndex. stop _ stopBlock stringIndex. (stop between: first and: paragraph nextChar) ifTrue: [(paragraph crIsLast and: [paragraph lastLine = paragraph lineLength and: [stop = paragraph nextChar and: [paragraph textSize + 1 >= paragraph nextChar]]]) ifTrue: [paragraph scrollUp: 1. startBlock _ paragraph characterBlockForIndex: start. stopBlock _ paragraph characterBlockForIndex: stop]. (start >= first and: [startBlock top < paragraph compositionRectangle top]) ifTrue: [startBlock _ paragraph characterBlockForIndex: start] ] ifFalse: [stop > paragraph nextChar ifTrue: [start <= first ifTrue: [paragraph setTopPosition: start] ifFalse: [paragraph setBottomPosition: stop]] ifFalse: [paragraph setTopPosition: start]. startBlock _ paragraph characterBlockForIndex: start. stopBlock _ paragraph characterBlockForIndex: stop]. self select! selectAndScrollUp "Scroll up until the selection is in the view and then highlight it." | first start stop | first _ paragraph lines at: 1. start _ startBlock stringIndex. stop _ stopBlock stringIndex. (stop between: first and: paragraph nextChar) ifTrue: [(paragraph crIsLast and: [paragraph lastLine = paragraph lineLength and: [stop = paragraph nextChar and: [paragraph textSize + 1 >= paragraph nextChar]]]) ifTrue: [paragraph scrollUp: 1. startBlock _ paragraph characterBlockForIndex: start. stopBlock _ paragraph characterBlockForIndex: stop]. (start >= first and: [startBlock top < paragraph compositionRectangle top]) ifTrue: [startBlock _ paragraph characterBlockForIndex: start] ] ifFalse: [paragraph scrollUpPosition: stop. startBlock _ paragraph characterBlockForIndex: start. stopBlock _ paragraph characterBlockForIndex: stop]. self select! ! !TextEditor methodsFor: 'updating'! replaceSelectionWith: aText beginTypeInBlock == nil ifTrue: [UndoSelection _ self selection]. stopBlock _ paragraph replaceFrom: startBlock stringIndex to: stopBlock stringIndex - 1 with: aText. stopBlock == nil ifTrue: [startBlock _ paragraph characterBlockForIndex: startBlock stringIndex. stopBlock _ paragraph characterBlockForIndex: startBlock stringIndex + aText size]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextEditor class instanceVariableNames: ''! !TextEditor class methodsFor: 'instance creation'! new "Answer a new instance of me with a null Paragraph to be edited." | aTextCompositor | aTextCompositor _ TextCompositor new. aTextCompositor text: '' asText. ^ self newCompositor: aTextCompositor! newCompositor: aCompositor "Answer an instance of me with aParagraph as the text to be edited. " | aTextEditor | aTextEditor _ super new. aTextEditor changeCompositor: aCompositor. ^aTextEditor! ! StringHolder subclass: #TextHolder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! TextHolder comment: 'I am like a StringHolder, except I keep my contents as a text, not as a string.'! !TextHolder methodsFor: 'accessing'! contents: aStringOrText "Set aStringOrText to be the contents of the receiver." contents _ aStringOrText! ! Interval subclass: #TextLineInterval instanceVariableNames: 'internalSpaces paddingWidth ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! TextLineInterval comment: 'Class TextLineInterval represents the starting and stopping points in a String of a composed line. The step is always 1. Instance Variables: internalSpaces number of spaces in the line paddingWidth amount to be added to the font'! !TextLineInterval methodsFor: 'accessing'! internalSpaces "Answer the number of spaces in the line." ^internalSpaces! internalSpaces: spacesInteger "Set the number of spaces in the line to be spacesInteger." internalSpaces _ spacesInteger! paddingWidth "Answer the amount of space to be added to the font." ^paddingWidth! paddingWidth: padWidthInteger "Set the amount of space to be added to the font to be padWidthInteger." paddingWidth _ padWidthInteger! stop: stopInteger "Set the stopping point in the string of the line to be stopInteger." stop _ stopInteger! ! !TextLineInterval methodsFor: 'comparing'! = line "Answer whether the species of the receiver and the species of the argument, line, are equal, and if both the receiver and the argument have equal starts, stops, spaces in a line and font width." self species = line species ifTrue: [^((start = line first and: [stop = line last]) and: [internalSpaces = line internalSpaces]) and: [paddingWidth = line paddingWidth]] ifFalse: [^false]! ! !TextLineInterval methodsFor: 'scanning'! justifiedPadFor: spaceIndex "Compute the width of pad for a given space in a line of justified text." | pad | internalSpaces = 0 ifTrue: [^0]. pad _ paddingWidth // internalSpaces. spaceIndex <= (paddingWidth \\ internalSpaces) ifTrue: [^pad + 1] ifFalse: [^pad]! justifiedTabDeltaFor: spaceIndex "Compute the delta for a tab in a line of justified text. So tab falls somewhere plausible when line is justified." | pad extraPad | internalSpaces = 0 ifTrue: [^0]. pad _ paddingWidth // internalSpaces. extraPad _ paddingWidth \\ internalSpaces. spaceIndex <= extraPad ifTrue: [^spaceIndex * (pad + 1)] ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! ! !TextLineInterval methodsFor: 'updating'! slide: delta "Change the starting and stopping points of the line by delta." start _ start + delta. stop _ stop + delta! ! !TextLineInterval methodsFor: 'copying'! deepCopy "Answer a copy of the receiver with its own copy of each instance variable." ^TextLineInterval start: start stop: stop internalSpaces: internalSpaces paddingWidth: paddingWidth! ! !TextLineInterval methodsFor: 'private'! internalSpaces: spacesInteger paddingWidth: padWidthInteger "Initialize the instance variables." internalSpaces _ spacesInteger. paddingWidth _ padWidthInteger! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextLineInterval class instanceVariableNames: ''! !TextLineInterval class methodsFor: 'instance creation'! start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger "Answer an instance of the receiver with the arguments as the start, stop points, number of spaces in the line, and width of the padding." | newSelf | newSelf _ super from: startInteger to: stopInteger by: 1. ^newSelf internalSpaces: spacesInteger paddingWidth: padWidthInteger! ! Paragraph subclass: #TextList instanceVariableNames: 'list ' classVariableNames: 'ListStyle ' poolDictionaries: '' category: 'Interface-Lists'! TextList comment: 'TextList is a subclass of Paragraph which is a more efficient representation of lists. Since it displays a list of items, it does not try to produce a single string with CRs, but instead simply makes up TextLineIntervals on the fly as needed by the view. The major savings come from not needing to make up a new string for the whole list and not having to measure the lines, since it is assumed that if they are too long, they will simply be clipped rather than wrapping to the next line.'! !TextList methodsFor: 'initialization'! compositionRectangle: compositionRect list: aList style: aTextStyle offset: aPoint outputMedium: aSymbol "Initialize the instance variables." compositionRectangle _ compositionRect copy. list _ aList. text _ Text new. textStyle _ aTextStyle. firstIndent _ textStyle firstIndent. restIndent _ textStyle restIndent. rightIndent _ textStyle rightIndent. marginTabsLevel _ 0. outputMedium _ aSymbol. rule _ DefaultRule. mask _ DefaultMask. destinationForm _ Display. clippingRectangle _ destinationForm boundingBox. offset _ aPoint. lastLine _ list size. compositionRectangle height: textStyle lineGrid * lastLine! ! !TextList methodsFor: 'line access'! lineAt: lineIndex ^ TextLineInterval start: 1 stop: (list at: lineIndex) size internalSpaces: 1 paddingWidth: 0! textAt: lineIndex ^ (list at: lineIndex) asText! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextList class instanceVariableNames: ''! !TextList class methodsFor: 'instance creation'! onList: aListArray "Answer an instance of the receiver with text set to the items in the argument aListArray." ^self basicNew compositionRectangle: DefaultCompositionRectangle list: aListArray style: ListStyle offset: 0@0 outputMedium: #Display! ! !TextList class methodsFor: 'class initialization'! initialize "TextList initialize." ListStyle _ DefaultTextStyle copy. ListStyle gridForFont: 1 withLead: 0! ! TextList initialize! Object subclass: #TextStyle instanceVariableNames: 'fontArray lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray outputMedium ' classVariableNames: 'TextStyles ' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! TextStyle comment: 'Class TextStyle is the repository of information which may be shared by a number of paragraphs. It is used for both display and printing operations. Instance Variables: fontArray A collection of fonts available to the paragraph. These may be either StrikeFonts or PressFonts. The emphasis portion of a Text returns a value for indexing the font. lineGrid The amount to be added to the top of a line to find the top of the next line. Will frequently be the greatest height in the fonts in fontArray. baseline The amount to be added to the top of a line to find the baseline of the line. The baseline is the point from which the ascent of a font should rise. alignment Indicates the mode for first level placement from the margins -- 0=left flush, 1=centered, 2=right flush, 3=justified. firstIndent Amount to inset from the left margin for the first line of a paragraph. Initial value for paragraph associated with this TextStyle. restIndent Amount to inset from the left margin for all but the first line of a paragraph. Initial value for paragraph associated with this TextStyle. rightIndent Amount to inset from the right margin for all the lines of the paragraph. Initial value for paragraph associated with this TextStyle. tabsArray Tab stops. Values are relative to the left margin of the paragraph. marginTabsArray Each value in the array is a tuple indicating an inset from the left and right margin of this paragraph. Allows for inset paragraphs. outputMedium Currently only #Display. Allows for use of TextStyle in both display and printing mode. Class Variable: TextStyles containing the names (dictionary keys) and available text styles (dictionary values) '! !TextStyle methodsFor: 'accessing'! alignment "Answer the code for the current setting of the alignment." ^alignment! alignment: anInteger "Set the current setting of the alignment to be anInteger-- 0=left flush, 1=centered, 2=right flush, 3=justified." alignment _ anInteger \\ (Justified + 1)! baseline "Answer the distance from the top of the line to the bottom of most of the characters (by convention, bottom of A)." ^baseline! baseline: anInteger "Set the distance from the top of the line to the bottom of most of the characters." baseline _ anInteger! defaultFont "Answer the first font in the font family." ^self fontAt: 1! descent "Answer the distance from the bottom of the line to the bottom of most of the characters (by convention, bottom of A)." ^self lineGrid - self baseline! firstIndent "Answer the horizontal indenting of the first line of a paragraph in the style of the receiver." ^firstIndent! firstIndent: anInteger "Set the horizontal indenting of the first line of a paragraph in the style of the receiver to be anInteger." firstIndent _ anInteger! fontAt: index "Answer the font indexed as index in the array of fonts. Provide an error notification if there is no font at this index." "This is should be treated as a private message because no object outside TextStyle should depend on the representation of the font family. " | fontIndex | fontIndex _ index. fontIndex > fontArray size ifTrue: [fontIndex _ fontArray size]. fontIndex < 0 ifTrue: [fontIndex _ 1]. ((fontArray at: fontIndex) isMemberOf: StrikeFont) ifTrue: [^fontArray at: fontIndex]. ((fontArray at: 1) isMemberOf: StrikeFont) ifTrue: [^fontArray at: 1]. self error: 'No valid fonts in font array'! fontAt: index put: font "Store the argument font as the index'th font." fontArray at: index put: font! lineGrid "Answer the relative space between lines of a paragraph in the style of the receiver." ^lineGrid! lineGrid: anInteger "Set the relative space between lines of a paragraph in the style of the receiver to be anInteger." lineGrid _ anInteger! nestingDepth "Answer the depth of indenting paragraphs when using this text style." ^ marginTabsArray size! outputMedium "Answer the outputMedium for this style." ^outputMedium! outputMedium: aSymbol "Set the outputMedium for this style -- currently only Display." outputMedium _ aSymbol. outputMedium = #Display ifTrue: [lineGrid _ DefaultLineGrid. baseline _ DefaultBaseline] ifFalse: [self outputMedium: #Display].! restIndent "Answer the indent for all but the first line of a paragraph in the style of the receiver." ^restIndent! restIndent: anInteger "Set the indent for all but the first line of a paragraph in the style of the receiver to be anInteger." restIndent _ anInteger! rightIndent "Answer the right margin indent for the lines of a paragraph in the style of the receiver." ^rightIndent! rightIndent: anInteger "Answer the right margin indent for the lines of a paragraph in the style of the receiver to be anInteger." rightIndent _ anInteger! ! !TextStyle methodsFor: 'tabs and margins'! clearIndents "Reset all the margin settings to be 0." self firstIndent: 0. self restIndent: 0. self rightIndent: 0! leftMarginTabAt: marginIndex "Set the 'nesting' level of left margin indents of the paragraph in the style of the receiver to be marginIndex." "The marginTabsArray is an Array of tuples. The Array is indexed according to the marginIndex, the 'nesting' level of the requestor." ^self marginTabAt: marginIndex side: 1 "1= leftSide, 2 = rightSide"! nextTabXFrom: anX leftMargin: leftMargin rightMargin: rightMargin "Tab stops are distances from the leftMargin. Set the distance into anX normalized for the paragraph's left margin. Scale makes the routine usable for printing. On the display the scale is 1." | normalizedX tabX i len| normalizedX _ anX - leftMargin. i _ 1. len _ tabsArray size. [i <= len] whileTrue: [(tabX _ (tabsArray at: i) asInteger) > normalizedX ifTrue: [^leftMargin + tabX min: rightMargin]. i _ i + 1]. ^rightMargin! rightMarginTabAt: marginIndex "Set the 'nesting' level of right margin indents of the paragraph in the style of the receiver to be marginIndex." "The marginTabsArray is an Array of tuples. The Array is indexed according to the marginIndex, the 'nesting' level of the requestor." ^self marginTabAt: marginIndex side: 2 "1= leftSide, 2 = rightSide"! tabWidth "Answer the width of standard tab." ^ DefaultTab! useTabs: newTabsArray "Change the tab stops used by this text style." | nextTab | tabsArray _ Array new: tabsArray size. 1 to: newTabsArray size do: [ :i | tabsArray at: i put: (newTabsArray at: i)]. nextTab _ newTabsArray last + self tabWidth. newTabsArray size+1 to: tabsArray size do: [ :i | tabsArray at: i put: nextTab. nextTab _ nextTab + self tabWidth]! ! !TextStyle methodsFor: 'fonts and font indexes'! flushFonts "Clean out the fonts, an aid when snapshotting claims too many are holding onto Display." "TextStyle default flushFonts." BinaryChoice message: 'This is very dangerous and should only be used if you know what you are doing and understand the system integrity issue.' displayAt: Display boundingBox center ifTrue: [1 to: fontArray size do: [:index | fontArray at: index put: nil]] ifFalse: [Transcript cr; show: 'flushFonts cancelled']! ! !TextStyle methodsFor: 'private'! basalFontFor: fontIndex ^self fontFor: fontIndex face: Basal! boldFontFor: fontIndex ^self fontFor: fontIndex face: Bold! boldItalicFontFor: fontIndex ^self fontFor: fontIndex face: BoldItalic! fontArray ^fontArray! fontFor: fontIndex face: face | currentFont currentFamilySizeFace family size emphasis newFamilySizeFace | currentFamilySizeFace _ (currentFont _ fontArray at: fontIndex) familySizeFace. family _ currentFamilySizeFace at: FamilyName. size _ currentFamilySizeFace at: PointSize. emphasis _ currentFont emphasis. (1 to: fontArray size) do: [:faceFontIndex | newFamilySizeFace _ (currentFont _ fontArray at: faceFontIndex) familySizeFace. ((((family = (newFamilySizeFace at: FamilyName)) and: [size = (newFamilySizeFace at: PointSize)]) and: [face = (newFamilySizeFace at: Face)]) and: [(emphasis bitAnd: NonFaceEmphasisMask) = (currentFont emphasis bitAnd: NonFaceEmphasisMask)]) ifTrue: [^faceFontIndex]]. ^ fontIndex! fontNamed: aString (1 to: fontArray size) do: [:faceFontIndex | aString = (fontArray at: faceFontIndex) name ifTrue: [^faceFontIndex]]. ^ self basalFontFor: 1! gridForFont: fontIndex withLead: leadInteger "Force whole style to suit one of its fonts. Assumes only one font referred to by runs. " | font | font _ self fontAt: fontIndex. self lineGrid: font height + leadInteger. self baseline: font ascent! isFontBold: fontIndex ^ ((fontArray at: fontIndex) familySizeFace at: Face) = Bold! isFontBoldItalic: fontIndex ^ ((fontArray at: fontIndex) familySizeFace at: Face) = BoldItalic! isFontItalic: fontIndex ^ ((fontArray at: fontIndex) familySizeFace at: Face) = Italic! isFontSubscripted: fontIndex ^ (((self fontAt: fontIndex) emphasis) bitAt: SubscriptedBit) = 1! isFontSuperscripted: fontIndex ^ (((self fontAt: fontIndex) emphasis) bitAt: SuperscriptedBit) = 1! isFontUnderlined: fontIndex ^ (((self fontAt: fontIndex) emphasis) bitAt: UnderlinedBit) = 1! italicFontFor: fontIndex ^self fontFor: fontIndex face: Italic! marginTabAt: marginIndex side: sideIndex "The marginTabsArray is an Array of tuples. The Array is indexed according to the marginIndex, the 'nesting' level of the requestor. sideIndex is 1 for left, 2 for right" | scale | scale _ 1. (marginIndex > 0 and: [marginIndex < marginTabsArray size]) ifTrue: [^((marginTabsArray at: marginIndex) at: sideIndex) * scale] ifFalse: [^0]! newFontArray: anArray fontArray _ anArray. lineGrid _ DefaultLineGrid. baseline _ DefaultBaseline. alignment _ 0. firstIndent _ 0. restIndent _ 0. rightIndent _ 0. outputMedium _ #Display. tabsArray _ DefaultTabsArray. marginTabsArray _ DefaultMarginTabsArray "Currently there is no supporting protocol for changing these arrays. If an editor wishes to implement margin setting, then a copy of the default should be stored as these instance variables."! subscriptedFontFor: fontIndex | name thisFont subscriptedFont | name _ (thisFont _ fontArray at: fontIndex) name. 1 to: fontArray size do: [:subscriptedFontIndex | (subscriptedFont _ fontArray at: subscriptedFontIndex) name = name ifTrue: [(((subscriptedFont emphasis bitAt: SubscriptedBit) = 1) and: [(thisFont emphasis bitAt: Underlined) = (subscriptedFont emphasis bitAt: Underlined)]) ifTrue: [^subscriptedFontIndex]]]. ^ fontIndex! superscriptedFontFor: fontIndex | name thisFont superscriptedFont | name _ (thisFont _ fontArray at: fontIndex) name. 1 to: fontArray size do: [:superscriptedFontIndex | (superscriptedFont _ fontArray at: superscriptedFontIndex) name = name ifTrue: [(((superscriptedFont emphasis bitAt: SuperscriptedBit) = 1) and: [(thisFont emphasis bitAt: Underlined) = (superscriptedFont emphasis bitAt: Underlined)]) ifTrue: [^superscriptedFontIndex]]]. ^ fontIndex! underlinedFontFor: fontIndex | name thisFont underlinedFont | name _ (thisFont _ fontArray at: fontIndex) name. 1 to: fontArray size do: [:underlinedFontIndex | (underlinedFont _ fontArray at: underlinedFontIndex) name = name ifTrue: [(((underlinedFont emphasis bitAt: UnderlinedBit) = 1) and: [(thisFont emphasis bitAnd: SubSuperscriptMask) = (underlinedFont emphasis bitAnd: SubSuperscriptMask)]) ifTrue: [^underlinedFontIndex]]]. ^ fontIndex! unSubscriptedFontFor: fontIndex | name thisFont unSubscriptedFont | name _ (thisFont _ fontArray at: fontIndex) name. 1 to: fontArray size do: [:unSubscriptedFontIndex | (unSubscriptedFont _ fontArray at: unSubscriptedFontIndex) name = name ifTrue: [(((unSubscriptedFont emphasis bitAt: SubscriptedBit) = 0) and: [(thisFont emphasis bitAt: Underlined) = (unSubscriptedFont emphasis bitAt: Underlined)]) ifTrue: [^unSubscriptedFontIndex]]]. ^ fontIndex! unSuperscriptedFontFor: fontIndex | name thisFont unSuperscriptedFont | name _ (thisFont _ fontArray at: fontIndex) name. 1 to: fontArray size do: [:unSuperscriptedFontIndex | (unSuperscriptedFont _ fontArray at: unSuperscriptedFontIndex) name = name ifTrue: [(((unSuperscriptedFont emphasis bitAt: SuperscriptedBit) = 0) and: [(thisFont emphasis bitAt: Underlined) = (unSuperscriptedFont emphasis bitAt: Underlined)]) ifTrue: [^unSuperscriptedFontIndex]]]. ^ fontIndex! unUnderlinedFontFor: fontIndex | name thisFont unUnderlinedFont | name _ (thisFont _ fontArray at: fontIndex) name. 1 to: fontArray size do: [:unUnderlinedFontIndex | (unUnderlinedFont _ fontArray at: unUnderlinedFontIndex) name = name ifTrue: [(((unUnderlinedFont emphasis bitAt: UnderlinedBit) = 0) and: [(thisFont emphasis bitAnd: SubSuperscriptMask) = (unUnderlinedFont emphasis bitAnd: SubSuperscriptMask)]) ifTrue: [^unUnderlinedFontIndex]]]. ^ fontIndex! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextStyle class instanceVariableNames: ''! !TextStyle class methodsFor: 'class initialization'! initialize "Initialize TextStyles constant dictionary." "TextStyle initialize" TextStyles _ Dictionary new. TextStyles at: #default put: DefaultTextStyle.! ! !TextStyle class methodsFor: 'instance creation'! fontArray: anArray "Answer an instance of the receiver with fonts those in anArray." ^self new newFontArray: anArray! ! !TextStyle class methodsFor: 'constants'! default "Answer the system default text style." ^DefaultTextStyle copy! resetViews "reset the world after changing the default textStyle" "TextStyle setDefaultTo: #small" "TextStyle resetViews" BitEditor initialize. ChangeListController initialize. FormEditor initialize. IconController initialize. NotifierController initialize.. ParagraphEditor initialize. TextList initialize. ScreenController initialize. StringHolderController initialize. ProjectController initialize. StandardSystemController initialize. StandardSystemController allInstances do: [:sc | sc initializeBlueButtonMenu]. Smalltalk allBehaviorsDo: [:b | (b respondsTo: #flushMenus) ifTrue: [b flushMenus]]. MouseMenuController allSubInstancesDo: [:c | (c respondsTo: #initializeYellowButtonMenu) ifTrue: [c initializeYellowButtonMenu]]. StandardSystemView withAllSubclasses do: [:ssv | ssv allInstances do: [:v | v newLabel: v label]]. TextCompositor allInstances do: [:v | v textStyle: TextStyle default]. TextList allInstances do: [:v | v textStyle: TextStyle default]. SelectionInListView allInstances do: [:view | view list: view getList]. ScheduledControllers restore.! setDefaultTo: aTextStyleSymbol "Set the default text style to be aTextStyleSymbol." "TextStyle setDefaultTo: #default" ^DefaultTextStyle _ TextStyles at: aTextStyleSymbol! styleNamed: aSymbol "Answer the style named aSymbol from the text style dictionary." ^(TextStyles at: aSymbol) copy! styleNamed: aSymbol ifAbsent: aBlock "Answer the style named aSymbol from the text style dictionary. If the style is not in the dictionary, answer the result of evaluating aBlock." ^(TextStyles at: aSymbol ifAbsent: aBlock) copy! styleNamed: aSymbol put: aTextStyle "Store the text style aTextStyle in the text style dictionary, naming it aSymbol." TextStyles at: aSymbol put: aTextStyle! styles "Answer a set of names of all the text styles." ^TextStyles keys! ! TextStyle initialize! View subclass: #TextView instanceVariableNames: 'partMsg acceptMsg menuMsg ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Text'! TextView comment: 'TextView is a "pluggable" view of text. 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 yellowButtonMenu) into model-specific operations (such as textMenu). See the protocol ''adaptor'' for use of the pluggable selectors. 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.'! !TextView methodsFor: 'initialize-release'! initialize super initialize. self insideColor: Form white! newText: aText aText == nil ifTrue: [^ self newText: Text new]. self controller paragraph text: aText. self controller paragraph lines at: 1 put: 1. self controller resetState! ! !TextView methodsFor: 'controller access'! defaultControllerClass ^ TextController! ! !TextView methodsFor: 'displaying'! display "Show the text of the receiver on the display screen." self isUnlocked ifTrue: [self controller wrappingBox: (self insetDisplayBox insetBy: 6 @ 0) clippingBox: self insetDisplayBox. (controller text isEmpty and: [controller textHasChanged not]) ifTrue: [self newText: self getText]]. super display! displayView self topView isCollapsed ifFalse: [ self clearInside. self controller display ]! ! !TextView methodsFor: 'updating'! update: aSymbol | text | aSymbol == partMsg ifTrue: [text _ self getText. self controller text ~= text ifTrue: [self newText: text. self displayView]]! updateRequest | cancel | self controller textHasChanged ifFalse: [^true]. self topView isCollapsed ifFalse: [Display reverse: insetDisplayBox mask: Form gray. Display reverse: (insetDisplayBox insetBy: 4) mask: Form gray]. cancel _ self confirm: 'The text showing has been altered. Do you wish to discard those changes?'. self topView isCollapsed ifFalse: [Display reverse: insetDisplayBox mask: Form gray. Display reverse: (insetDisplayBox insetBy: 4) mask: Form gray]. ^ cancel! ! !TextView methodsFor: 'deEmphasizing'! deEmphasizeView self controller deselect! ! !TextView methodsFor: 'emphasizing'! emphasizeView self controller select! ! !TextView methodsFor: 'adaptor'! accept: aText from: aController acceptMsg == nil ifTrue: [self flash. ^ false]. ^ acceptMsg numArgs = 1 ifTrue: "one arg selectors get text only" [model perform: acceptMsg with: aText] ifFalse: "two arg selectors get text and controller as well" [model perform: acceptMsg with: aText with: aController]! getText | text | partMsg == nil ifTrue: [^ Text new]. text _ model perform: partMsg. text == nil ifTrue: [^ Text new]. ^ text! yellowButtonMenu menuMsg == nil ifTrue: [^ nil]. ^ model perform: menuMsg! ! !TextView methodsFor: 'private'! on: anObject aspect: m1 change: m3 menu: m4 self model: anObject. partMsg _ m1. acceptMsg _ m3. menuMsg _ m4. self initialize! paragraphInset "Answer the amount to inset the paragraph from the border" ^6@0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextView class instanceVariableNames: ''! !TextView class methodsFor: 'instance creation'! on: anObject aspect: aspectMsg change: changeMsg menu: menuMsg "Create a 'pluggable' (see class comment) textView viewing anObject. aspectMsg is sent to read the current text value in the model. It is also used as the changed: parameter for this view. changeMsg is sent to inform anObject of new text for the model. menuMsg is sent to read the yellowButton menu for this view." ^ self new on: anObject aspect: aspectMsg change: changeMsg menu: menuMsg! ! Magnitude subclass: #Time instanceVariableNames: 'hours minutes seconds ' classVariableNames: '' poolDictionaries: '' category: 'Numeric-Magnitudes'! Time comment: 'An instance of class Time represents a particular second in a day. Days start at midnight. Protocol provided for the object Time supports inquiries about time in general as well as details about a specific time. Instance Variables: hours minutes seconds Time is represented by integral units of hours, minutes and seconds such that the total seconds since midnight is 3600*hours + (60*minutes + seconds) '! !Time methodsFor: 'comparing'! < aTime "Answer whether the argument, aTime is earlier than the receiver." hours ~= aTime hours ifTrue: [^hours < aTime hours]. minutes ~= aTime minutes ifTrue: [^minutes < aTime minutes]. ^seconds < aTime seconds! = aTime "Answer whether aTime represents the same second as the receiver." self species = aTime species ifTrue: [^hours = aTime hours & (minutes = aTime minutes) & (seconds = aTime seconds)] ifFalse: [^false]! hash "Answer a SmallInteger unique to the receiver." ^((hours hash bitShift: 3) bitXor: minutes) bitXor: seconds! ! !Time methodsFor: 'accessing'! hours "Answer the number of hours the receiver represents." ^hours! minutes "Answer the number of minutes the receiver represents." ^minutes! seconds "Answer the number of seconds the receiver represents." ^seconds! ! !Time methodsFor: 'arithmetic'! addTime: timeAmount "Answer a new Time that is timeAmount after the receiver. timeAmount is an instance of Date or Time." ^Time fromSeconds: self asSeconds + timeAmount asSeconds! subtractTime: timeAmount "Answer a new Time that is timeAmount before the receiver. timeAmount is an instance of Date or Time." ^Time fromSeconds: self asSeconds - timeAmount asSeconds! ! !Time methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver. Format is h:mm:ss am/pm." hours > 12 ifTrue: [hours - 12 printOn: aStream] ifFalse: [hours < 1 ifTrue: [12 printOn: aStream] ifFalse: [hours printOn: aStream]]. aStream nextPutAll: (minutes < 10 ifTrue: [':0'] ifFalse: [':']). minutes printOn: aStream. aStream nextPutAll: (seconds < 10 ifTrue: [':0'] ifFalse: [':']). seconds printOn: aStream. aStream nextPutAll: (hours < 12 ifTrue: [' am'] ifFalse: [' pm'])! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver. The general format for objects is ( class-name readFromString: string )" aStream nextPutAll: '(', self class name, ' readFromString: '; print: self printString; nextPut: $)! ! !Time methodsFor: 'converting'! asSeconds "Answer the number of seconds since midnight of the receiver." ^3600 * hours + (60 * minutes + seconds)! ! !Time methodsFor: 'private'! hours: anInteger "Initialize the hour of the day." hours _ anInteger! hours: hourInteger minutes: minInteger seconds: secInteger "Initialize all the instance variables." hours _ hourInteger. minutes _ minInteger. seconds _ secInteger! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Time class instanceVariableNames: ''! !Time class methodsFor: 'instance creation'! fromSeconds: secondCount "Answer a Time that is secondCount seconds since midnight." | secondsInHour hours | hours _ secondCount truncated // 3600. secondsInHour _ secondCount truncated \\ 3600. ^self new hours: hours minutes: secondsInHour // 60 seconds: secondsInHour \\ 60! now "Answer a Time representing the time right now--this is a 24 hour clock." ^self dateAndTimeNow at: 2! readFrom: aStream "Answer a Time as read from the argument aStream that is in the form: :: , or may be omitted. such as, 1:59:30 pm 8AM 15:30 For example, Time readFrom: (ReadStream on: '2:23:09 pm')" | hour minute second | hour _ Integer readFrom: aStream. hour = 12 ifTrue: [hour _ 0]. minute _ 0. second _ 0. (aStream peekFor: $:) ifTrue: [minute _ Integer readFrom: aStream. (aStream peekFor: $:) ifTrue: [second _ Integer readFrom: aStream]]. aStream skipSeparators. (aStream atEnd not and: [aStream peek isLetter]) ifTrue: [aStream next asLowercase = $p ifTrue: ["potentially pm, look for m or M" (aStream peekFor: $m) ifTrue: [hour _ hour + 12] ifFalse: [(aStream peekFor: $M) ifTrue: [hour _ hour + 12]]]]. ^self fromSeconds: 60*(60*hour+minute)+second! ! !Time class methodsFor: 'general inquiries'! dateAndTimeNow "Answer an array of (Date today, Time now)." "Time dateAndTimeNow." ^self currentTime! millisecondClockValue "Answer the number of milliseconds since the millisecond clock was last reset or rolled over." | milliseconds | milliseconds _ LargePositiveInteger new: 4. self millisecondClockInto: milliseconds. ^milliseconds truncated! millisecondsToRun: timedBlock "Answer the number of milliseconds timedBlock takes to return its value." | initialMilliseconds | initialMilliseconds _ self millisecondClockValue. timedBlock value. ^self millisecondClockValue - initialMilliseconds! timeWords "Answer the seconds (in GMT) since 1901 began, as a four element ByteArray. The high-order 8-bits of the answer are stored in the byte indexed by 1 and the low-order 8-bits in the byte indexed 4." | seconds bytes | seconds _ ByteArray new: 4. self secondClockInto: seconds. bytes _ ByteArray new: 4. "Reverse the bytes" 1 to: 4 do: [:i | bytes at: i put: (seconds at: 5 - i)]. ^bytes! totalSeconds "Answer the total seconds since 1901 began, corrected for time zone and daylight savings time." ^self currentSeconds! ! !Time class methodsFor: 'private'! aTime: theSeconds "Answer an Array of (Date today, Time now)." ^TimeZone default convertGMT: theSeconds do: [:date :seconds | Array with: date with: (Time fromSeconds: seconds)]! aTimeString: theSeconds "Answer a String of the date and time where the argument, theSeconds, represents the number of seconds since 1901 began." ^TimeZone default convertGMT: theSeconds do: [:date :seconds | date printString , ' ' , (Time fromSeconds: seconds) printString]! currentSeconds "Answer with the total seconds since 1901 began, corrected for time zone and daylight savings time." ^TimeZone default convertGMT: self secondClock do: [:date :seconds | date asSeconds + seconds]! currentTime "Answer an Array of (Date today, Time now)." ^TimeZone default convertGMT: self secondClock do: [:date :seconds | Array with: date with: (Time fromSeconds: seconds)]! millisecondClockInto: aByteArray "Answer the number of milliseconds since the millisecond clock was last reset or rolled over by storing the result in the argument. The argument is a byte indexable object of length at least four (a LargePositiveInteger). Store into the first four bytes of the argument the number of milliseconds since the millisecond clock was last reset or rolled over (a 32-bit unsigned number). The low-order 8-bits are stored in the byte indexed by 1 and the high-order 8-bits in the byte indexed 4. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! secondClock "Answer an integer representing the number of seconds since 1901 began." | seconds | seconds _ LargePositiveInteger new: 4. self secondClockInto: seconds. ^seconds truncated! secondClockInto: aByteArray "The argument is a byte indexable object of length at least four. Store into the first four bytes of the argument the number of seconds since 1901 began (a 32-bit unsigned number). The low-order 8-bits are stored in the byte indexed by 1 and the high-order 8-bits in the byte indexed 4. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! Object subclass: #TimeZone instanceVariableNames: 'secondsFromGMT dayStartDST dayEndDST timeStartEndDST secondsForDST weekDayStartDST ' classVariableNames: 'DefaultTimeZone NullTimeZone ' poolDictionaries: '' category: 'Numeric-Magnitudes'! TimeZone comment: 'This class represents a time zone, i.e., a mapping between Greenwich Mean Time (GMT) and local time. This involves both a time difference for standard time, and an algorithm for determining whether Daylight Savings Time (DST) is in effect and, if so, what the additional time offset is. This class is intended as a support class for class Time. There are places in the world in which one or the other of the time offsets is not an integral number of hours, and where the DST algorithms vary. We accommodate the former, but not the latter. We currently assume that DST transitions always occur on the last Sunday preceding a fixed date. Instance Variables: secondsFromGMT offset of this time zone from GMT, in seconds, e.g., California = -8 * 3600 dayStartDST day of (non-leap) year when DST starts (resolved to the previous Sunday) dayEndDST day of (non-leap) year when DST ends (resolved to the previous Sunday) timeStartEndDST time of day (in seconds) when DST starts or ends secondsForDST (non-negative) additional time offset when DST is in effect, e.g., U.S. uses 1 hour = 3600 Class Variables: DefaultTimeZone a Time Zone initialized with date and time information to specify difference from GMT NullTimeZone a Time Zone with no date and time information '! !TimeZone methodsFor: 'accessing'! weekDayToStartDST "Return the day of the week that DST starts (usually #Sunday)." ^weekDayStartDST! weekDayToStartDST: aSymbol "Set the day of the week that DST starts (usually #Sunday)." weekDayStartDST _ aSymbol.! ! !TimeZone methodsFor: 'converting'! convertGMT: totalSeconds do: aBlock "Convert a GMT time to a local date and time (the two interact because of Daylight Saving Time.) The GMT time origin is midnight, Dec 31 1900. Answer with the result of invoking the argument aBlock with two arguments representing the local date (an instance of Date) and time (an instance of Time where time is in seconds where midnight = 0)." | sec date seconds days dstDay dd start end dday | sec _ totalSeconds + secondsFromGMT. "Estimate the number of days since the origin." days _ sec // 86400. seconds _ sec - (days * 86400). "avoid a second long division" "Decide if DST is in effect." secondsForDST ~= 0 ifTrue: ["This time zone does have DST" dstDay _ seconds < timeStartEndDST ifTrue: [days - 1] ifFalse: [days]. dd _ Date fromDays: dstDay. dday _ dd day. start _ Date newDay: (dayStartDST >= 60 ifTrue: [dayStartDST + dd leap - 1] ifFalse: [dayStartDST]) year: dd year. dday >= (start previous: self weekDayToStartDST) day ifTrue: [end _ Date newDay: (dayEndDST >= 60 ifTrue: [dayEndDST + dd leap - 1] ifFalse: [dayEndDST]) year: dd year. dday < (end previous: self weekDayToStartDST) day ifTrue: ["DST is in effect. Correct the time." seconds _ seconds + secondsForDST. seconds >= 86400 ifTrue: ["crossed a day boundary" seconds _ seconds - 86400. days _ days + 1]]]. date _ dstDay = days ifTrue: [dd] ifFalse: [Date fromDays: days]] ifFalse: ["No DST" date _ Date fromDays: days]. ^aBlock value: date value: seconds! ! !TimeZone methodsFor: 'private'! setDifference: hours DST: dstAmount at: dstHour from: dstStart to: dstEnd "Initialize the instance variables." secondsFromGMT _ (hours * 3600) rounded. dayStartDST _ dstStart. dayEndDST _ dstEnd. timeStartEndDST _ (dstHour * 3600) rounded. secondsForDST _ (dstAmount * 3600) rounded! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TimeZone class instanceVariableNames: ''! !TimeZone class methodsFor: 'class initialization'! initialize "Install a default TimeZone. The parameters here are for California. Eventually we should obtain this from the operating system." "TimeZone initialize." DefaultTimeZone _ self timeDifference: -8 "Offset for California." DST: 1 "1 hour DST" at: 4 "starting at 4 AM" from: 91 + 6 "(first Sunday preceding) April 7" to: 274 + 6. "(first Sunday preceding) October 7" DefaultTimeZone weekDayToStartDST: #Sunday. "Also create a zone that leaves times unchanged." NullTimeZone _ self timeDifference: 0 DST: 0 at: 0 from: 0 to: 0. NullTimeZone weekDayToStartDST: #Sunday.! initializeDefaultTimeZone: hoursFromGMT "Install a default TimeZone with hours offset from Greenwich mean time." "TimeZone initializeDefaultTimeZone: -8. for California TimeZone initializeDefaultTimeZone: -5. for NewYork TimeZone initializeDefaultTimeZone: 0. for London TimeZone initializeDefaultTimeZone: 1. for Dortmund TimeZone initializeDefaultTimeZone: nil. for absolute" hoursFromGMT == nil ifTrue: [ DefaultTimeZone _ self null ] ifFalse:[ DefaultTimeZone _ self timeDifference: hoursFromGMT DST: 1 "1 hour DST" at: 4 "starting at 4 AM" from: 91 + 6 "on (first Sunday preceding) April 7" to: 274 + 6. "until (first Sunday preceding) October 7" DefaultTimeZone weekDayToStartDST: #Sunday.]! ! !TimeZone class methodsFor: 'instance creation'! default "Answer the default time zone, set at class initialization." ^DefaultTimeZone! null "Answer a TimeZone that leaves times unchanged. This is appropriate if the operating system returns local time rather than GMT." ^NullTimeZone! timeDifference: hours DST: amount at: startHour from: startDate to: endDate "Answer a new TimeZone. This is the most general message for creating a TimeZone with specified time difference and DST parameters." ^self new setDifference: hours DST: amount at: startHour from: startDate to: endDate! ! TimeZone initialize! Boolean subclass: #True instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! True comment: 'Class True describes the behavior of its sole instance, true'! !True methodsFor: 'logical operations'! & alternativeObject "Evaluating conjunction. Answer alternativeObject since receiver is true." ^alternativeObject! not "Negation--answer false since the receiver is true." ^false! | aBoolean "Evaluating disjunction (OR) -- answer true since the receiver is true." ^self! ! !True methodsFor: 'controlling'! and: alternativeBlock "Nonevaluating conjunction -- answer the value of alternativeBlock since the receiver is true." ^alternativeBlock value! ifFalse: alternativeBlock "Since the condition is true, the value is the true alternative, which is nil." "Execution does not actually reach here because the expression is compiled in-line." ^nil! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Answer the value of trueAlternativeBlock." "Execution does not actually reach here because the expression is compiled in-line." ^trueAlternativeBlock value! ifTrue: alternativeBlock "Answer the value of alternativeBlock." "Execution does not actually reach here because the expression is compiled in-line." ^alternativeBlock value! ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock "Answer with the value of trueAlternativeBlock." "Execution does not actually reach here because the expression is compiled in-line." ^trueAlternativeBlock value! or: alternativeBlock "Nonevaluating disjunction -- answer true since the receiver is true." ^self! ! !True methodsFor: 'printing'! printOn: aStream "Print true." aStream nextPutAll: 'true'! ! Object subclass: #UndefinedObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! UndefinedObject comment: 'Class UndefinedObject describes the behavior of its sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.'! !UndefinedObject methodsFor: 'initialize-release'! release "Nil release is a no-op"! ! !UndefinedObject methodsFor: 'copying'! deepCopy "Only one instance of UndefinedObject should ever be made, so answer with self."! shallowCopy "Only one instance of UndefinedObject should ever be made, so answer with self."! ! !UndefinedObject methodsFor: 'printing'! printOn: aStream "Print nil." aStream nextPutAll: 'nil'! storeOn: aStream "Append to the argument aStream the literal 'nil'." aStream nextPutAll: 'nil'! ! !UndefinedObject methodsFor: 'testing'! isNil ^true! notNil ^false! ! !UndefinedObject methodsFor: 'dependents access'! addDependent: ignored self error: 'Nil should not have dependents'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UndefinedObject class instanceVariableNames: ''! !UndefinedObject class methodsFor: 'instance creation'! new self error: 'You may not create any more undefined objects--use nil'! ! LeafNode subclass: #VariableNode instanceVariableNames: 'name isArg ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! VariableNode comment: 'I am a parse tree leaf representing a variable. Note that my name and key are different for pool variables -- the key is the Object Reference.'! !VariableNode methodsFor: 'initialize-release'! isArg: aBoolean isArg _ aBoolean! name: varName index: i type: type self name: varName key: varName index: i type: type! name: string key: object code: byte name _ string. key _ object. code _ byte! name: varName key: objRef index: i type: type name _ varName. self key: objRef index: i type: type! ! !VariableNode methodsFor: 'code generation'! emitForReturn: stack on: strm (code >= LdSelf and: [code <= LdNil]) ifTrue: ["short returns" strm nextPut: EndMethod - 4 + (code - LdSelf). stack push: 1 "doesnt seem right"] ifFalse: [super emitForReturn: stack on: strm]! emitForValue: stack on: strm code < 256 ifTrue: [strm nextPut: (code = LdSuper ifTrue: [LdSelf] ifFalse: [code]). stack push: 1] ifFalse: [self emitLong: LdInstLong on: strm. stack push: 1]! emitStore: stack on: strm self emitLong: Store on: strm! emitStorePop: stack on: strm (code between: 0 and: 7) ifTrue: [strm nextPut: ShortStoP + code "short stopop inst"] ifFalse: [(code between: 16 and: 23) ifTrue: [strm nextPut: ShortStoP + 8 + code - 16 "short stopop temp"] ifFalse: [self emitLong: StorePop on: strm]]. stack pop: 1! sizeForReturn: encoder (code >= LdSelf and: [code <= LdNil]) ifTrue: ["short returns" ^1]. ^super sizeForReturn: encoder! sizeForStore: encoder self reserve: encoder. ^(code < 256 or: [code \\ 256 < 64]) ifTrue: [2] ifFalse: [3]! sizeForStorePop: encoder self reserve: encoder. (code < 24 and: [code noMask: 8]) ifTrue: [^1]. ^(code < 256 or: [code \\ 256 < 64]) ifTrue: [2] ifFalse: [3]! ! !VariableNode methodsFor: 'printing'! printOn: aStream indent: level aStream nextPutAll: name! ! !VariableNode methodsFor: 'testing'! canBeSpecialArgument "can I be an argument of (e.g.) ifTrue:?" ^code < LdNil! isArg ^self isTemp and: [isArg==true]! isTemp "Answer true if this describes a temporary variable" code < 0 ifTrue: [^code = LdTempType negated]. code > 255 ifTrue: [^code between: LdTempType * 256 and: LdTempType * 256 + 255]. ^code between: (CodeBases at: 2) and: (CodeBases at: 2) + (CodeLimits at: 2) - 1! isVariableReference ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! VariableNode class instanceVariableNames: ''! !VariableNode class methodsFor: 'class initialization'! initialize "VariableNode initialize. Decompiler initialize." | encoder | encoder _ Encoder new. StdVariables _ Dictionary new: 16. encoder fillDict: StdVariables with: VariableNode mapping: #('self' 'thisContext' 'super' 'nil' 'false' 'true' ) to: (Array with: LdSelf with: LdThisContext with: LdSuper) , (Array with: LdNil with: LdFalse with: LdTrue). StdSelectors _ Dictionary new: 64. encoder fillDict: StdSelectors with: SelectorNode mapping: ((1 to: Smalltalk specialSelectorSize) collect: [:i | Smalltalk specialSelectorAt: i]) to: (SendPlus to: SendPlus + 31). StdLiterals _ LiteralDictionary new: 16. encoder fillDict: StdLiterals with: LiteralNode mapping: #(-1 0 1 2 ) to: (LdMinus1 to: LdMinus1 + 3). encoder initScopeAndLiteralTables. self initialize2: encoder! initialize2: encoder "VariableNode initialize." NodeNil _ encoder encodeVariable: 'nil'. NodeTrue _ encoder encodeVariable: 'true'. NodeFalse _ encoder encodeVariable: 'false'. NodeSelf _ encoder encodeVariable: 'self'. NodeThisContext _ encoder encodeVariable: 'thisContext'. NodeSuper _ encoder encodeVariable: 'super'! ! VariableNode initialize! Object subclass: #View instanceVariableNames: 'model controller superView subViews transformation viewport window displayTransformation insetDisplayBox borderWidth borderColor insideColor boundingBox ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Framework'! View comment: 'Instances of class View are intended to be components in a structured picture. Each View in the structured picture can contain other Views as sub-components. These sub-components are called subViews. A View can be a subView of only one View. This View is called its superView. The set of Views in a structured picture forms a hierarchy. The one View in the hierarchy that has no superView is called the topView of the structured picture. A View in a structured picture with no subViews is called a bottom View. A View and all of its subViews, and all of their subViews and so on, are treated as a unit in many operations on the View. For example, if a View is displayed, all of its subViews are displayed as well. There are several catagories of operations that can be performed on a View. Among these are the following. 1. Adding subViews to a View. 2. Positioning subViews within a View. 3. Deleting subViews from a View. 4. Transforming a View. 5. Displaying a View. Each View has its own coordinate system. In order to change from one coordinate system to another, each View has two transformations associated with it. The local transformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the coordinate system of the superView of the View. The displayTransformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the display screen coordinate system. The part of the space that is to be made visible is represented by the window of the View. The window of a View is a Rectangle expressed in the coordinate system of the View. The area occupied by a View in the coordinate system of its superView is called its viewport. The viewport of a View is its window transformed by its local transformation. The region of the display screen occupied by a View is called its displayBox. The display box of a View can include a border. The width of the border expressed in display screen coordinates is called the border width of the View. The color of the border is called the border color. The region of the display box of a View excluding the border is called the inset display box. The color of the inset display box is called the inside color of the View. Instance Variables: model controller , #NoControllerAllowed, or nil superView or nil subViews of Views transformation viewport (in superView coordinates), or nil. window (in View coordinates), or nil. displayTransformation or nil. insetDisplayBox (in display screen coordinates), or nil. borderWidth (display screen unit) or 0 (meaning no border). borderColor insideColor or nil (meaning transparent) boundingBox (in View coordinates), or nil '! !View methodsFor: 'initialize-release'! initialize "Initialize the state of the receiver. Subclasses should include 'super initialize' when redefining this message to insure proper initialization." self resetSubViews. transformation _ WindowingTransformation identity. self borderWidth: 0. self borderColor: Form black! release "Remove the receiver from its model's list of dependents (if the model exists), and release all of its subViews. It is used to break possible cycles in the receiver and should be sent when the receiver is no longer needed. Subclasses should include 'super release.' when redefining release." super release. model removeDependent: self. model _ nil. controller release. controller _ nil. subViews ~~ nil ifTrue: [subViews do: [:aView | aView release]]. subViews _ nil. superView _ nil.! ! !View methodsFor: 'testing'! containsPoint: aPoint "Answer true if aPoint is within the receiver's display box, and answer false, otherwise. It is sent to a View's subViews by View|subViewAt: in order to determine which subView contains the cursor point (so that, for example, control can be pass down to that subView's controller)." ^self displayBox containsPoint: aPoint! ! !View methodsFor: 'model access'! model "Answer the receiver's model." ^model! model: aModel "Set the receiver's model to aModel. The model of the receiver's controller is also set to aModel." self model: aModel controller: controller! ! !View methodsFor: 'superView access'! isTopView "Answer true if the receiver is a top view, that is, if it has no superView." ^superView == nil! resetSubViews "Set the list of subviews to an empty collection." subViews _ OrderedCollection new! superView "Answer the superView of the receiver." ^superView! topView "Answer the root of the tree of Views in which the receiver is a node. The root of the tree is found by going up the superView path until reaching a View whose superView is nil." superView == nil ifTrue: [^self] ifFalse: [^superView topView]! ! !View methodsFor: 'subView access'! firstSubView "Answer the first subView in the receiver's list of subViews if it is not empty, else nil." subViews isEmpty ifTrue: [^nil] ifFalse: [^subViews first]! lastSubView "Answer the last subView in the receiver's list of subViews if it is not empty, else nil." subViews isEmpty ifTrue: [^nil] ifFalse: [^subViews last]! subViewContaining: aPoint "Answer the first subView that contains aPoint within its window and answer nil, otherwise. It is typically sent from a Controller in order to determine where to pass control (usually to the Controller of the View returned by View|subViewContaining:). " subViews reverseDo: [:aSubView | (aSubView displayBox containsPoint: aPoint) ifTrue: [^aSubView]]. ^nil! subViews "Answer the receiver's collection of subViews." ^subViews! ! !View methodsFor: 'controller access'! controller "If the receiver's controller is nil (the default case), an initialized instance of the receiver's default controller is returned." controller == nil ifTrue: [self controller: self defaultController]. ^controller! controller: aController "Set the receiver's controller to aController. An instance of NoController can be specified to indicate that the receiver will not have a controller. The model of aController is set to the receiver's model." self model: model controller: aController! defaultController "Answer an initialized instance of the receiver's default controller. Subclasses should redefine this message only if the default controller instances need to be initialized in a nonstandard way." ^self defaultControllerClass new! defaultControllerClass "Answer the class of the default controller for the receiver. Subclasses should redefine View|defaultControllerClass if the class of the default controller is not Controller." ^Controller! model: aModel controller: aController "Set the receiver's model to aModel, add the receiver to aModel's list of dependents, and set the receiver's controller to aController. Subsequent changes to aModel (see Model|change) will result in View|update: messages being sent to the receiver. nil for the value of aController indicates that the default controller is to be used when needed. If aController is not nil, its view is set to the receiver and its model is set to aModel." model ~~ nil & (model ~~ aModel) ifTrue: [model removeDependent: self]. aModel ~~ nil & (aModel ~~ model) ifTrue: [aModel addDependent: self]. model _ aModel. aController ~~ nil ifTrue: [aController view: self. aController model: aModel]. controller _ aController! ! !View methodsFor: 'basic control sequence'! subViewWantingControl "Answer the first subView that has a controller that now wants control." subViews reverseDo: [:aSubView | aSubView controller isControlWanted ifTrue: [^aSubView]]. ^nil! ! !View methodsFor: 'window access'! defaultWindow "Build the minimum Rectangle that encloses all the windows of the receiver's subViews. The answer is a Rectangle obtained by expanding this minimal Rectangle by the borderWidth of the receiver. If the receiver has no subViews, then a Rectangle enclosing the entire display screen is answered. It is used internally by View methods if no window has been specified for the View. Specialized subclasses of View should redefine View|defaultWindow to handle the default case for instances that have no subViews. " | aRectangle | subViews isEmpty ifTrue: [^DisplayScreen boundingBox]. aRectangle _ self firstSubView viewport. subViews do: [:aView | aRectangle _ aRectangle merge: aView viewport]. ^aRectangle expandBy: self borderWidth! insetWindow "Answer a Rectangle that is obtained by insetting the receiver's window rectangle by the border width." ^self getWindow insetBy: self borderWidth! window "Answer a copy of the receiver's window." ^self getWindow copy! window: aWindow "Set the receiver's window to a copy of aWindow." self setWindow: aWindow copy! ! !View methodsFor: 'viewport access'! viewport "Answer a copy of the receiver's viewport." ^self getViewport copy! ! !View methodsFor: 'display box access'! boundingBox "Answer the bounding box which for the default case is the rectangular area surrounding the bounding boxes of all the subViews." boundingBox ~~ nil ifTrue: [^boundingBox] ifFalse: [^self computeBoundingBox]! computeBoundingBox "Answer the minimum rectangle that encloses the bounding boxes of the receiver's subViews. If the receiver has no subViews, then the bounding box is the receiver's window." "Subclasses should redefine View|boundingBox if a more suitable default for the case of no subViews is available." | aRectangle | subViews isEmpty ifTrue: [^self getWindow]. aRectangle _ self firstSubView transform: self firstSubView boundingBox. subViews do: [:aView | aRectangle _ aRectangle merge: (aView transform: aView boundingBox).]. ^aRectangle expandBy: self borderWidth! displayBox "Answer the receiver's inset display box (see View|insetDisplayBox) expanded by the borderWidth. The display box represents the region of the display screen in which the receiver (including the border) is displayed. If the receiver is totally clipped by the display screen and its superView, the resulting Rectangle will be invalid." ^self insetDisplayBox expandBy: self borderWidth! insetDisplayBox "Answer the receiver's inset display box. The inset display box is the intersection of the receiver's window, tranformed to display coordinates, and the inset display box of the superView, inset by the border width. The inset display box represents the region of the display screen in which the inside of the receiver (all except the border) is displayed. If the receiver is totally clipped by the display screen and its superView, the resulting Rectangle will be invalid." [insetDisplayBox == nil] whileTrue: [insetDisplayBox _ self computeInsetDisplayBox]. ^insetDisplayBox! ! !View methodsFor: 'lock access'! isLocked "Answer whether the receiver is locked. A View is 'locked' if its display transformation and inset display box are defined. If these are undefined, the View is 'unlocked'. The display transformation and inset display box become undefined when the transformation of the View (or the transformation of a View in its superView chain) is changed, or when the superView of the View is changed, or any other change to the View that affects the display screen coordinates of the View. The locking and unlocking of a View is handled automatically by the internal methods of the View, but can also be done explicitly if desired (see View|lock, and View|unlock)." displayTransformation == nil | (insetDisplayBox == nil) ifTrue: [^false] ifFalse: [^true]! isUnlocked "Answer whether the receiver is unlocked. See comment in View|isLocked." ^displayTransformation == nil & (insetDisplayBox == nil)! lock "'Lock' the receiver and all of its subViews (see View|isLocked). This has the effect of computing and storing the display transformation (see View|displayTransformation) and inset display box (see View|insetDisplayBox) of the receiver and all its subViews. The locking and unlocking of a View is handled automatically by the internal methods of the View, but can also be done explicitly if desired." self isLocked ifTrue: [^self]. displayTransformation _ self computeDisplayTransformation. insetDisplayBox _ self computeInsetDisplayBox. subViews do: [:aSubView | aSubView lock]! unlock "'Unlock the receiver and all of its subViews (see View|isUnlocked). This has the effect of forcing the display transformation (see View|displayTransformation) and inset display box (see View|insetDisplayBox) of the receiver and all its subViews to be recomputed the next time they are referenced. The locking and unlocking of a View is handled automatically by the internal methods of the View, but can also be done explicitly if desired." self isUnlocked ifTrue: [^self]. displayTransformation _ nil. insetDisplayBox _ nil. subViews do: [:aSubView | aSubView unlock]! ! !View methodsFor: 'subView inserting'! addSubView: aView "Remove aView from the tree of Views it is in (if any) and adds it to the rear of the list of subViews of the receiver. Set the superView of aView to be the receiver. It is typically used to build up a hierarchy of Views (a structured picture). An error is generated if aView is the same as the receiver or its superView, etc." self addSubView: aView ifCyclic: [self error: 'cycle in subView structure.']! addSubView: aSubView above: lowerView "Adds aView (see View|addSubView:) so that it lies above lowerView" self addSubView: aSubView align: aSubView viewport bottomLeft with: lowerView viewport topLeft! addSubView: aSubView align: aPoint1 with: aPoint2 "Add aView to the receiver's list of subViews (see View|addSubView:) and translate aView so that aPoint1 coincides with aPoint2. It is typically used to build up a hierarchy of Views (a structured picture). Normally, aPoint1 is a point on aView's viewport (e.g. aView viewport topLeft, etc.), and aPoint2 is either an arbitrary point in the receiver's coordinate system or a point on the receiver's window (e.g. self window topRight, etc)." self addSubView: aSubView. aSubView align: aPoint1 with: aPoint2! addSubView: aSubView below: lowerView "Adds aView (see View|addSubView:) so that it lies below lowerView" self addSubView: aSubView align: aSubView viewport topLeft with: lowerView viewport bottomLeft! addSubView: aView ifCyclic: exceptionBlock "Remove aView from the tree of Views it is in (if any) and add it to the rear of the list of subViews of the receiver. Set the superView of aView to be the receiver. It is typically used to build up a hierarchy of Views (a structured picture). An error is generated if aView is the same as the receiver or its superView, etc." (self isCyclic: aView) ifTrue: [exceptionBlock value] ifFalse: [aView removeFromSuperView. subViews addLast: aView. aView superView: self]! addSubView: aView in: aRelativeRectangle borderWidth: width "I make 'aView' into a subview. I use 'aRelativeRectangle' and the super view's window to compute (1) a viewport within the superview for 'aView' and (2) the window extent for 'aView'. Note: defining the windowing transformation and deriving the viewport is logically equivalent but does not seem to be easily done" | subViewPort myWindow myExtent myOrigin | self addSubView: aView ifCyclic: [self error: 'cycle in subView structure.']. aView borderWidth: width. myWindow _ self window. myExtent _ myWindow extent. myOrigin _ myWindow origin. subViewPort _ (myExtent * aRelativeRectangle origin) + myOrigin corner: (myExtent * aRelativeRectangle corner) + myOrigin. aView window: aView window viewport: subViewPort! addSubView: aSubView toLeftOf: rightView "Adds aView (see addSubView:) so that it lies to the left of rightView." self addSubView: aSubView align: aSubView viewport topRight with: rightView viewport topLeft! addSubView: aSubView toRightOf: leftView "Adds aView (see addSubView:) so that it lies to the right of leftView" self addSubView: aSubView align: aSubView viewport topLeft with: leftView viewport topRight! addSubView: aView viewport: aViewport "Add aView to the receiver's list of subViews (see View|addSubView:) and applies to aView a scale and translation computed from its window and aViewport (such that its window fills aViewport)." self addSubView: aView. aView window: aView window viewport: aViewport! addSubView: aView window: aWindow viewport: aViewport "Add aView to the receiver's list of subViews (see View|addSubView:) and applies to aView a scale and translation computed from aWindow and aViewport (such that aWindow fills aViewport)." self addSubView: aView. aView window: aWindow viewport: aViewport! insertSubView: aSubView above: lowerView "Adds aView (see View|addSubView:) so that it lies above lowerView" self insertSubView: aSubView before: lowerView ifCyclic: [self error: 'cycle in subView structure.']. aSubView align: aSubView viewport bottomLeft with: lowerView viewport topLeft.! insertSubView: aView before: anotherView ifCyclic: exceptionBlock "Remove aView from the tree of Views it is in (if any) and add it to the rear of the list of subViews of the receiver. Set the superView of aView to be the receiver. It is typically used to build up a hierarchy of Views (a structured picture). An error is generated if aView is the same as the receiver or its superView, etc." (self isCyclic: aView) ifTrue: [exceptionBlock value] ifFalse: [aView removeFromSuperView. subViews add: aView before: anotherView. aView superView: self]! ! !View methodsFor: 'subView removing'! releaseSubView: aView "Delete aView from the receiver's list of subViews and send it the message 'release' (so that it can break up cycles with subViews, etc.)" self removeSubView: aView. aView release! releaseSubViews "Release (see View|releaseSubView: ) all subViews in the receiver's list of subViews." subViews do: [:aView | aView release]. self resetSubViews! removeFromSuperView "Delete the receiver from its superView's collection of subViews." superView ~= nil ifTrue: [superView removeSubView: self]! removeSubView: aView "Remove aView from the receiver's list of subViews. If the list of subViews does not contain aView, an error window is created." subViews remove: aView. aView superView: nil. aView unlock! removeSubViews "Remove all the receiver's subViews." subViews do: [:aView | aView superView: nil. aView unlock]. self resetSubViews! ! !View methodsFor: 'displaying'! display "Display the receiver's border, model of the receiver, and then the sub views of the receiver." "Can be sent to the top View of a structured picture in order to display the entire structure, or to any particular View in the structure in order to display that View and its subViews. It is typically sent in response to an update request to a View." self displayBorder. self displayView. self displaySubViews! displayBorder "Display the receiver's border (using the receiver's borderColor)." self borderWidth = 0 ifTrue: [self insideColor == nil ifFalse: [Display fill: self displayBox mask: self insideColor]] ifFalse: [superView isNil ifTrue: [Display border: self displayBox widthRectangle: self borderWidth mask: borderColor] ifFalse: [Display border: self displayBox widthRectangle: self borderWidth mask: borderColor clippingBox: superView insetDisplayBox]. self insideColor == nil ifFalse: [Display fill: self insetDisplayBox mask: self insideColor]]! displaySafe: aBlock "Put the display of the receiver at the top of all views and evaluate the argument aBlock." self topView displaySafe: aBlock! displaySubViews "Display all the subViews of the receiver." subViews do: [:aSubView | aSubView display]! displayView "Subclasses should redefine View|displayView in order to display particular objects associated with the View such as labels, lines, boxes, etc." ^self! ! !View methodsFor: 'deEmphasizing'! deEmphasize "Modify the emphasis (highlighting, special tabs) of the receiver. This includes objects such as labels, lines, and boxes. Typically used so that the receiver is not presented as active. Do this for the receiver and then for each of the receiver's subViews." self deEmphasizeView. self deEmphasizeSubViews! deEmphasizeSubViews "Send the deEmphasize message to each of the receiver's subviews." subViews do: [:aSubView | aSubView deEmphasize]! deEmphasizeView "Subclasses should redefine View|deEmphasizeView in order to modify the emphasis (highlighting, special tabs) of particular objects associated with the View such as labels, lines, and boxes." ^self! emphasize "Modify the emphasis (highlighting, special tabs) of the receiver. This includes objects such as labels, lines, and boxes. Typically used so that the receiver is not presented as active. Do this for the receiver and then for each of the receiver's subViews." self emphasizeView. self emphasizeSubViews! emphasizeSubViews "Send the emphasize message to each of the receiver's subviews." subViews do: [:aSubView | aSubView emphasize]! emphasizeView "Subclasses should redefine View|emphasizeView in order to modify the emphasis (highlighting, special tabs) of particular objects associated with the View such as labels, lines, and boxes." ^self! ! !View methodsFor: 'display transformation'! displayTransform: anObject "Apply the display transformation of the receiver to anObject (see View|displayTransformation) and answer the resulting scaled, translated object. It is normally applied to Rectangles, Points, and other objects with coordinates defined in the View's local coordinate system in order to get a corresponding object in display coordinates." ^(self displayTransformation applyTo: anObject) rounded! displayTransformation "Answer a WindowingTransformation that is the result of composing all local transformations in the receiver's superView chain with the receiver's own local transformation. The resulting transformation transforms objects in the receiver's coordinate system into objects in the display screen coordinate system. " displayTransformation == nil ifTrue: [displayTransformation _ self computeDisplayTransformation]. ^displayTransformation! inverseDisplayTransform: aPoint "Answer a point that is obtained from aPoint by applying to it the inverse of the receiver's display transformation. It is typically used by the Controller of the receiver in order to convert a point in display coordinates, such as the cursor point, to the local coordinate system of the receiver." ^self displayTransformation applyInverseTo: aPoint! ! !View methodsFor: 'transforming'! align: aPoint1 with: aPoint2 "Add a translation of (aPoint2 - aPoint1) to the receiver's local transformation. The point in the receiver's coordinate system that previously was transformed to aPoint1 in the superView's coordinate system will now be transformed to aPoint2 in the superView's coordinate system. Other points will be translated by the same amount. It is normally used when adding subViews to their superView in order to line up the Viewport of one subView with that of another subView (see View|addSubView:align:with:). aPoint1 and aPoint2 are usually points on the viewports that are to be aligned. For example, 'subView2 align: subView2 viewport topLeft with: subView1 viewport topRight' would be used to place the viewport of subView2 next to the viewport of subView1 with the topLeft and topRight corners, respectively, coinciding. It is also possible to align the viewport of a subView with the window of the superView, e.g. 'subView align: subView viewport center with: superView window center'. View|align:with: assumes that the view has been properly scaled, if necessary, to match its superView (see View|scaleBy:). Typically, the coordinate systems of the receiver and its superView will differ only by a translation offset so that no scaling is necessary. " self setTransformation: (transformation align: aPoint1 with: aPoint2)! scale: aScale translation: aTranslation "The x component of aScale (a Point) specifies the scale (translation) in the x direction; the y component specifies the scale (translation) in the y direction. aScale can optionally be an instance of Integer or Float in order to specify uniform scaling in both directions. Create a new local transformation for the receiver with a scale factor of aScale and a translation offset of aTranslation. When the transformation is applied (see View|transform:), the scale is applied first, followed by the translation. It is typically used when building a superView from its subViews in order to line up the viewports of the subViews in the desired way. If no scaling is required between subView and superView, then View|align:with: is often more convenient to use." self setTransformation: (WindowingTransformation scale: aScale translation: aTranslation)! scaleBy: aScale "The x component of aScale (a Point) specifies the scale in the x direction; the y component specifies the scale in the y direction. aScale can, optionally, be an instance of Integer or Float in order to specify uniform scaling in both directions. Scales the View by aScale. The scale is concatenated with the current transformation of the receiver and is applied when View|transform is sent. This happens automatically in the process of displaying the receiver, for example." self setTransformation: (transformation scaleBy: aScale)! transform: anObject "Apply the local transformation of the receiver to anObject and answer the resulting transformation. It is used to get the superView coordinates of an object. For example, the viewport is equal to the window transformed." ^transformation applyTo: anObject! transformation "Answer a copy of the receiver's local transformation." ^transformation copy! transformation: aTransformation "Set the receiver's local transformation to a copy of aTransformation, unlock the receiver (see View|unlock) and set the viewport to undefined (this forces it to be recomputed when needed)." self setTransformation: aTransformation copy! translateBy: aPoint "Translate the receiver by aPoint. The translation is concatenated with the current transformation of the receiver and is applied when View|transform is sent. This happens automatically in the process of displaying the receiver." self setTransformation: (transformation translateBy: aPoint)! window: aWindow viewport: aViewport "Set the receiver's window to aWindow, set its viewport to aViewport, and create a new local transformation for the receiver based on aWindow and aViewport. The receiver is scaled and translated so that aWindow, when transformed, coincides with aViewport. It is used to position a subView's window within some specific region of its superView's area. For example, 'subView window: aRectangle1 viewport: aRectangle2' sets subView's window to aRectangle1, its viewport to aRectangle2, and its local transformation to one that transforms aRectangle1 to aRectange2." self window: aWindow. self setTransformation: (WindowingTransformation window: aWindow viewport: aViewport). self getViewport! ! !View methodsFor: 'bordering'! borderColor "Answer the receiver's border color." ^borderColor! borderColor: aColor "Set the receiver's border color to aColor." borderColor _ aColor! borderWidth "Answer either 0, indicating no border, or a Rectangle whose left value is the width in display coordinates of the receiver's left border. Right, top, and bottom widths are analogous. The border width is initially 0. A View with a border width of 0 will not have any border displayed." ^borderWidth! borderWidth: borderValue "Set the four border widths of the receiver to anInteger or rectangle." (borderValue isKindOf: Rectangle) ifTrue: [borderWidth _ borderValue. self unlock] ifFalse: [self borderWidthLeft: borderValue right: borderValue top: borderValue bottom: borderValue].! borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4 "Set the border widths of the receiver to a Rectangle made up of the four arguments. These arguements represent the left, right, top, and bottom border widths." borderWidth _ Rectangle left: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4. self unlock! insideColor "Answer the inside color of the receiver. The inside color determines the color of the inside of the receiver, which is the area inside the receiver's window excluding the border. The inside color is initially nil (meaning transparent), which means that when the receiver is displayed, the inside region will not be affected." ^insideColor! insideColor: aColor "Set the inside color of the receiver to be aColor." insideColor _ aColor! ! !View methodsFor: 'scrolling'! scrollBy: aPoint "The x component of aPoint specifies the amount of scrolling in the x direction; the y component specifies the amount of scrolling in the y direction. The amounts are specified in the receiver's local coordinate system. Scroll the receiver up or down, left or right. The window of the receiver is kept stationary and the subViews and other objects in the receiver are translated relative to it. Scrolling doesn't change the insetDisplayBox or the viewport since the change in the transformation is canceled by the change in the window. In other words, all display objects in the view, except the window, are translated by the scrolling operation." | aRectangle | aRectangle _ insetDisplayBox. transformation _ transformation scrollBy: aPoint. window _ self getWindow translateBy: aPoint x negated @ aPoint y negated. self unlock. insetDisplayBox _ aRectangle! ! !View methodsFor: 'clearing'! clear "Use the border color to paint the display box (including the border, see View|displayBox) of the receiver." borderColor ~= nil ifTrue: [self clear: borderColor]! clear: aColor "Use aColor to paint the display box (including the border, see View|displayBox) of the receiver." aColor ~= nil ifTrue: [Display fill: self displayBox mask: aColor]! clearInside "Use the inside color to paint the inset display box (excluding the border, see View|insetDisplayBox) of the receiver." self insideColor ~= nil ifTrue: [self clearInside: self insideColor]! clearInside: aColor "Use aColor to paint the inset display box (excluding the border, see View|insetDisplayBox) of the receiver." aColor ~= nil ifTrue: [Display fill: self insetDisplayBox mask: aColor]! ! !View methodsFor: 'indicating'! flash "Cause the inset display box (the display box excluding the border, see View|insetDisplayBox) of the receiver to complement twice in succession." Display flash: self insetDisplayBox! highlight "Cause the inset display box (the display box excluding the border, see View|insetDisplayBox) of the receiver to complement." Display reverse: self insetDisplayBox! ! !View methodsFor: 'updating'! update "Normally sent by the receiver's model in order to notify the receiver of a change in the model's state. Subclasses implement this message to do particular update actions." self update: self! update: aParameter "Normally sent by the receiver's model (via 'View|update') in order to notify the receiver that the state of the model has changed. View|update: should be redefined in a subclass if some specific action is to take place when the model changes. A typical action that might be required is to redisplay the receiver." ^self! ! !View methodsFor: 'private'! computeDisplayTransformation "Returns a WindowingTransformation that transforms the coordinate system of the View into that of the display screen. The transformation is computed by composing the View's transformation with all transformations along its superView chain. It is sent by View|displayTransformation when the View is unlocked (see View|unlock)." self isTopView ifTrue: [^transformation] ifFalse: [^superView displayTransformation compose: transformation]! computeInsetDisplayBox "Compute the View's inset display box by intersecting the superView's inset display box with the View's window transformed to display coordinates and then inseting the result by the border width. It is sent by View|insetDisplayBox if the inset display box is nil." self isTopView ifTrue: [^(self displayTransform: self getWindow) insetBy: self borderWidth] ifFalse: [^(superView insetDisplayBox intersect: (self displayTransform: self getWindow)) insetBy: self borderWidth]! getController "Returns the View's controller if one exists. nil indicates that the default controller is to be used." ^controller! getViewport "Returns the Rectangle representing the View's viewport (in the coordinate system of the superclass). If no viewport has been specified, the View's window transformed into the superView's coordinate system is saved and returned. It should be used by methods of View and subclasses (instead of directly referring to the viewport) unless it is known that a viewport actually exists. It should not be used outside of View or subclasses because the viewport is not sharable." viewport == nil ifTrue: [viewport _ self transform: self getWindow]. ^viewport! getWindow "Returns the Rectangle that represents the window of this View. If no window has been specified, a default window (see View|defaultWindow) is created, saved, and returned. Should be used by methods of View and subclasses to access the View window instead of directly accessing the field unless it is known that a window actually exists. It is not to be used outside of View (or subclasses) because the window is not sharable. View|window should be used for outside access to the window." window == nil ifTrue: [self setWindow: self defaultWindow]. ^window! inspect "Build an inspector of the receiver's model, the receiver as view, and my controller." | topView titleView className | topView _ StandardSystemView model: nil label: 'MVC inspector' minimumSize: 250 @ 250. titleView _ StringHolderView new. className _ model class name. titleView model: (StringHolder new contents: ' Model: ', ((className at: 1) isVowel ifTrue: ['an '] ifFalse: ['a ']), className). titleView controller: Controller new. topView addSubView: titleView in: (0@0 extent: 1@0.06) borderWidth: 1. InspectorView view: (Inspector inspect: model) in: (0@0.06 extent: 1@0.34) of: topView. titleView _ StringHolderView new. className _ self class name. titleView model: (StringHolder new contents: ' View: ', ((className at: 1) isVowel ifTrue: ['an '] ifFalse: ['a ']), className). titleView controller: Controller new. topView addSubView: titleView in: (0@0.4 extent: 1@0.06) borderWidth: 1. InspectorView view: (Inspector inspect: self) in: (0@0.46 extent: 1@0.24) of: topView. titleView _ StringHolderView new. className _ controller class name. titleView model: (StringHolder new contents: ' Controller: ', ((className at: 1) isVowel ifTrue: ['an '] ifFalse: ['a ']), className). titleView controller: Controller new. topView addSubView: titleView in: (0@0.7 extent: 1@0.06) borderWidth: 1. InspectorView view: (Inspector inspect: controller) in: (0@0.76 extent: 1@0.24) of: topView. topView controller open! isCyclic: aView "Answers true if aView is the same as this View or its superView, false otherwise. " self == aView ifTrue: [^true]. self isTopView ifTrue: [^false]. ^superView isCyclic: aView! setTransformation: aTransformation "Sets the View's local transformation to aTransformation, unlocks the View (see View|unlock) and sets the viewport to undefined (this forces it to be recomputed when needed). Should be used instead of setting the transformation directly." transformation _ aTransformation. self unlock. viewport _ nil! setWindow: aWindow "Sets the View's window to aWindow and unlocks the View (see View|unlock). View|setWindow should be used by methods of View and subclasses to set the View window (rather than directly setting the instance variable) to insure that the View is unlocked." window _ aWindow. viewport _ nil. self unlock! superView: aView "Sets the View's superView to aView and unlocks the View (see View|unlock). It is sent by View|addSubView: in order to properly set all the links." superView _ aView. self unlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! View class instanceVariableNames: ''! !View class methodsFor: 'instance creation'! identityTransformation "Answer an instance of me with no translation and unity scaling. " ^WindowingTransformation identity! new "Answer an initialized instance of me. The transformation is an identity transformation, the borderWidth is 0, the borderColor is black, and the insideColor is transparent." ^super new initialize! ! Object subclass: #WindowingTransformation instanceVariableNames: 'scale translation ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Framework'! WindowingTransformation comment: 'An instance of WindowingTransformation is used to transform objects from a source coordinate system to a destination coordinate system. WindowingTransformation contains a scale and a translation which can be applied to objects that respond to scaleBy: and translateBy:. An instance can be created with a default identity scale and translation, or with a specified scale and translation, or with a scale and translation computed from a window (a Rectangle in the source coordinate system) and a viewport (a Rectangle in the destination coordinate system). In applying a WindowingTransformation to an object, the object is first scaled (around the origin of the source coordinate system) and then translated. WindowingTransformations can be composed to form a single compound transformation. Instance Variables: scale translation '! !WindowingTransformation methodsFor: 'scrolling'! scrollBy: aPoint "Answer a new WindowingTransformation with the same scale as the receiver and with a translation of the current translation plus aPoint scaled by the current scale. It is used when the translation is known in source coordinates, rather than scaled source coordinates (see WindowingTransformation|translateBy:). An example is that of scrolling objects with respect to a stationary window in the source coordinate system. If no scaling is in effect (scale = nil), then WindowingTransformation|translateBy: and WindowingTransformation|scrollBy: are equivalent." | newTranslation | scale == nil ifTrue: [newTranslation _ aPoint] ifFalse: [newTranslation _ scale * aPoint]. ^self translateBy: newTranslation! ! !WindowingTransformation methodsFor: 'transforming'! align: point1 with: point2 "Answer a new WindowingTransformation with the same scale as the receiver and with a translation of (aPoint2 - aPoint1). It is normally used when the source and destination coordinate systems are scaled the same (that is, there is no scaling between them), and is then a convenient way of specifying a translation, given two points that are intended to coincide." ^self translateBy: point2 - point1! noScale "Answer true if the identity scale is in effect; answer false, otherwise." ^scale == nil! scale "Answer a copy of the point that represents the current scale of the receiver." scale == nil ifTrue: [^1.0 @ 1.0] ifFalse: [^scale copy]! scaleBy: aScale "Answer a new WindowingTransformation with the scale and translation of the receiver both scaled by aScale." | checkedScale newScale newTranslation | aScale == nil ifTrue: [newScale _ scale. newTranslation _ translation] ifFalse: [checkedScale _ self checkScale: aScale. scale == nil ifTrue: [newScale _ checkedScale] ifFalse: [newScale _ scale * checkedScale]. newTranslation _ checkedScale * translation]. ^WindowingTransformation scale: newScale translation: newTranslation! scaleOfOne scale _ 1.0 @ 1.0.! translateBy: aPoint "Answer a new WindowingTransformation with the same scale as the receiver and with a translation of the current translation plus aPoint. It is used when the translation is known in scaled source coordinates, rather than source coordinates (see WindowingTransformation|scrollBy:). If no scaling is in effect (scale = nil), then WindowingTransformation|translateBy: and WindowingTransformation|scrollBy: are equivalent." ^WindowingTransformation scale: scale translation: translation + aPoint! translation "Answer a copy of the receiver's translation." ^translation copy! ! !WindowingTransformation methodsFor: 'applying transform'! applyInverseTo: anObject "Apply the inverse of the receiver to anObject and answer the result. Used to map some object in destination coordinates to one in source coordinates." | transformedObject | transformedObject _ anObject translateBy: translation x negated @ translation y negated. scale == nil ifFalse: [transformedObject _ transformedObject scaleBy: 1.0 / scale x @ (1.0 / scale y)]. ^transformedObject! applyTo: anObject "Apply the receiver to anObject and answer the result. Used to map some object in source coordinates to one in destination coordinates." | transformedObject | scale == nil ifTrue: [transformedObject _ anObject] ifFalse: [transformedObject _ anObject scaleBy: scale]. transformedObject _ transformedObject translateBy: translation. ^transformedObject! compose: aTransformation "Answer a new WindowingTransformation that is the composition of the receiver and aTransformation. The effect of applying the resulting WindowingTransformation to an object is the same as that of first applying aTransformation to the object and then applying the receiver to its result." | aTransformationScale newScale newTranslation | aTransformationScale _ aTransformation scale. scale == nil ifTrue: [aTransformation noScale ifTrue: [newScale _ nil] ifFalse: [newScale _ aTransformationScale]. newTranslation _ translation + aTransformation translation] ifFalse: [aTransformation noScale ifTrue: [newScale _ scale] ifFalse: [newScale _ scale * aTransformationScale]. newTranslation _ translation + (scale * aTransformation translation)]. ^WindowingTransformation scale: newScale translation: newTranslation! ! !WindowingTransformation methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." aStream nextPutAll: self class name, ' scale: '; print: scale; nextPutAll: ' translation: '; print: translation! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates a windowing transformation similar to the receiver. The general format is (class-name scale: scale translation: translation)." aStream nextPut: $(; nextPutAll: self species name; nextPutAll: ' scale: '; store: scale; cr; nextPutAll: ' translation: '; store: translation; nextPut: $).! ! !WindowingTransformation methodsFor: 'private'! checkScale: aScale "Converts aScale to the internal format of a floating-point Point." | checkedScale | checkedScale _ aScale asPoint. ^checkedScale x asFloat @ checkedScale y asFloat! setScale: aScale translation: aTranslation "Sets the scale to aScale and the translation to aTranslation." scale _ aScale. translation _ aTranslation! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WindowingTransformation class instanceVariableNames: ''! !WindowingTransformation class methodsFor: 'instance creation'! identity "Answer an instance of me with no scaling (nil) and no translation (0@0)." ^self new setScale: nil translation: 0 @ 0! scale: aScale translation: aTranslation "Answer an instance of me with a scale factor of aScale and a translation offset of aTranslation. When the transformation is applied (see WindowingTransformation|apply:), the scale is applied first, followed by the translation." ^self new setScale: aScale translation: aTranslation! window: aWindow viewport: aViewport "Answer an instance of me with a scale and translation based on aWindow and aViewport. The scale and translation are computed such that aWindow, when transformed, coincides with aViewport. " | scale translation | aViewport width = aWindow width & (aViewport height = aWindow height) ifTrue: [scale _ nil] ifFalse: [scale _ aViewport width asFloat / aWindow width asFloat @ (aViewport height asFloat / aWindow height asFloat)]. scale == nil ifTrue: [translation _ aViewport left - aWindow left @ (aViewport top - aWindow top)] ifFalse: [translation _ aViewport left - (scale x * aWindow left) @ (aViewport top - (scale y * aWindow top))]. ^self new setScale: scale translation: translation! ! ArrayedCollection variableWordSubclass: #WordArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Support'! WordArray comment: 'Class WordArray provides contiguous storage of data, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions. Instance Variables: *word indexed*'! !WordArray methodsFor: 'initialize-release'! fromByteStream: aStream "Initialize the array of bits by reading integers from the Stream, aStream." | high low | 1 to: self size do: [:i | high _ aStream next asInteger. "be cautious, it may be a char" low _ aStream next asInteger. self at: i put: (high bitShift: 8) + low]! ! !WordArray methodsFor: 'bit counting'! countBits "Answer the number of on bits (1's) in the receiver." | count bitMask | count _ 0. self do: [:word | bitMask _ 1. word highBit timesRepeat: [(word bitAnd: bitMask) ~= 0 ifTrue: [count _ count + 1]. bitMask _ bitMask bitShift: 1]]. ^count! ! !WordArray methodsFor: 'printing'! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." aStream nextPutAll: 'a WordArray of length '. self size printOn: aStream! ! !WordArray methodsFor: 'filing'! toStream: aStream "Store the array of bits onto the Stream, aStream." 1 to: self size do: [:i | aStream nextPut: ((self at: i) bitShift: -8). aStream nextPut: ((self at: i) bitAnd: 255)]! ! PositionableStream subclass: #WriteStream instanceVariableNames: 'writeLimit ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! WriteStream comment: 'Instances of WriteStream are writers of an indexable collection. Instance Variable: writeLimit writeLimit marks the farthest that has been written into the collection, not the actual size of the collection.'! !WriteStream methodsFor: 'accessing'! contents "Answer the contents of the collection." readLimit _ readLimit max: position. ^collection copyFrom: 1 to: position! next "Provide an error notification that WriteStreams do not permit read access." self shouldNotImplement! nextPut: anObject "Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. Optional. See Object documentation whatIsAPrimitive." position = writeLimit ifTrue: [^self pastEndPut: anObject] ifFalse: [^collection at: (position _ position + 1) put: anObject]! size "Answer how many elements the receiver contains." ^readLimit _ readLimit max: position! ! !WriteStream methodsFor: 'positioning'! position: anInteger "Set position to anInteger as long as anInteger is within the bounds of the receiver's contents. If it is not, provide an error notification." readLimit _ readLimit max: position. super position: anInteger! reset "Set the read limit to its maximum position and the receiver's access position to 0." readLimit _ readLimit max: position. position _ 0! ! !WriteStream methodsFor: 'character writing'! cr "Append a return character to the receiver." self nextPut: Character cr! crtab "Append a return character, followed by a single tab character, to the receiver." self nextPut: Character cr. self nextPut: Character tab! crtab: anInteger "Append a return character, followed by anInteger tab characters, to the receiver." self nextPut: Character cr. anInteger timesRepeat: [self nextPut: Character tab]! emphasis "Answer 1." "Allows compatibility with streams which carry emphasis" ^ 1! emphasis: ignored "Ignore this message." "Allows compatibility with streams which carry emphasis" ^self! space "Append a space character to the receiver." self nextPut: Character space! tab "Append a tab character to the receiver." self nextPut: Character tab! ! !WriteStream methodsFor: 'printing'! print: anObject "Have anObject print on the receiver." anObject printOn: self! store: anObject "Have anObject print on the receiver for rereading." anObject storeOn: self! ! !WriteStream methodsFor: 'fileIn/Out'! nextChunkPut: aString "Put aString onto self, doubling embedded terminators." | index stringSize char terminator | terminator _ $!!. index _ 0. stringSize _ aString size. [(index _ index + 1) <= stringSize] whileTrue: [char _ aString at: index. self nextPut: char. char == terminator ifTrue: ["double imbedded terminator" self nextPut: char]]. self nextPut: terminator! ! !WriteStream methodsFor: 'private'! on: aCollection "Initialize the instance variables." super on: aCollection. readLimit _ 0. writeLimit _ aCollection size! on: aCollection from: firstIndex to: lastIndex "Initialize the instance variables." | len | collection _ aCollection. readLimit _ writeLimit _ lastIndex > (len _ collection size) ifTrue: [len] ifFalse: [lastIndex]. position _ firstIndex <= 1 ifTrue: [0] ifFalse: [firstIndex - 1]! pastEndPut: anObject "Expand the collection and reset the pointers." collection grow. writeLimit _ collection size. collection at: (position _ position + 1) put: anObject! with: aCollection "Initialize the instance variables." super on: aCollection. position _ readLimit _ writeLimit _ aCollection size! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WriteStream class instanceVariableNames: ''! !WriteStream class methodsFor: 'instance creation'! on: aCollection from: firstIndex to: lastIndex "Answer a new instance streaming over a copy of aCollection from firstIndex to lastIndex." ^self basicNew on: aCollection from: firstIndex to: lastIndex! with: aCollection "Answer a new instance of the receiver streaming on aCollection. Assume that the collection is already full so the position and the limits are set to the end." ^self basicNew with: aCollection! with: aCollection from: firstIndex to: lastIndex "Answer a new instance of the receiver streaming on the subcollection of aCollection, starting at index firstIndex and ending at lastIndex. Assume that the resulting collection is already full so the position and the limits are set to the end." ^self basicNew with: (aCollection copyFrom: firstIndex to: lastIndex)! !