'From Pharo1.4a of ''16 June 2011'' [Latest update: #14415] on 29 March 2012 at 11:18:42 pm'! "Change Set: Ti-Support Date: 5 November 1999 Author: Francisco Garau Needed by ChangeSet Ti-Engine. Extensions to existing classes to support type inference. "! !Object methodsFor: 'printing' stamp: 'fg 5/6/2001 18:56'! printStringLimitedTo: limit "Answer a String whose characters are a description of the receiver. If you want to print without a character limit, use fullPrintString." | limitedString | limitedString := String streamContents: [:s | self printOn: s] limitedTo: limit. limitedString size < limit ifTrue: [^ limitedString]. ^ limitedString , '..' ! ! !Object methodsFor: 'type inference' stamp: 'fg 8/10/2001 13:16'! concreteType ^ TiSystem current addType: (self class concreteTypeClass new setObject: self) ! ! !Object methodsFor: 'type inference' stamp: 'fg 3/7/2001 00:50'! isNodeSuper ^ false! ! !Point methodsFor: 'converting' stamp: 'fg 2/17/2001 22:36'! asTPoint " (3@4) asTPoint " ^ TPoint new setX: x y: y ! ! !SequenceableCollection methodsFor: 'converting' stamp: 'LC 2/3/1999 19:58'! cartesianProduct | m answer | self isEmpty ifTrue: [^ #()]. m := self inject: 1 into: [:r :col | r * col size]. m = 0 ifTrue: [^ #()]. answer := OrderedCollection new: m. self cartesianProductDo: [:each | answer add: each]. ^ answer! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'LC 2/3/1999 19:52'! cartesianProductDo: aBlock | n index sizes k array s indexk | n := self size. n = 0 ifTrue: [^ self]. index := (Array new: n) atAllPut: 1. sizes := self collect: [:each | (s := each size) = 0 ifTrue: [^ self]. s]. [array := Array new: n. 1 to: n do: [:i | array at: i put: ((self at: i) at: (index at: i))]. aBlock value: array. (k := (n to: 1 by: -1) detect: [:i | (indexk := index at: i) < (sizes at: i)] ifNone: []) isNil] whileFalse: [k + 1 to: n do: [:i | index at: i put: 1]. index at: k put: indexk + 1]! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'th 1/6/2000 17:01'! with: otherCollection allSatisfy: twoArgBlock "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection. In analogy with allSatisfy." otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. 1 to: self size do: [:index | (twoArgBlock value: (self at: index) value: (otherCollection at: index)) ifFalse:[^false]]. ^true! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'th 1/6/2000 17:01'! with: otherCollection anySatisfy: twoArgBlock "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection. In analogy with anySatisfy." otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. 1 to: self size do: [:index | (twoArgBlock value: (self at: index) value: (otherCollection at: index)) ifTrue:[^true]]. ^false! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'fg 11/10/1999 13:15'! allPrimitiveMessages "Answer an OrderedCollection of all the methods that are implemented by primitives." | aColl method primitive | aColl := Dictionary new. Cursor execute showWhile: [self allBehaviorsDo: [:class | class selectorsDo: [:sel | method := class compiledMethodAt: sel. primitive := method primitive. (primitive > 0 and: [(primitive between: 255 and: 519) not]) ifTrue: [(aColl at: primitive ifAbsentPut: [OrderedCollection new]) add: (class name , ' ' , sel)]]]]. ^aColl! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'fg 11/10/1999 16:12'! panchoMajorShrink "Smalltalk panchoMajorShrink; abandonSources; lastRemoval" "This method throws out lots of the system that is not needed for, eg, operation in a hand-held PC. Currently, since it discards Morphic, majorShrink must be run in an MVC project. Moreover, since it throws out projects, it shouod be run in the top (and only) project. majorShrink altogether saves about 5,620k in Squeak 2.4" "First delete all the PlayWithMe windows and projects, and the class Component1" Wonderland removeActorPrototypesFromSystem. Player freeUnreferencedSubclasses. MorphicModel removeUninstantiatedModels. Utilities classPool at: #ScrapsBook put: nil. "Smalltalk discardVMConstruction. 666k" Smalltalk discardSoundSynthesis. "358k" Smalltalk discardOddsAndEnds. "158k" Smalltalk discardNetworking. "243k" Smalltalk discardMorphic. "2,494k" SystemOrganization removeSystemCategory: 'VRML-BaseNodes'. SystemOrganization removeSystemCategory: 'VRML-Definition'. SystemOrganization removeSystemCategory: 'Squeak-Applescript'. Symbol rehash. "40k" "Above by itself saves about 3,960k" " | a | a := Smalltalk garbageCollect. Smalltalk majorShrink. Smalltalk garbageCollect - a " "Remove references to a few classes to be deleted, so that they won't leave obsolete versions around." FileList removeSelector: #fileIntoNewChangeSet. ChangeSet class compile: 'defaultName ^ ''Changes'' ' classified: 'initialization'. ScreenController removeSelector: #openChangeManager. ScreenController removeSelector: #exitProject. ScreenController removeSelector: #openProject. ScreenController removeSelector: #viewImageImports. "Now delete lots of classes.." SystemOrganization removeSystemCategory: 'Graphics-Symbols'. SystemOrganization removeSystemCategory: 'Graphics-Files'. SystemOrganization removeSystemCategory: 'Interface-Projects'. SystemOrganization removeSystemCategory: 'System-Object Storage'. Smalltalk removeClassNamed: #FormSetFont. Smalltalk removeClassNamed: #FontSet. Smalltalk removeClassNamed: #InstructionPrinter. Smalltalk removeClassNamed: #ChangeSorter. Smalltalk removeClassNamed: #DualChangeSorter. Smalltalk removeClassNamed: #EmphasizedMenu. Smalltalk removeClassNamed: #MessageTally. StringHolder class removeSelector: #originalWorkspaceContents. CompiledMethod removeSelector: #symbolic. RemoteString removeSelector: #makeNewTextAttVersion. Utilities class removeSelector: #absorbUpdatesFromServer. Smalltalk removeClassNamed: #PenPointRecorder. Smalltalk removeClassNamed: #Path. Smalltalk removeClassNamed: #Base64MimeConverter. Smalltalk removeClassNamed: #EToySystem. Smalltalk removeClassNamed: #RWBinaryOrTextStream. Smalltalk removeClassNamed: #AttributedTextStream. Smalltalk removeClassNamed: #CornerRounder. Smalltalk removeClassNamed: #WordNet. Smalltalk removeClassNamed: #SelectorBrowser. TextStyle allSubInstancesDo: [:ts | ts newFontArray: (ts fontArray copyFrom: 1 to: (2 min: ts fontArray size))]. ListParagraph initialize. PopUpMenu initialize. StandardSystemView initialize. Smalltalk noChanges. ChangeSorter classPool at: #AllChangeSets put: (OrderedCollection with: Smalltalk changes). ScriptingSystem := nil. SystemDictionary removeSelector: #majorShrink. [Smalltalk removeAllUnSentMessages > 0] whileTrue: [Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]]. SystemOrganization removeEmptyCategories. Smalltalk allClassesDo: [:c | c zapOrganization]. Symbol rehash.! ! !Behavior methodsFor: 'type inference' stamp: 'fg 12/8/1999 20:17'! classImplementingSelector: selector "Idem as Behavior|#lookupSelector: but answer the class." | lookupClass | lookupClass := self. [lookupClass == nil] whileFalse: [(lookupClass includesSelector: selector) ifTrue: [^ lookupClass]. lookupClass := lookupClass superclass]. ^ nil! ! !Behavior methodsFor: 'type inference' stamp: 'fg 8/10/2001 13:18'! concreteTypeClass ^ (self isVariable & self isPointers) ifTrue: [TiIndexedType] ifFalse: [TiObjectType]! ! !Behavior methodsFor: 'type inference' stamp: 'fg 8/10/2001 13:19'! createInitializedType: typesArray ^ TiSystem current addType: (self concreteTypeClass new setClass: self initializedWith: typesArray)! ! !Behavior methodsFor: 'type inference' stamp: 'fg 8/10/2001 13:19'! createType ^ TiSystem current addType: (self concreteTypeClass new setClass: self)! ! !Behavior methodsFor: 'type inference' stamp: 'fg 12/3/1999 14:46'! isVariableByteOrWord ^ self isVariable & self isBits! ! !Preferences class methodsFor: 'standard preferences' stamp: 'fg 12/22/1999 20:06'! inferLargeIntegers ^ self valueOfFlag: #inferLargeIntegers! ! !WriteStream methodsFor: 'printing' stamp: 'fg 5/3/2001 01:51'! print: anObject anObject printOn: self! ! !WriteStream methodsFor: 'printing' stamp: 'fg 12/23/1999 19:36'! printCollection: aCollection inside: startCharacter and: endCharacter self nextPut: startCharacter. aCollection isEmptyOrNil ifTrue: [self nextPut: endCharacter. ^ self] ifFalse: [aCollection do: [:each | self print: each; space]]. self skip: -1. self nextPut: endCharacter. ! ! !Compiler methodsFor: 'public access' stamp: 'fg 8/10/2001 13:32'! analyze: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock "same as Compiler evaluate:in:to:notifying:ifFail: but analyzing the method node for type inference" | methodNode | 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]. ^ (TiSystem current compiler replicateMethodNode: methodNode) analyzedMethod makeConnections; seedArguments: (Array with: receiver concreteType) ! ! !Set methodsFor: 'adding' stamp: 'go 10/1/97 09:33'! add: newObject "Add an element. User error instead of halt. go 10/1/97 09:33" | index | newObject == nil ifTrue: [self error: 'Sets cannot meaningfully contain nil as an element']. index := self findElementOrNil: newObject. (array at: index) == nil ifTrue: [self atNewIndex: index put: newObject]. ^ newObject! ! !Set methodsFor: 'adding' stamp: 'fg 12/6/1999 16:56'! add: newObject ifPresent: aBlock | index | newObject == nil ifTrue: [self error: 'Sets cannot meaningfully contain nil as an element']. index := self findElementOrNil: newObject. (array at: index) == nil ifTrue: [self atNewIndex: index put: newObject] ifFalse: [aBlock value]. ^ newObject! ! !Set methodsFor: 'adding' stamp: 'fg 12/6/1999 17:06'! addReturningExisting: newObject | index | newObject == nil ifTrue: [self error: 'Sets cannot meaningfully contain nil as an element']. index := self findElementOrNil: newObject. ^ (array at: index) == nil ifTrue: [self atNewIndex: index put: newObject. newObject] ifFalse: [array at: index]. ! ! !Set methodsFor: 'testing' stamp: 'fg 12/6/1999 18:01'! includes: anObject ^ (array at: (self findElementOrNil: anObject)) notNil! ! !Set methodsFor: 'private' stamp: 'fg 5/9/1999 21:45'! getIndexToAdd: newObject newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. ^ self findElementOrNil: newObject! ! !ParseNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:06'! mirrorIn: aTiCompiler "Send the appropiate messages to aTiCompiler so that it can replicate my structure" self subclassResponsibility! ! !MessageNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:04'! mirrorIn: aTiCompiler ^ aTiCompiler buildMessage: selector key asSymbol receiver: receiver arguments: arguments! ! !VariableNode methodsFor: 'type inference' stamp: 'fg 5/20/1999 12:56'! isInstanceVariable ^ self type = LdInstType! ! !VariableNode methodsFor: 'type inference' stamp: 'LC 2/3/1999 13:56'! isSharedVarNode ^ self type = 4 and: [key class == Association]! ! !VariableNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:08'! mirrorIn: aTiCompiler "true false and nil should be LiteralNode. see DecompilerConstructor codeConstants " | symbolName | self == NodeTrue ifTrue: [^ aTiCompiler buildLiteral: true]. self == NodeFalse ifTrue: [^ aTiCompiler buildLiteral: false]. self == NodeNil ifTrue: [^ aTiCompiler buildLiteral: nil]. symbolName := name asSymbol. symbolName = #self ifTrue: [^ aTiCompiler nodeSelf]. symbolName = #super ifTrue: [^ aTiCompiler nodeSuper]. self isInstanceVariable ifTrue: [^ aTiCompiler instanceVariable: symbolName]. self isArg ifTrue: [^ aTiCompiler argumentVariable: symbolName]. self isSharedVarNode ifTrue: [^ aTiCompiler sharedVariableAt: key value named: symbolName]. ^ aTiCompiler localVariable: symbolName! ! !MethodNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:05'! mirrorIn: aTiCompiler ^ aTiCompiler buildMethod: self selector arguments: arguments temporaries: temporaries block: block primitive: primitive ! ! !ReturnNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:06'! mirrorIn: aTiCompiler ^ aTiCompiler buildReturn: expr ! ! !CascadeNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:04'! mirrorIn: aTiCompiler ^ aTiCompiler buildCascade: receiver messages: messages! ! !AssignmentNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:04'! mirrorIn: aTiCompiler ^ aTiCompiler buildAssignFromExpression: value toVariable: variable ! ! !BlockNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:04'! mirrorIn: aTiCompiler ^ aTiCompiler buildBlock: statements arguments: arguments ! ! !LiteralNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:04'! mirrorIn: aTiCompiler ^ aTiCompiler buildLiteral: key! ! !Symbol methodsFor: 'type inference' stamp: 'fg 8/10/2001 13:17'! concreteType ^ TiSymbolType new setSymbol: self sharedType: (TiSystem current addType: (self class concreteTypeClass new setObject: self)) ! ! !BraceNode methodsFor: 'type inference' stamp: 'fg 2/20/2001 21:04'! mirrorIn: aTiCompiler ^ aTiCompiler buildBrace: elements! ! "Postscript: Leave the line above, and replace the rest of this comment by a useful one. Executable statements should follow this comment, and should be separated by periods, with no exclamation points (!!). Be sure to put any further comments in double-quotes, like this one." " ParagraphEditor initializeTextEditorMenus. ParagraphEditor initializeCmdKeyShortcuts. " !