'From Pharo2.0a of ''18 April 2012'' [Latest update: #20582] on 4 March 2013 at 2:54:09 pm'! BracketSliderMorph subclass: #AColorSelectorMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! ColorComponentSelector showing an alpha gradient over a hatched background.! !AColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/3/2009 13:43'! color: aColor "Set the gradient colors." super color: aColor asNontranslucentColor. self fillStyle: self defaultFillStyle! ! !AColorSelectorMorph methodsFor: 'drawing' stamp: 'gvc 9/19/2006 14:28'! drawOn: aCanvas "Draw a hatch pattern first." aCanvas fillRectangle: self innerBounds fillStyle: (InfiniteForm with: self hatchForm). super drawOn: aCanvas ! ! !AColorSelectorMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 11:54'! initialize "Initialize the receiver." super initialize. self value: 1.0; color: Color black! ! !AColorSelectorMorph methodsFor: 'protocol' stamp: 'gvc 9/3/2009 13:43'! defaultFillStyle "Answer the hue gradient." ^(GradientFillStyle colors: {self color alpha: 0. self color}) origin: self topLeft; direction: (self bounds isWide ifTrue: [self width@0] ifFalse: [0@self height])! ! !AColorSelectorMorph methodsFor: 'visual properties' stamp: 'gvc 9/19/2006 15:46'! fillStyle: fillStyle "If it is a color then override with gradient." fillStyle isColor ifTrue: [self color: fillStyle] ifFalse: [super fillStyle: fillStyle]! ! !AColorSelectorMorph methodsFor: 'private' stamp: 'gvc 9/22/2006 09:17'! hatchForm "Answer a form showing a grid hatch pattern." ^ColorPresenterMorph hatchForm! ! AbstractGroupAnnouncement subclass: #AGroupHasBeenAdded instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGroupHasBeenAdded class instanceVariableNames: ''! !AGroupHasBeenAdded class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 16:32'! group: aGroup into: anHolder ^ self group: aGroup from: anHolder! ! AbstractGroupAnnouncement subclass: #AGroupHasBeenCreated instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! AbstractGroupAnnouncement subclass: #AGroupHasBeenRegistered instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! !AGroupHasBeenRegistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group ^ group! ! !AGroupHasBeenRegistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group: anObject group := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGroupHasBeenRegistered class instanceVariableNames: ''! !AGroupHasBeenRegistered class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:40'! with: aGroup ^ self new group: aGroup! ! AbstractGroupAnnouncement subclass: #AGroupHasBeenRemoved instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! AbstractGroupAnnouncement subclass: #AGroupHasBeenRenamed instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! AbstractGroupAnnouncement subclass: #AGroupHasBeenUnregistered instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! !AGroupHasBeenUnregistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group ^ group! ! !AGroupHasBeenUnregistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group: anObject group := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGroupHasBeenUnregistered class instanceVariableNames: ''! !AGroupHasBeenUnregistered class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:40'! with: aGroup ^ self new group: aGroup! ! AJInstruction subclass: #AJAlignmentInstruction instanceVariableNames: 'alignTo' classVariableNames: '' poolDictionaries: 'AJConstants' category: 'AsmJit-Instructions'! !AJAlignmentInstruction commentStamp: '' prior: 0! I am a pseudo instruction used to align the following instruction to a multiple of a given byte number. Example: asm := AJx64Assembler noStackFrame. "align the following instruction to a word (2bytes)" asm alignWord. asm inc: asm RAX. "align the following instruction to a double (4bytes)" asm alignDouble. asm inc: asm RAX. "align the following instruction to a QuadWord (8bytes)" asm alignQuad. asm inc: asm RAX. "align the following instruction to a multiple of an arbirary count" asm align: 64. asm inc: asm RAX.! !AJAlignmentInstruction methodsFor: 'accessing'! align ^ alignTo! ! !AJAlignmentInstruction methodsFor: 'accessing'! align: bytesSize "align the data to the given byte count" alignTo := bytesSize! ! !AJAlignmentInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 13:56'! name ^ String streamContents: [ :s| self printSelfOn: s]! ! !AJAlignmentInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 13:55'! printSelfOn: aStream self align <= 1 ifTrue: [ ^ self ]. aStream nextPut: $|. self align <= 8 ifTrue: [ self align timesRepeat: [ aStream nextPutAll: '----|']] ifFalse: [ aStream nextPutAll: (self align asString padded: #left to: 4 with: $ ); nextPut: $|]! ! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignByte self align: 1! ! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignDouble self align: 4! ! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignQuad self align: 8! ! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignWord self align: 2! ! !AJAlignmentInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 4/12/2012 13:44'! emitCode: asm | padding | padding := self paddingForPosition: position. "new machine code: | padding |" machineCode := ByteArray new: padding .! ! !AJAlignmentInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 4/12/2012 13:50'! paddingForPosition: aPositionNumber | padding | padding := aPositionNumber \\ self align. padding = 0 ifFalse: [ padding := self align - padding ]. ^ padding! ! !AJAlignmentInstruction methodsFor: 'initialize-release'! initialize super initialize. self alignByte.! ! !AJAlignmentInstruction methodsFor: 'visitor' stamp: 'CamilloBruni 4/12/2012 13:38'! accept: anObject self shouldBeImplemented ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJAlignmentInstruction class instanceVariableNames: ''! !AJAlignmentInstruction class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/12/2012 13:50'! align: byteSize ^ self new align: byteSize! ! !AJAlignmentInstruction class methodsFor: 'instance creation'! alignDouble ^ self new alignDouble! ! !AJAlignmentInstruction class methodsFor: 'instance creation'! alignQuad ^ self new alignQuad! ! !AJAlignmentInstruction class methodsFor: 'instance creation'! alignWord ^ self new alignWord! ! Object subclass: #AJAssembler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Core'! AJOperand subclass: #AJBaseReg instanceVariableNames: 'size code name' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJBaseReg methodsFor: 'accessing'! code "Answer the value of code" ^ code! ! !AJBaseReg methodsFor: 'accessing'! code: anObject "Set the value of code" code := anObject! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 11:07'! description ^ String streamContents: [ :s | self descriptionOn: s ].! ! !AJBaseReg methodsFor: 'accessing'! index ^ code bitAnd: RegCodeMask! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 11:24'! influencingRegisters ^ #()! ! !AJBaseReg methodsFor: 'accessing'! name ^ name! ! !AJBaseReg methodsFor: 'accessing'! size ^ size! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:59'! type ^ code bitAnd: RegTypeMask! ! !AJBaseReg methodsFor: 'comparing'! = otherReg ^ (self class == otherReg class) and: [ code = otherReg code ]! ! !AJBaseReg methodsFor: 'comparing'! hash ^ code hash! ! !AJBaseReg methodsFor: 'initialize-release'! initializeWithCode: aRegisterCode name: aSymbol super initialize. code := aRegisterCode. name := aSymbol! ! !AJBaseReg methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:07'! descriptionOn: aStream self subclassResponsibility! ! !AJBaseReg methodsFor: 'testing'! isGeneralPurpose self subclassResponsibility ! ! !AJBaseReg methodsFor: 'testing'! isUpperBank "Used for emitting the REX Prefix Byte on 64bit machines" ^ self index > 7! ! !AJBaseReg methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 10:58'! isX86 "Return whether this register is available in the standard x86 instruction set" ^ self isUpperBank not and: [ self is64 not ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJBaseReg class instanceVariableNames: ''! !AJBaseReg class methodsFor: 'instance creation'! code: aRegisterCode name: aSymbol ^ self basicNew initializeWithCode: aRegisterCode name: aSymbol! ! AJStackInstruction subclass: #AJCallArgument instanceVariableNames: 'size stackOffset first' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCallArgument methodsFor: 'accessing'! instructionName ^ #push! ! !AJCallArgument methodsFor: 'accessing'! name ^ 'argument push:'! ! !AJCallArgument methodsFor: 'accessing'! size ^ size ! ! !AJCallArgument methodsFor: 'accessing'! size: aSmallInteger size := aSmallInteger! ! !AJCallArgument methodsFor: 'accessing'! stackOffset: anOffset stackOffset := anOffset ! ! !AJCallArgument methodsFor: 'function calls'! prepareCallAlignments callInfo noticeArgument: self ! ! !AJCallArgument methodsFor: 'visitor'! accept: anObject ^ anObject visitCallArgument: self ! ! AJStackInstruction subclass: #AJCallCleanup instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCallCleanup methodsFor: 'accessing'! callInfo ^ callInfo! ! !AJCallCleanup methodsFor: 'accessing'! callInfo: anObject callInfo := anObject! ! !AJCallCleanup methodsFor: 'accessing'! name ^ 'call cleanup'! ! !AJCallCleanup methodsFor: 'function calls'! prepareCallAlignments callInfo callCleanup: self ! ! !AJCallCleanup methodsFor: 'visitor'! accept: anObject ^ anObject visitCallCleanup: self! ! Object subclass: #AJCallInfo instanceVariableNames: 'asm stackAlignment stackSize arguments callCleanup prepareForCall noCleanup alignInsertionPoint' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCallInfo methodsFor: 'accessing'! alignment: aStackAlignment stackAlignment := aStackAlignment ! ! !AJCallInfo methodsFor: 'accessing'! alignmentInsertionPoint: instruction alignInsertionPoint := instruction! ! !AJCallInfo methodsFor: 'accessing'! asm: assembler asm := assembler! ! !AJCallInfo methodsFor: 'accessing'! callCleanup: aCallCleanup self assert: callCleanup isNil. callCleanup := aCallCleanup ! ! !AJCallInfo methodsFor: 'accessing'! defaultArgumentSize self subclassResponsibility ! ! !AJCallInfo methodsFor: 'accessing'! disableCleanup noCleanup := true! ! !AJCallInfo methodsFor: 'accessing'! name ^ 'call info' ! ! !AJCallInfo methodsFor: 'accessing'! noCleanup ^ noCleanup ! ! !AJCallInfo methodsFor: 'accessing'! noticeArgument: aCallArgument arguments add: aCallArgument. stackSize := stackSize + aCallArgument size.! ! !AJCallInfo methodsFor: 'accessing'! stackSize ^ stackSize! ! !AJCallInfo methodsFor: 'accessing'! stackSize: anObject stackSize := anObject! ! !AJCallInfo methodsFor: 'initialize-release'! initialize arguments := OrderedCollection new. stackSize := 0. stackAlignment := 1. noCleanup := false.! ! !AJCallInfo methodsFor: 'pushing args'! push: anArgument asm pushArgument: anArgument forCall: self. ! ! !AJCallInfo methodsFor: 'testing'! needsAlignment ^ stackAlignment > 1! ! AJCallInfo subclass: #AJCdeclCallInfo instanceVariableNames: 'savedSP' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCdeclCallInfo methodsFor: 'accessing'! defaultArgumentSize ^ 4! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: 'CamilloBruni 3/29/2012 14:01'! alignedCleanup asm mov: savedSP to: asm ESP. asm releaseTemps: 1 "release our temp afterwards" ! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: 'CamilloBruni 7/23/2012 13:29'! emitAlignment | instructions | instructions := asm instructionsFor: [ asm decorateWith: 'align stack' during: [ savedSP := asm reserveTemp annotation: 'saved SP'. asm mov: asm ESP to: savedSP. stackSize > 0 ifTrue: [ asm sub: asm ESP with: (stackSize asUImm annotation: 'stack size') ]. asm and: asm ESP with: stackAlignment - 1; neg: asm ESP; add: asm ESP with: savedSP ] ]. asm insert: instructions after: alignInsertionPoint. self emitCleanup! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: 'CamilloBruni 4/4/2012 16:57'! emitAlignmentIfNeeded | alignment | self needsAlignment ifTrue: [ ^ self emitAlignment ]. self emitCleanup! ! !AJCdeclCallInfo methodsFor: 'emitting code'! emitCleanup noCleanup ifTrue: [ ^ self ]. asm insert: ( asm instructionsFor: [ self needsAlignment ifTrue: [ self alignedCleanup ] ifFalse: [ self normalCleanup ] ] ) after: callCleanup! ! !AJCdeclCallInfo methodsFor: 'emitting code'! normalCleanup stackSize > 0 ifTrue: [ asm add: asm ESP with: stackSize ]! ! SharedPool subclass: #AJConstants instanceVariableNames: '' classVariableNames: 'CcA CcABOVE CcABOVEEQUAL CcAE CcB CcBE CcBELOW CcBELOWEQUAL CcC CcE CcEQUAL CcFPNOTUNORDERED CcFPUNORDERED CcG CcGE CcGREATER CcGREATEREQUAL CcL CcLE CcLESS CcLESSEQUAL CcNA CcNAE CcNB CcNBE CcNC CcNE CcNEGATIVE CcNG CcNGE CcNL CcNLE CcNO CcNOCONDITION CcNOOVERFLOW CcNOTEQUAL CcNOTSIGN CcNOTZERO CcNP CcNS CcNZ CcO CcOVERFLOW CcP CcPARITYEVEN CcPARITYODD CcPE CcPO CcPOSITIVE CcS CcSIGN CcZ CcZERO InstCMOVA InstJA O64Only OFM1 OFM10 OFM2 OFM24 OFM248 OFM4 OFM48 OFM4810 OFM8 OG16 OG163264 OG32 OG3264 OG64 OG8 OG8163264 OIMM OMEM OMM OMMMEM OMMXMM OMMXMMMEM ONOREX OXMM OXMMMEM OpImm OpLabel OpMem OpNONE OpREG PrefetchNTA PrefetchT0 PrefetchT1 PrefetchT2 RIDEAX RIDEBP RIDEBX RIDECX RIDEDI RIDEDX RIDESI RIDESP RegCodeMask RegGPB RegGPD RegGPQ RegGPW RegHighByteMask RegMM RegTypeMask RegX87 RegXMM SegmentCS SegmentDS SegmentES SegmentFS SegmentGS SegmentNONE SegmentSS SizeByte SizeDQWord SizeDWord SizeQWord SizeTWord SizeWord' poolDictionaries: '' category: 'AsmJit-Core'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJConstants class instanceVariableNames: ''! !AJConstants class methodsFor: 'initialization' stamp: 'CamilloBruni 3/29/2012 13:49'! initOpCodes " x86 " OG8 := 16r01. OG16 := 16r02. OG32 := 16r04. OG64 := 16r08. OMEM := 16r40. OIMM := 16r80. O64Only := 16r100. OG8163264 := OG64 + OG32 + OG16 + OG8. OG163264 := OG64 + OG32 + OG16. OG3264 := OG64 + OG32. " x87" OFM1 := 16r01. OFM2 := 16r02. OFM4 := 16r04. OFM8 := 16r08. OFM10 := 16r10. OFM24 := OFM2 + OFM4. OFM248 := OFM2 + OFM4 + OFM8. OFM48 := OFM4 + OFM8. OFM4810 := OFM4 + OFM8 + OFM10. " mm|xmm" ONOREX := 16r01. " Used by MMX/SSE instructions. OG8 is never used for them " OMM := 16r10. OXMM := 16r20. OMMMEM := OMM + OMEM. OXMMMEM := OXMM + OMEM. OMMXMM := OMM + OXMM. OMMXMMMEM := OMM + OXMM + OMEM.! ! !AJConstants class methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2012 18:36'! initialize "Operand is none, used only internally." OpNONE := 0. "Operand is register" OpREG := 1. "Operand is memory" OpMem := 2. "Operand is immediate." OpImm := 3. "Operand is label. " OpLabel := 4. RegTypeMask := 16rF0. RegCodeMask := 16r0F. RegHighByteMask := 2r111100. "1 byte size." SizeByte := 1. "2 bytes size." SizeWord := 2. "4 bytes size." SizeDWord := 4. "8 bytes size." SizeQWord := 8. "10 bytes size." SizeTWord := 10. "16 bytes size." SizeDQWord := 16. "ID for AX/EAX/RAX registers." RIDEAX := 0. "ID for CX/ECX/RCX registers." RIDECX := 1. "ID for DX/EDX/RDX registers." RIDEDX := 2. "ID for BX/EBX/RBX registers." RIDEBX := 3. "ID for SP/ESP/RSP registers." RIDESP := 4. "ID for BP/EBP/RBP registers." RIDEBP := 5. "ID for SI/ESI/RSI registers." RIDESI := 6. "ID for DI/EDI/RDI registers." RIDEDI := 7. "8 bit general purpose register type." RegGPB := 16r00. "16 bit general purpose register type." RegGPW := 16r10. "32 bit general purpose register type." RegGPD := 16r20. "64 bit general purpose register type. " RegGPQ := 16r30. "X87 (FPU) register type. " RegX87 := 16r50. "64 bit mmx register type." RegMM := 16r60. "128 bit sse register type." RegXMM := 16r70. "Segment override prefixes." "No segment override prefix." SegmentNONE := 0. "Use 'cs' segment override prefix." SegmentCS := 1. "Use 'ss' segment override prefix." SegmentSS := 2. "Use 'ds' segment override prefix." SegmentDS := 3. "Use 'es' segment override prefix." SegmentES := 4. "Use 'fs' segment override prefix." SegmentFS := 5. "Use 'gs' segment override prefix." SegmentGS := 6. self initializePrefetchHints. self initializeConditionCodes. self initOpCodes. ! ! !AJConstants class methodsFor: 'initialization'! initializeConditionCodes "Condition codes." "No condition code." CcNOCONDITION := -1. "Condition codes from processor manuals." CcA := 16r7. CcAE := 16r3. CcB := 16r2. CcBE := 16r6. CcC := 16r2. CcE := 16r4. CcG := 16rF. CcGE := 16rD. CcL := 16rC. CcLE := 16rE. CcNA := 16r6. CcNAE := 16r2. CcNB := 16r3. CcNBE := 16r7. CcNC := 16r3. CcNE := 16r5. CcNG := 16rE. CcNGE := 16rC. CcNL := 16rD. CcNLE := 16rF. CcNO := 16r1. CcNP := 16rB. CcNS := 16r9. CcNZ := 16r5. CcO := 16r0. CcP := 16rA. CcPE := 16rA. CcPO := 16rB. CcS := 16r8. CcZ := 16r4. " Simplified condition codes" CcOVERFLOW := 16r0. CcNOOVERFLOW := 16r1. CcBELOW := 16r2. CcABOVEEQUAL := 16r3. CcEQUAL := 16r4. CcNOTEQUAL := 16r5. CcBELOWEQUAL := 16r6. CcABOVE := 16r7. CcSIGN := 16r8. CcNOTSIGN := 16r9. CcPARITYEVEN := 16rA. CcPARITYODD := 16rB. CcLESS := 16rC. CcGREATEREQUAL := 16rD. CcLESSEQUAL := 16rE. CcGREATER := 16rF. "aliases" CcZERO := 16r4. CcNOTZERO := 16r5. CcNEGATIVE := 16r8. CcPOSITIVE := 16r9. "x87 floating point only" CcFPUNORDERED := 16. CcFPNOTUNORDERED := 17. ! ! !AJConstants class methodsFor: 'initialization'! initializePrefetchHints "Prefetch hints." "Prefetch to L0 cache." PrefetchT0 := 1. "Prefetch to L1 cache." PrefetchT1 := 2. "Prefetch to L2 cache." PrefetchT2 := 3. "Prefetch using NT hint." PrefetchNTA := 0. ! ! AJInstruction subclass: #AJData instanceVariableNames: 'data alignment' classVariableNames: '' poolDictionaries: 'AJConstants' category: 'AsmJit-Instructions'! !AJData commentStamp: '' prior: 0! I represent a pure data section in an assembly instruction stream. Example: asm := AJx64Assembler noStackFrame. "add a raw byte" asm db: 16rFF. "add a raw word" asm dw: #[16r34 16r12]. "add a raw double" asm dw: #[16r78 16r56 16r34 16r12]. "add a arbitrary sized data section with a byteArray" asm data: #[1 2 3 4 5 6 7 8 9 10 11 12 ].! !AJData methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 14:22'! data ^ machineCode! ! !AJData methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 14:22'! data: aByteArray "the will be put in the executable." machineCode := aByteArray! ! !AJData methodsFor: 'accessing'! name name ifNotNil: [ ^ name ]. "standard data sections" self is8 ifTrue: [ ^ 'db' ]. self is16 ifTrue: [ ^ 'dw' ]. self is32 ifTrue: [ ^ 'dd' ].! ! !AJData methodsFor: 'accessing'! size ^ self data size! ! !AJData methodsFor: 'emitting code' stamp: 'CamilloBruni 4/12/2012 14:22'! emitCode: asm machineCode ifNil: [ machineCode := #[] ]! ! !AJData methodsFor: 'testing'! is16 ^ self size = 2! ! !AJData methodsFor: 'testing'! is32 ^ self size = 4! ! !AJData methodsFor: 'testing'! is64 ^ self size = 8! ! !AJData methodsFor: 'testing'! is8 ^ self size = 1! ! !AJData methodsFor: 'visitor'! accept: anObject anObject instructionData: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJData class instanceVariableNames: ''! !AJData class methodsFor: 'instance creation'! byte: aByteValue ^ self data: (ByteArray with: aByteValue)! ! !AJData class methodsFor: 'instance creation'! data: aDataByteArray ^ self new data: aDataByteArray; yourself! ! !AJData class methodsFor: 'instance creation'! label: aLabel data: aDataByteArray ^ self new label: aLabel; data: aDataByteArray; yourself! ! Object subclass: #AJGeneratedCode instanceVariableNames: 'bytes labels' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Core'! !AJGeneratedCode methodsFor: 'accessing'! bytes ^ bytes! ! !AJGeneratedCode methodsFor: 'accessing'! bytes: aBytes bytes := aBytes ! ! !AJGeneratedCode methodsFor: 'accessing'! labels: aLabels "turn labels into a simple name->offset pairs" aLabels keysAndValuesDo: [:name :lbl | labels at: name put: lbl paddedOffset ]. ! ! !AJGeneratedCode methodsFor: 'accessing'! offsetAt: aLabelName ^ labels at: aLabelName! ! !AJGeneratedCode methodsFor: 'initialize-release' stamp: 'CamilloBruni 4/4/2012 16:30'! fromInstructions: instructions bytes := ByteArray new: 100 streamContents: [:stream| instructions do: [ :each | each extractLabels: [:name :pos | labels at: name put: pos ]. each storeOn: stream ]].! ! !AJGeneratedCode methodsFor: 'initialize-release'! initialize labels := Dictionary new. ! ! !AJGeneratedCode methodsFor: 'output'! dumpWithLabels "dump the native code , interspersed with labels" | offsets i str | offsets := OrderedCollection new. labels keysAndValuesDo: [ :name :offset | offsets add: (offset -> name) ]. offsets := offsets sort: [:a :b | a key < b key ]. str := String new writeStream. i := 0. offsets do: [:offset | i to: offset key -1 do: [:x | str nextPutAll: ((bytes at: i+1) printStringBase: 16 nDigits: 2) ; space. i:=i+1. ]. str cr; nextPutAll: offset value; cr. ]. i to: bytes size-1 do: [:x | str nextPutAll: ((bytes at: i+1) printStringBase: 16 nDigits: 2) ; space. i := i + 1] . ^ str contents! ! !AJGeneratedCode methodsFor: 'output'! saveToFile self saveToFile: 'asm.bin'! ! !AJGeneratedCode methodsFor: 'output'! saveToFile: fileName (FileStream forceNewFileNamed: fileName) nextPutAll: bytes; close ! ! !AJGeneratedCode methodsFor: 'printing'! printOn: aStream bytes notNil ifTrue: [ aStream nextPutAll: self dumpWithLabels ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJGeneratedCode class instanceVariableNames: ''! !AJGeneratedCode class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/25/2012 12:44'! fromInstructions: instructions ^ self new fromInstructions: instructions! ! AJOperand subclass: #AJImmediate instanceVariableNames: 'label size isUnsigned relocMode value' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJImmediate commentStamp: '' prior: 0! I am an immediate (constant integer) operand used by the assembler. Example: asm := AJx64Assembler new. "create an immediate from an integer" 1 asImm. "implicitely use an immediate in an assembly instrution" asm add: 1 to: asm RAX. ! !AJImmediate methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/18/2012 16:49'! asNBExternalType: gen ^ NBFFIConst value: self! ! !AJImmediate methodsFor: 'accessing'! extractLabels: aBlock label ifNotNil: [ label extractLabels: aBlock ] ! ! !AJImmediate methodsFor: 'accessing'! ivalue: aValue "signed integer value" value := aValue. isUnsigned := false.! ! !AJImmediate methodsFor: 'accessing'! label: aLabelName label := aLabelName! ! !AJImmediate methodsFor: 'accessing'! relocMode ^ relocMode ifNil: [#RelocNone ]! ! !AJImmediate methodsFor: 'accessing'! size ^ size! ! !AJImmediate methodsFor: 'accessing'! size: aSize size := aSize! ! !AJImmediate methodsFor: 'accessing'! sizeFor: anOperand "Check if I am a valid size to be used together with anOperand If so, I will use as much size as it" self assert: (self fitsInSize: anOperand size). ^anOperand size! ! !AJImmediate methodsFor: 'accessing'! uvalue: aValue "unsigned value" self assert: (aValue >=0). value := aValue. isUnsigned := true.! ! !AJImmediate methodsFor: 'accessing'! value ^ value! ! !AJImmediate methodsFor: 'converting'! asByte "answer the byte representing a value" (self fitsInSize: 1) ifFalse: [ Error signal: self asString, ' exceeds byte (8bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<8) + value ]. ^ value! ! !AJImmediate methodsFor: 'converting' stamp: 'CamilloBruni 4/4/2012 16:52'! asDWord "answer the 32bit word representing a value" (self fitsInSize: 4) ifFalse: [ Error signal: self asString, ' exceeds doubleword (32bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<32) + value ]. ^ value! ! !AJImmediate methodsFor: 'converting' stamp: 'CamilloBruni 4/4/2012 16:52'! asQWord "answer the 64bit word representing a value" (self fitsInSize: 8) ifFalse: [ Error signal: self asString, ' exceeds quadword (64bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<64) + value ]. ^ value! ! !AJImmediate methodsFor: 'converting'! asWord "answer the 16bit word representing a value" (self fitsInSize: 2) ifFalse: [ Error signal: self asString, ' value exceeds word (16bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<16) + value ]. ^ value! ! !AJImmediate methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:54'! ptr "turn receiver into a memory operand with absolute address == receiver" ^ AJMem new displacement: self! ! !AJImmediate methodsFor: 'emitting code' stamp: 'CamilloBruni 4/4/2012 16:53'! emitUsing: emitter size: aSize label ifNotNil: [ "this will set the label offset" emitter setLabelPosition: label. ]. aSize = 1 ifTrue: [ ^ emitter emitByte: self asByte ]. aSize = 2 ifTrue: [ ^ emitter emitWord: self asWord ]. aSize = 4 ifTrue: [ ^ emitter emitDWord: self asDWord ]. aSize = 8 ifTrue: [ ^ emitter emitQWord: self asQWord ]. self error: aSize asString, 'bytes is an invalid immediate value size'! ! !AJImmediate methodsFor: 'initialize-release'! initialize value := 0. isUnsigned := false.! ! !AJImmediate methodsFor: 'printing' stamp: 'CamilloBruni 10/5/2012 14:39'! printOn: aStream aStream nextPut: $(. self printAnnotationOn: aStream. value > 1000000 ifTrue: [ aStream nextPutAll: value hex] ifFalse: [ aStream print: value]. aStream space. aStream nextPut: ( self isSigned ifTrue: [ $i ] ifFalse: [ $u ]). size ifNotNil: [ aStream print: size]. aStream nextPut: $). ! ! !AJImmediate methodsFor: 'testing' stamp: 'CamilloBruni 4/4/2012 16:54'! fitsInSize: aSize | maxSize | maxSize := 1 << (aSize * 8). self isUnsigned ifTrue: [ ^ maxSize > value ]. value < 0 ifTrue: [ ^ 0 - value <= (maxSize >> 1) ]. ^ value < (maxSize>>1)! ! !AJImmediate methodsFor: 'testing'! isImm ^ true! ! !AJImmediate methodsFor: 'testing' stamp: 'CamilloBruni 4/4/2012 16:54'! isInt32 ^ value >= -2147483648 and: [ value <= 2147483647 ] ! ! !AJImmediate methodsFor: 'testing'! isInt8 ^ size ifNil: [ self fitsInSize: 1 ] ifNotNil: [ size = 1 ]! ! !AJImmediate methodsFor: 'testing'! isSigned ^ isUnsigned not! ! !AJImmediate methodsFor: 'testing'! isUnsigned ^ isUnsigned! ! !AJImmediate methodsFor: 'testing'! isZero ^ value = 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJImmediate class instanceVariableNames: ''! !AJImmediate class methodsFor: 'as yet unclassified'! ivalue: aValue ^ self new ivalue: aValue! ! Object subclass: #AJInstruction instanceVariableNames: 'name operands machineCode position next annotation level' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJInstruction methodsFor: 'accessing'! annotation ^ annotation! ! !AJInstruction methodsFor: 'accessing'! annotation: anObject annotation := anObject! ! !AJInstruction methodsFor: 'accessing'! extractLabels: aBlock operands ifNotNil: [ operands do: [:each | each extractLabels: aBlock ]]! ! !AJInstruction methodsFor: 'accessing'! increaseLevel: num level := level + num! ! !AJInstruction methodsFor: 'accessing'! insert: anInstructions | n | self halt. n := next. next := anInstructions. anInstructions do: [:each | each increaseLevel: level ]. anInstructions last next: n! ! !AJInstruction methodsFor: 'accessing'! instructionName ^ name! ! !AJInstruction methodsFor: 'accessing'! level ^ level! ! !AJInstruction methodsFor: 'accessing'! level: aLevel level := aLevel ! ! !AJInstruction methodsFor: 'accessing'! machineCodeSize ^ machineCode ifNil: [ 0 ] ifNotNil: [ machineCode size ]! ! !AJInstruction methodsFor: 'accessing'! name ^ name ifNil: ['undefined']! ! !AJInstruction methodsFor: 'accessing'! name: anObject name := anObject! ! !AJInstruction methodsFor: 'accessing'! next ^ next! ! !AJInstruction methodsFor: 'accessing'! next: anObject next := anObject! ! !AJInstruction methodsFor: 'accessing'! operands ^ operands! ! !AJInstruction methodsFor: 'accessing'! operands: anObject operands := anObject! ! !AJInstruction methodsFor: 'accessing'! position ^ position! ! !AJInstruction methodsFor: 'accessing'! position: anObject position := anObject! ! !AJInstruction methodsFor: 'emitting code'! emitCode: asm machineCode := #[] ! ! !AJInstruction methodsFor: 'emitting code'! emitCodeAtOffset: offset assembler: asm position := offset. self emitCode: asm. next ifNotNil: [ next emitCodeAtOffset: offset + self machineCodeSize assembler: asm ].! ! !AJInstruction methodsFor: 'function calls'! prepareCallAlignments "do nothing"! ! !AJInstruction methodsFor: 'helpers'! find: aByteString self shouldBeImplemented.! ! !AJInstruction methodsFor: 'initialize-release'! initialize level := 0! ! !AJInstruction methodsFor: 'iterating'! do: aBlock "evaluate all instructions for the list" | nn | nn := self. [ nn notNil ] whileTrue: [ aBlock value: nn. nn := nn next. ].! ! !AJInstruction methodsFor: 'iterating'! last "answer the last instruction in the list" | nn l | nn := self. [ (l := nn next) notNil ] whileTrue: [ nn := l ]. ^ nn! ! !AJInstruction methodsFor: 'manipulating'! insert: newInstruction before: anInstruction "replace a single instruction with one or more other instructions" | instr anext | anInstruction == self ifTrue: [ newInstruction last next: self. ^ newInstruction ]. instr := self. [ (anext := instr next) notNil and: [ anext ~~ anInstruction ]] whileTrue: [ instr := anext ]. instr next ifNotNil: [ newInstruction do: [:each | each increaseLevel: instr level ]. newInstruction last next: instr next. instr next: newInstruction ]. ! ! !AJInstruction methodsFor: 'manipulating'! replace: anInstruction with: otherInstructions "replace a single instruction with one or more other instructions" | instr | anInstruction == self ifTrue: [ otherInstructions last next: self next. ^ otherInstructions ]. instr := self. [ instr notNil and: [instr next ~~ anInstruction ]] whileTrue: [ instr := instr next ]. instr notNil ifTrue: [ otherInstructions last next: instr next next. instr next: otherInstructions ]. ! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:33'! printAnnotationOn: aStream annotation ifNil: [^ self]. aStream nextPut: $"; nextPutAll: annotation asString; nextPut: $"; cr. self printIndentOn: aStream! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:44'! printIndentOn: aStream level ifNil: [ ^ self ]. level timesRepeat: [ aStream nextPutAll: '| ']! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:27'! printListOn: aStream self printIndentOn: aStream. self printSelfOn: aStream. next ifNotNil: [ aStream cr. next printListOn: aStream ]! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 10/12/2012 11:40'! printMachineCodeOn: aStream (machineCode isNil or: [machineCode isEmpty]) ifTrue: [^ self]. aStream padColumn: 65; nextPutAll: '#['. machineCode do: [ :byte | byte printOn: aStream base: 16 length: 2 padded: true ] separatedBy: [ aStream space ]. aStream nextPut: $]! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:24'! printOn: aStream "[ ^self ] value." self printListOn: aStream asLineStream! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:29'! printOperandsOn: aStream (operands notNil and: [operands isEmpty not]) ifTrue: [aStream space; nextPut: $(. operands do: [ :operand | operand printAsOperandOn: aStream] separatedBy: [aStream space]. aStream nextPut: $)]! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:26'! printSelfOn: aStream self printAnnotationOn: aStream. aStream nextPutAll: (self name padRightTo: 4). self printOperandsOn: aStream. self printMachineCodeOn: aStream! ! !AJInstruction methodsFor: 'printing'! printStringLimitedTo: aNumber ^ String streamContents: [:s | self printOn: s] ! ! !AJInstruction methodsFor: 'printing'! storeOn: aStream "store machine code to binary stream" machineCode ifNotNil: [ aStream nextPutAll: machineCode ]! ! !AJInstruction methodsFor: 'testing'! hasLabel self shouldBeImplemented.! ! !AJInstruction methodsFor: 'testing'! isLabelUsed: anAJJumpLabel ^ false! ! !AJInstruction methodsFor: 'visitor'! accept: anObject self subclassResponsibility! ! !AJInstruction methodsFor: 'visitor'! processTempsWith: anObject "do nothing"! ! !AJInstruction methodsFor: 'visitor'! setPrologue: anInstrucitons "do nothing"! ! AJInstruction subclass: #AJInstructionDecoration instanceVariableNames: 'end' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJInstructionDecoration methodsFor: 'accessing'! end end := true! ! !AJInstructionDecoration methodsFor: 'accessing'! start end := false! ! !AJInstructionDecoration methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:43'! printIndentOn: aStream end ifFalse: [ super printIndentOn: aStream. aStream cr ]. ^ super printIndentOn: aStream! ! !AJInstructionDecoration methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:42'! printSelfOn: aStream end ifFalse: [ aStream nextPutAll: '/ "' ] ifTrue: [ aStream nextPutAll: '\ "end ' ]. aStream nextPutAll: annotation; nextPut: $". ! ! !AJInstructionDecoration methodsFor: 'visitor'! accept: anObject anObject instructionDecoration: self! ! AJInstruction subclass: #AJJumpInstruction instanceVariableNames: 'label description' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJJumpInstruction methodsFor: 'accessing'! codeSize ^ machineCode size! ! !AJJumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:54'! description ^ description! ! !AJJumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description: anInstructionDescription description := anInstructionDescription! ! !AJJumpInstruction methodsFor: 'accessing'! label ^ label! ! !AJJumpInstruction methodsFor: 'accessing'! label: anObject label := anObject! ! !AJJumpInstruction methodsFor: 'printing'! printSelfOn: aStream aStream nextPutAll: name; space. label printSelfOn: aStream. machineCode ifNotNil: [ aStream space; nextPut: $[ . machineCode do: [:byte | aStream nextPutAll: (byte printStringBase: 16)] separatedBy: [ aStream space ]. aStream nextPut: $]. ]. ! ! !AJJumpInstruction methodsFor: 'testing'! isLabelUsed: anAJJumpLabel ^ label = anAJJumpLabel ! ! !AJJumpInstruction methodsFor: 'visitor'! accept: anObject ^ anObject jumpInstruction: self! ! AJInstruction subclass: #AJJumpLabel instanceVariableNames: 'isSet' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJJumpLabel methodsFor: 'accessing'! extractLabels: aBlock aBlock value: name value: position! ! !AJJumpLabel methodsFor: 'accessing'! isSet ^ isSet == true! ! !AJJumpLabel methodsFor: 'accessing'! isSet: anObject isSet := anObject! ! !AJJumpLabel methodsFor: 'emitting code'! emitCode: asm ! ! !AJJumpLabel methodsFor: 'printing'! printAsOperandOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'printing'! printOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 14:48'! printSelfOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'testing' stamp: 'CamilloBruni 8/22/2012 16:43'! isLabel ^ true! ! !AJJumpLabel methodsFor: 'visitor'! accept: anObject anObject jumpLabel: self! ! Object subclass: #AJLineStream instanceVariableNames: 'lineStart writeStream' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Extension'! !AJLineStream methodsFor: 'error handling' stamp: 'CamilloBruni 7/16/2012 14:59'! doesNotUnderstand: aMessage writeStream perform: aMessage selector withArguments: aMessage arguments! ! !AJLineStream methodsFor: 'writing'! cr self updateLineStart. writeStream cr! ! !AJLineStream methodsFor: 'writing'! crlf self updateLineStart. writeStream crlf! ! !AJLineStream methodsFor: 'writing'! lf self updateLineStart. writeStream lf! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:00'! on: aStream ^ self new writeStream: aStream; yourself! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:23'! padColumn: maxCharacterPosition "pad the current line up to maxCharacterPosition with spaces" [writeStream position - lineStart < maxCharacterPosition] whileTrue: [writeStream space]! ! !AJLineStream methodsFor: 'writing'! updateLineStart lineStart := writeStream position! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:22'! writeStream: aWriteStream writeStream := aWriteStream. self updateLineStart! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJLineStream class instanceVariableNames: ''! !AJLineStream class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/16/2012 15:33'! on: aWriteStream ^ self new writeStream: aWriteStream; yourself! ! AJBaseReg subclass: #AJMMRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Operands'! !AJMMRegister methodsFor: 'accessing'! code: aCode code := aCode. size := 8.! ! !AJMMRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:13'! descriptionOn: s s nextPutAll: 'An MMX register'.! ! !AJMMRegister methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJMMRegister methodsFor: 'testing'! isRegTypeMM ^ true! ! AJOperand subclass: #AJMem instanceVariableNames: 'size base index shift segmentPrefix hasLabel target displacement' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJMem commentStamp: '' prior: 0! I am memory operand used in asembly instructions. Example: asm := AJx86Assembler new. "create a simple memory operand with RAX as base" asm RAX ptr. "the same with a 8 byte offset" asm RAX ptr + 8! !AJMem methodsFor: 'accessing'! * aScale self scale: aScale! ! !AJMem methodsFor: 'accessing' stamp: 'CamilloBruni 4/4/2012 16:45'! + displacementOrIndex displacementOrIndex isInteger ifTrue: [ self displacement: (AJImmediate new ivalue: displacementOrIndex). ^ self ]. displacementOrIndex isGeneralPurpose ifTrue: [ index := displacementOrIndex. ^ self ]. self error: 'Expected integer or general purpose register for memory displacement but got ', displacementOrIndex class name, '.'.! ! !AJMem methodsFor: 'accessing' stamp: 'CamilloBruni 4/4/2012 16:40'! - aDisplacement aDisplacement isInteger ifFalse: [ self error: 'Expected integer for memory displacement but got ', aDisplacement class name, '.' ]. self displacement: (AJImmediate new ivalue: aDisplacement negated). ^ self! ! !AJMem methodsFor: 'accessing'! base "Answer the value of base" ^ base! ! !AJMem methodsFor: 'accessing'! base: anObject "Set the value of base" base := anObject! ! !AJMem methodsFor: 'accessing'! displacement "Answer the value of displacement" ^ displacement! ! !AJMem methodsFor: 'accessing'! displacement: anImm "Set the value of displacement" self assert: anImm isImm. displacement := anImm! ! !AJMem methodsFor: 'accessing'! hasLabel "Answer the value of hasLabel" ^ false! ! !AJMem methodsFor: 'accessing'! hasLabel: anObject "Set the value of hasLabel" hasLabel := anObject! ! !AJMem methodsFor: 'accessing'! index "Answer the value of index" ^ index! ! !AJMem methodsFor: 'accessing'! index: anIndex "Set the value of index, must be a general purpose register" self assert: (anIndex isGeneralPurpose). index := anIndex! ! !AJMem methodsFor: 'accessing'! scale: aScale "a valid scale values is 0 , 2 , 4 and 8" aScale = 0 ifTrue: [ shift := 0. ^ self ]. aScale = 2 ifTrue: [ shift := 1. ^ self ]. aScale = 4 ifTrue: [ shift := 2. ^ self ]. aScale = 8 ifTrue: [ shift := 3. ^ self ]. self error: 'invalid scale value'! ! !AJMem methodsFor: 'accessing'! segmentPrefix "Answer the value of segmentPrefix" ^ segmentPrefix! ! !AJMem methodsFor: 'accessing'! segmentPrefix: anObject "Set the value of segmentPrefix" segmentPrefix := anObject! ! !AJMem methodsFor: 'accessing'! shift "Answer the value of shift" ^ shift! ! !AJMem methodsFor: 'accessing'! shift: value "Set the value of shift" self assert: (value >=0 and: [ value < 4 ]). shift := value! ! !AJMem methodsFor: 'accessing'! size ^ size ifNil: [ base size ]! ! !AJMem methodsFor: 'accessing'! size: anObject "Set the value of size" size := anObject! ! !AJMem methodsFor: 'emitting'! emit32BitAbsoluteDisplacementModRM: emitter code: rCode self hasIndex ifTrue: [ self assert: index index ~= RIDESP. " ESP/RSP" emitter emitMod: 0 reg: rCode rm: 4. emitter emitScale: shift index: index index base: 5 ] ifFalse: [ emitter emitMod: 0 reg: rCode rm: 5 ]. self hasLabel ifTrue: [ "X86 uses absolute addressing model, all relative addresses will be relocated to absolute ones." "target is label" target addRelocationAt: emitter offset displacement: displacement absolute: true size: 4. emitter emitInt32: 0 ] ifFalse: [ " Absolute address" displacement emitUsing: emitter size: 4 ]! ! !AJMem methodsFor: 'emitting'! emitBaseDisplacementModRM: emitter code: rCode | mod | self base isRip ifTrue: [ emitter emitMod: 0 reg: rCode rm: 2r101. displacement emitUsing: emitter size: 4. ^ self ]. mod := 0. displacement isZero ifFalse: [ mod := displacement isInt8 ifTrue: [ 1 ] ifFalse: [ 2 ]]. self base index == RIDESP ifTrue: [ "ESP/RSP/R12" emitter emitMod: mod reg: rCode rm: RIDESP. emitter emitScale: 0 index: RIDESP base: RIDESP ] ifFalse: [ (self base index ~= RIDEBP and: [ displacement isZero ]) ifTrue: [ "just base, and not EBP/RBP/R13 " ^ emitter emitMod: 0 reg: rCode rm: base index ]. "force emitting displacement" mod = 0ifTrue: [ mod := 1 ]. emitter emitMod: mod reg: rCode rm: base index ]. mod = 1 ifTrue: [ displacement emitUsing: emitter size: 1 ]. mod = 2 ifTrue: [ displacement emitUsing: emitter size: 4 ].! ! !AJMem methodsFor: 'emitting' stamp: 'CamilloBruni 4/4/2012 16:52'! emitModRM: emitter code: rCode immSize: immSize "Receiver is memory location" "[base + displacement]" (self hasBase and: [ self hasIndex not ]) ifTrue: [ ^ self emitBaseDisplacementModRM: emitter code: rCode ]. "[base + index * scale + displacement]" (self hasBase and: [ self hasIndex ]) ifTrue: [ ^ self emitScaledBaseDisplacementModRM: emitter code: rCode ]. " Address | 32-bit mode | 64-bit mode ------------------------------+-------------+--------------- [displacement] | ABSOLUTE | RELATIVE (RIP) [index * scale + displacemnt] | ABSOLUTE | ABSOLUTE (ZERO EXTENDED) In 32 bit mode is used absolute addressing model. In 64 bit mode is used relative addressing model together with absolute addressing one. The main problem is that if the instruction contains a SIB byte then relative addressing (RIP) is not possible. " emitter is32BitMode ifTrue: [ ^ self emit32BitAbsoluteDisplacementModRM: emitter code: rCode ]. emitter is64BitMode ifTrue: [ self shouldBeImplemented ]. self invalidInstruction! ! !AJMem methodsFor: 'emitting'! emitScaledBaseDisplacementModRM: emitter code: rCode self assert: index index ~= RIDESP. (base index ~= RIDEBP and: [ displacement isZero ]) ifTrue: [ emitter emitMod: 0 reg: rCode rm: 4. ^ emitter emitScale: shift index: index index base: base index ]. displacement isInt8 ifTrue: [ emitter emitMod: 1 reg: rCode rm: 4. emitter emitScale: shift index: index index base: base index. displacement emitUsing: emitter size: 1 ] ifFalse: [ emitter emitMod: 2 reg: rCode rm: 4. emitter emitScale: shift index: index index base: base index. displacement emitUsing: emitter size: 4 ]. ^ self! ! !AJMem methodsFor: 'initialize-release'! initialize displacement := AJImmediate new. shift := 0.! ! !AJMem methodsFor: 'printing' stamp: 'CamilloBruni 10/5/2012 14:38'! printOn: aStream self printAnnotationOn: aStream. aStream nextPutAll: 'mem['. base ifNotNil: [ aStream nextPutAll: base printAsMemBase. (index isNil and: [ displacement isNil ]) ifFalse: [ aStream nextPutAll: ' + ' ]]. index ifNotNil: [ aStream nextPutAll: index registerName . displacement ifNotNil: [ aStream nextPutAll: ' + ']]. displacement ifNotNil: [ aStream print: displacement ]. aStream nextPut: $].! ! !AJMem methodsFor: 'testing'! hasBase ^ base notNil! ! !AJMem methodsFor: 'testing'! hasIndex ^ index notNil! ! !AJMem methodsFor: 'testing'! hasSegmentPrefix ^ segmentPrefix notNil! ! !AJMem methodsFor: 'testing'! isMem ^ true! ! !AJMem methodsFor: 'testing'! isRip ^ self base isRip! ! !AJMem methodsFor: 'testing'! isUpperBank "see `AJBaseReg >> #isUpperBank` " ^ self base isUpperBank! ! Object subclass: #AJOperand instanceVariableNames: 'data compilerData operandId x64padding annotation' classVariableNames: '' poolDictionaries: 'AJConstants' category: 'AsmJit-Operands'! !AJOperand methodsFor: 'accessing'! annotation ^ annotation! ! !AJOperand methodsFor: 'accessing'! annotation: anObject annotation := anObject! ! !AJOperand methodsFor: 'accessing'! clearId operandId := 0.! ! !AJOperand methodsFor: 'accessing'! compilerData ^ compilerData! ! !AJOperand methodsFor: 'accessing'! operandId ^ operandId! ! !AJOperand methodsFor: 'accessing'! size "Return size of operand in bytes." self shouldBeImplemented ! ! !AJOperand methodsFor: 'accessing'! size16 ^ self size: 2! ! !AJOperand methodsFor: 'accessing'! size32 ^ self size: 4! ! !AJOperand methodsFor: 'accessing'! size64 ^ self size: 8! ! !AJOperand methodsFor: 'accessing'! size8 ^ self size: 1! ! !AJOperand methodsFor: 'accessing'! stackSize ^ self size! ! !AJOperand methodsFor: 'code generation'! emitPushOnStack: asm asm push: self! ! !AJOperand methodsFor: 'converting'! asAJOperand "receiver is already an operand. no nothing"! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr "turn receiver into a memory operand " self subclassResponsibility ! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:51'! ptr16 "turn receiver into a memory operand with receiver as base, with 2 bytes size" ^ self ptr size: 2! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr32 "turn receiver into a memory operand with receiver as base, with 4 bytes size" ^ self ptr size: 4! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr64 "turn receiver into a memory operand with receiver as base, with 8 bytes size" ^ self ptr size: 8! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr8 "turn receiver into a memory operand with receiver as base, with 1 byte size" ^ self ptr size: 1! ! !AJOperand methodsFor: 'labels'! extractLabels: aBlockClosure " do nothing"! ! !AJOperand methodsFor: 'printing' stamp: 'CamilloBruni 8/24/2012 13:56'! printAnnotationOn: aStream annotation ifNil: [ ^ self ]. aStream nextPut: $" ; nextPutAll: annotation asString; nextPut: $"; space.! ! !AJOperand methodsFor: 'printing'! printAsOperandOn: aStream ^ self printOn: aStream ! ! !AJOperand methodsFor: 'testing'! is16 ^ self size == 2! ! !AJOperand methodsFor: 'testing'! is32 ^ self size == 4! ! !AJOperand methodsFor: 'testing'! is64 ^ self size == 8! ! !AJOperand methodsFor: 'testing'! is8 ^ self size == 1! ! !AJOperand methodsFor: 'testing'! isImm ^ false ! ! !AJOperand methodsFor: 'testing'! isLabel ^ false! ! !AJOperand methodsFor: 'testing'! isMem ^ false! ! !AJOperand methodsFor: 'testing'! isNone "Return true if operand is none (OP_NONE)." self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing'! isReg ^ false! ! !AJOperand methodsFor: 'testing'! isRegCode: aRegCode self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing'! isRegIndex: aRegIndex ^ self isReg and: [ self index == (aRegIndex bitAnd: RegCodeMask ) ] ! ! !AJOperand methodsFor: 'testing'! isRegMem ^ self isReg or: [ self isMem ]! ! !AJOperand methodsFor: 'testing'! isRegMem: aRegType self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing'! isRegType: aRegType ^ self isReg and: [self type == aRegType]! ! !AJOperand methodsFor: 'testing'! isRegTypeGPB ^ self isRegType: RegGPB! ! !AJOperand methodsFor: 'testing'! isRegTypeGPD ^ self isRegType: RegGPD! ! !AJOperand methodsFor: 'testing'! isRegTypeGPQ ^ self isRegType: RegGPQ! ! !AJOperand methodsFor: 'testing'! isRegTypeGPW ^ self isRegType: RegGPW! ! !AJOperand methodsFor: 'testing'! isRegTypeMM ^ false! ! !AJOperand methodsFor: 'testing'! isRegTypeX87 ^ false! ! !AJOperand methodsFor: 'testing'! isRegTypeXMM ^ false! ! !AJOperand methodsFor: 'testing'! isRip ^ false! ! AJBaseReg subclass: #AJRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJRegister methodsFor: 'accessing'! code: aCode code := aCode. size := 1 << (( code bitAnd: RegTypeMask ) >> 4).! ! !AJRegister methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 12:43'! influencingRegisters self is8 ifFalse: [ ^ self as8 influencingRegisters ]. ^ { self as8. self as16. self as32. self as64}! ! !AJRegister methodsFor: 'accessing'! size ^ 1 << (( code bitAnd: RegTypeMask ) >> 4).! ! !AJRegister methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJRegister methodsFor: 'testing'! isReg ^ true! ! AJInstruction subclass: #AJReleaseTemps instanceVariableNames: 'count' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJReleaseTemps methodsFor: 'accessing'! count ^ count! ! !AJReleaseTemps methodsFor: 'accessing'! count: anObject count := anObject! ! !AJReleaseTemps methodsFor: 'printing'! printOn: aStream ^ self printSelfOn: aStream ! ! !AJReleaseTemps methodsFor: 'printing'! printSelfOn: aStream aStream nextPutAll: 'Release temps: '; print: count ! ! !AJReleaseTemps methodsFor: 'visitor'! accept: anObject anObject visitReleaseTemps: self ! ! !AJReleaseTemps methodsFor: 'visitor'! processTempsWith: anObject anObject releaseTemps: count! ! AJInstruction subclass: #AJReserveTemp instanceVariableNames: 'operand size' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJReserveTemp commentStamp: 'IgorStasenko 1/18/2012 13:09' prior: 0! note: assembler should set size even before realizing a temp into stack location reference! !AJReserveTemp methodsFor: 'accessing' stamp: 'CamilloBruni 8/24/2012 13:32'! name ^ name ifNil: [ 'Reserve temp' ]! ! !AJReserveTemp methodsFor: 'accessing'! operand ^ operands first! ! !AJReserveTemp methodsFor: 'accessing'! operand: anObject anObject annotation: annotation. operands := Array with: anObject ! ! !AJReserveTemp methodsFor: 'accessing'! size ^ size! ! !AJReserveTemp methodsFor: 'accessing'! size: number size := number! ! !AJReserveTemp methodsFor: 'accessing'! stackSize ^ self size! ! !AJReserveTemp methodsFor: 'converting'! asAJOperand ^ operands first! ! !AJReserveTemp methodsFor: 'emitting code'! emitPushOnStack: asm ^ asm push: self! ! !AJReserveTemp methodsFor: 'printing' stamp: 'CamilloBruni 7/20/2012 13:29'! printAsOperandOn: aStream annotation ifNotNil: [ aStream nextPut: $"; nextPutAll: annotation asString; nextPut: $"; space ]. operands ifNil: [ ^ aStream nextPutAll: 'aStackTEMP' ]. self operand printAsOperandOn: aStream.! ! !AJReserveTemp methodsFor: 'printing'! printOn: aStream ^ self printSelfOn: aStream ! ! !AJReserveTemp methodsFor: 'testing'! isMem ^ true! ! !AJReserveTemp methodsFor: 'visitor'! accept: anObject ^ anObject reserveTemp: self! ! !AJReserveTemp methodsFor: 'visitor'! processTempsWith: anObject anObject reserveTemp: self ! ! AJInstruction subclass: #AJRoutineEpilogue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! AJInstruction subclass: #AJRoutinePrologue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJRoutinePrologue commentStamp: 'IgorStasenko 5/11/2011 00:32' prior: 0! This is a pseudo-instruction to indicate a place in native code for routine prologue. It is later replaced by real instructions which contain code for initializing stack frame & extra stack space required by routine.! !AJRoutinePrologue methodsFor: 'accessing'! name ^ 'prologue' ! ! !AJRoutinePrologue methodsFor: 'emitting code'! emitCode: asm machineCode := #[]! ! !AJRoutinePrologue methodsFor: 'visitor'! accept: anObject ^ anObject visitRoutinePrologue: self! ! !AJRoutinePrologue methodsFor: 'visitor' stamp: 'CamilloBruni 10/4/2012 18:54'! setPrologue: anInstructions "do nothing" | old | old := next. next := anInstructions. anInstructions last next: old ! ! Object subclass: #AJRoutineStackManager instanceVariableNames: 'calls instructions assembler noStackFrame temps maxTemps extraStackBytes' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/4/2012 16:33'! analyzeInstructions: anInstructions assembler: asm instructions := anInstructions. assembler := asm. instructions do: #prepareCallAlignments. calls do: [:callInfo | callInfo asm: assembler. callInfo emitAlignmentIfNeeded ]. instructions do: [:each | each processTempsWith: self]. self emitPrologue. ^ instructions ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! emitEpilogue: popExtraBytes assembler: asm asm leave. popExtraBytes > 0 ifTrue: [ asm ret: popExtraBytes asUImm ] ifFalse: [ asm ret. ].! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! newCdeclCall self stackFrameCheck. ^ calls add: (AJCdeclCallInfo new)! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! newStdCall self stackFrameCheck. ^ calls add: (AJStdCallCallInfo new) ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! noStackFrame noStackFrame := true.! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! releaseTemps: count temps := temps - count! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! reserveExtraBytesOnStack: numBytes self stackFrameCheck. extraStackBytes := numBytes ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! reserveTemp: anAJReserveTemp self stackFrameCheck. temps := temps + 1. maxTemps := maxTemps max: temps . anAJReserveTemp operand: (assembler strackFrameValueAtOffset: extraStackBytes + (temps * assembler wordSize )).! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! stackFrameCheck noStackFrame ifTrue: [ self error: 'Operation requires stack frame management to be enabled for generated code' ].! ! !AJRoutineStackManager methodsFor: 'emitting'! emitPrologue noStackFrame == true ifTrue: [ ^self ]. instructions do: [:each | each setPrologue: (assembler instructionsFor: [ | numBytes | assembler push: assembler EBP; mov: assembler ESP to: assembler EBP. numBytes := extraStackBytes. numBytes := numBytes + (maxTemps * assembler wordSize ). numBytes > 0 ifTrue: [ (assembler sub: assembler ESP with: numBytes) annotation: extraStackBytes asString , ' extra bytes + ' , maxTemps asString , ' temps' ] ]). ] ! ! !AJRoutineStackManager methodsFor: 'initialize-release'! initialize self reset. noStackFrame := false.! ! !AJRoutineStackManager methodsFor: 'initialize-release'! reset instructions := nil. assembler := nil. calls := OrderedCollection new. temps := maxTemps := extraStackBytes := 0. ! ! AJInstruction subclass: #AJStackInstruction instanceVariableNames: 'callInfo' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJStackInstruction methodsFor: 'accessing'! callInfo ^ callInfo! ! !AJStackInstruction methodsFor: 'accessing'! callInfo: anObject callInfo := anObject! ! AJCallInfo subclass: #AJStdCallCallInfo instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJStdCallCallInfo commentStamp: 'IgorStasenko 8/5/2011 06:17' prior: 0! stdcall calling convention. Used on windows. No need for stack cleanup after call. No need to align stack before making call.! !AJStdCallCallInfo methodsFor: 'emitting code'! emitAlignment "do nothing" "stdcall calling convention requires no stack alignment, no stack cleanup after call"! ! !AJStdCallCallInfo methodsFor: 'emitting code'! emitAlignmentIfNeeded "do nothing" "stdcall calling convention requires no stack alignment, no stack cleanup after call"! ! AJx86Assembler subclass: #AJx64Assembler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86'! !AJx64Assembler commentStamp: '' prior: 0! I am an assembler for the Intel x86-64 architecture.! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 18:17'! instructionDesciptions ^ AJx64InstructionDescription instructions! ! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:25'! newInstruction ^ AJx64Instruction new! ! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:24'! newJumpInstruction ^ AJx64JumpInstruction new! ! !AJx64Assembler methodsFor: 'accessing'! numGPRegisters ^ 16! ! !AJx64Assembler methodsFor: 'accessing'! pointerSize "see AJx86Assembler >> #pointerSize" ^ 8! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EIP "A 32bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ EIP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! IP "A 16bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ IP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10 "A 64bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10B "A 8bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10D "A 32bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10W "A 16bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11 "A 64bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11B "A 8bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11D "A 32bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11W "A 16bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12 "A 64bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12B "A 8bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12D "A 32bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12W "A 16bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13 "A 64bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R13B "A 8bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13D "A 32bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13W "A 16bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14 "A 64bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14B "A 8bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14D "A 32bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14W "A 16bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15 "A 64bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15B "A 8bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15D "A 32bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15W "A 16bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8 "A 64bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8B "A 8bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8D "A 32bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8W "A 16bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9 "A 64bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R9B "A 8bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9D "A 32bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9W "A 16bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RAX "A 64bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ RAX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RBP "A 64bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ RBP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RBX "A 64bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ RBX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RCX "A 64bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ RCX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RDI "A 64bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ RDI! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RDX "A 64bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ RDX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RIP "A 64bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ RIP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RSI "A 64bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ RSI! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RSP "A 64bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ RSP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM10 "An SSE register" ^ XMM10! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM11 "An SSE register" ^ XMM11! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM12 "An SSE register" ^ XMM12! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM13 "An SSE register" ^ XMM13! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM14 "An SSE register" ^ XMM14! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM15 "An SSE register" ^ XMM15! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM8 "An SSE register" ^ XMM8! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM9 "An SSE register" ^ XMM9! ! !AJx64Assembler methodsFor: 'initialize-release' stamp: 'CamilloBruni 4/17/2012 18:16'! initialize super initialize. is64 := true.! ! !AJx64Assembler methodsFor: 'register'! accumulator ^ RAX! ! !AJx64Assembler methodsFor: 'register'! basePointer ^ RBP ! ! !AJx64Assembler methodsFor: 'register'! counter ^ RCX! ! !AJx64Assembler methodsFor: 'register'! data ^ RDX! ! !AJx64Assembler methodsFor: 'register'! destinationIndex ^ RDI! ! !AJx64Assembler methodsFor: 'register'! instructionPointer ^ RIP! ! !AJx64Assembler methodsFor: 'register'! sourceIndex ^ RSI! ! !AJx64Assembler methodsFor: 'register'! stackPointer ^ RSP! ! !AJx64Assembler methodsFor: 'testing'! is32 ^ false! ! AJx86Instruction subclass: #AJx64Instruction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx64Instruction methodsFor: 'accessing'! instructionDesciptions ^ AJx64InstructionDescription instructions! ! !AJx64Instruction methodsFor: 'testing'! is32BitMode ^ false! ! !AJx64Instruction methodsFor: 'testing'! is64BitMode ^ true! ! AJx86InstructionDescription subclass: #AJx64InstructionDescription instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx64InstructionDescription methodsFor: 'code emitting'! emitalu: emitter operand1: op1 operand2: op2 operand3: op3 | opCode opReg | opCode := opCode1. opReg := opCodeR. " Mem <- Reg " (op1 isMem and: [ op2 isReg ]) ifTrue: [ ^ emitter emitX86RM: opCode + op2 isRegTypeGPB not asBit size: op2 size regOrCode: op2 rm: op1 ]. "Reg <- Reg|Mem" (op1 isReg and: [op2 isRegMem]) ifTrue: [ (op2 isReg and: [op1 size ~= op2 size]) ifTrue: [ self invalidInstruction ]. self upperBankHighByteGuardOp1: op1 op2: op2. ^ emitter emitX86RM: opCode + 2 + op1 isRegTypeGPB not asBit size: op1 size regOrCode: op1 rm: op2 ]. op2 isImm ifFalse: [ self invalidInstruction ]. " AL, AX, EAX, RAX register shortcuts" (op1 isRegIndex: 0) ifTrue: [ op1 is16 ifTrue: [ emitter emitByte: 16r66 " 16 bit " ]. op1 is64 ifTrue: [ emitter emitByte: 16r48 " REX.W" ]. emitter emitByte: (opReg << 3 bitOr: (16r04 + op1 isRegTypeGPB not asBit)). ^ emitter emitImmediate: op2 size: (op1 size min: 4) ]. "short constant" op2 isInt8 ifTrue: [ | szBits | szBits := op1 size = 1 ifTrue: [ 0 ] ifFalse: [ 3 ]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: 1. ^ emitter emitImmediate: op2 size: 1. ]. (op1 isRegMem) ifTrue: [ | immSize szBits | immSize := op2 isInt8 ifTrue: [1] ifFalse: [ op1 size min: 4]. szBits := op1 size ~= 1 ifTrue: [ immSize ~= 1 ifTrue: [1] ifFalse: [3]] ifFalse: [ 0]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: immSize. ^ emitter emitImmediate: op2 size: immSize. ]. self invalidInstruction. ! ! !AJx64InstructionDescription methodsFor: 'code emitting'! emitbswap: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ emitter emitRexForSingleOperand: op1. emitter emitByte: 16r0F. ^ emitter emitModR: 1 r: op1 code ]. self invalidInstruction.! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: 'CamilloBruni 4/17/2012 18:43'! emitcall: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isReg and: [ op1 is64 and: [ op1 isUpperBank not ]]) ifTrue: [ "shortcut" emitter emitByte: 16rFF. op1 emitModRM: emitter code: 2 immSize: 4. ^ self]. (op1 isMem and: [op1 hasBase and: [ op1 base is64 and: [ op1 base isUpperBank not ]]]) ifTrue: [ "shortcut" emitter emitByte: 16rFF. op1 emitModRM: emitter code: 2 immSize: 4. ^ self]. (op1 isMem or: [ op1 isReg and: [ op1 is64 ] ]) ifTrue: [ ^ emitter emitX86RM: 16rFF size: 4 regOrCode: 2 rm: op1 ]. op1 isImm ifTrue: [ "call by relative offset, you should be really sure what you're' doing" emitter emitByte: 16rE8. op1 emitUsing: emitter size: 4. ^ self. ]. op1 isLabel ifTrue: [ emitter emitByte: 16rE8. emitter emitDisplacement: op1 inlinedDisp: -4. ^ self ]. self invalidInstruction. ! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: 'IgorStasenko 5/28/2012 03:01'! emitmov: emitter operand1: dst operand2: src operand3: op3 src isReg & dst isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ]. " reg <- mem " dst isReg & src isRegMem ifTrue: [ self assert: (dst isRegTypeGPB | dst isRegTypeGPW | dst isRegTypeGPD | dst isRegTypeGPQ ). src isMem ifTrue: [ (src base notNil and: [ src base is64 not ]) ifTrue: [ Error signal: 'use a 64bit base register instead of ', src base asString, '(', (src base size * 8) asString, 'bit) for memory access on a 64bit CPU' ]] ifFalse:[ (src size = dst size) ifFalse: [ Error signal: 'source ',src asString,' and destination ',dst asString,' need to have the same size' ]]. ^ emitter emitX86RM: 16r0000008A + dst isRegTypeGPB not asBit size: dst size regOrCode: dst rm: src ]. " reg <- imm " dst isReg & src isImm ifTrue: [ | immSize | immSize := dst size. "Optimize instruction size by using 32 bit immediate if value can fit to it" emitter is64BitMode & immSize = 8 & src isInt32 & (src relocMode == #RelocNone) ifTrue: [ emitter emitX86RM: 16rC7 size: dst size regOrCode: 0 rm: dst. immSize := 4 ] ifFalse: [ emitter emitX86Inl: (immSize=1 ifTrue: [16rB0] ifFalse: [16rB8]) reg: dst. ]. ^ emitter emitImmediate: src size: immSize ]. "mem <- reg" dst isMem & src isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ^ emitter emitX86RM: 16r88 + src isRegTypeGPB not asBit size: src size regOrCode: src rm: dst ]. "mem <- imm" dst isMem & src isImm ifTrue: [ | immSize | immSize := dst size <= 4 ifTrue: [ dst size ] ifFalse: [4]. emitter emitX86RM: 16rC6 + ((dst size = 1) not) asBit size: dst size regOrCode: 0 rm: dst immSize: immSize. ^ emitter emitImmediate: src size: immSize ]. self invalidInstruction ! ! !AJx64InstructionDescription methodsFor: 'code emitting'! emitmovPtr: emitter operand1: op1 operand2: op2 operand3: op3 | reg imm opCode | (op1 isReg & op2 isImm) | (op1 isImm & op2 isReg) ifFalse: [ self invalidInstruction ]. opCode := op1 isReg ifTrue: [reg := op1. imm := op2. 16rA0] ifFalse: [reg := op2. imm := op1. 16rA2]. reg index ~= 0 ifTrue: [ self invalidInstruction ]. reg isRegTypeGPW ifTrue: [ emitter emitByte: 16r66 ]. emitter emitRexForSingleOperand: reg. emitter emitByte: opCode + (reg size ~=1) asBit. emitter emitImmediate: imm size: reg size ! ! !AJx64InstructionDescription methodsFor: 'code emitting'! emitmovSxZx: emitter operand1: dst operand2: src operand3: op3 dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. (src size >= dst size) ifTrue: [ self invalidInstruction ]. dst isGeneralPurpose ifFalse: [ self invalidInstruction ]. src is16 ifTrue: [ ^ emitter emitX86RM: opCode1 + 1 size: dst size regOrCode: dst rm: src ]. src is32 ifTrue: [ self invalidInstruction ]. "64 bit source" self upperBankHighByteGuardOp1: dst op2: src. emitter emitX86RM: opCode1 size: dst size regOrCode: dst rm: src ! ! !AJx64InstructionDescription methodsFor: 'code emitting'! emitpop: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ self assert: op1 isGeneralPurpose. (op1 is32 or: [ op1 is8 ]) ifTrue: [ Error signal: 'invalid register ', op1 name, '. push/pop requires 64bit/16bit reg in 64bit mode']. ^ emitter emitX86Inl: opCode1 reg: op1 withRex: op1 isUpperBank. ]. op1 isMem ifFalse: [ self invalidInstruction ]. emitter emitX86RM: opCode2 size: op1 size regOrCode: opCodeR rm: op1 ! ! AJx86JumpInstruction subclass: #AJx64JumpInstruction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx64JumpInstruction methodsFor: 'accessing'! instructionDesciptions ^ AJx64InstructionDescription instructions! ! AJx86GPRegister subclass: #AJx64RipRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'AsmJit-x86-Operands'! !AJx64RipRegister commentStamp: '' prior: 0! Virtual registers used for relative instruction pointer addressing in 64Bit mode In IA-32 architecture and compatibility mode, addressing relative to the instruction pointer is available only with control-transfer instructions. In 64-bit mode, instruc- tions that use ModR/M addressing can use RIP-relative addressing. Without RIP-rela- tive addressing, all ModR/M instruction modes address memory relative to zero.! !AJx64RipRegister methodsFor: 'accessing'! code self ripAccessError! ! !AJx64RipRegister methodsFor: 'accessing'! index self ripAccessError! ! !AJx64RipRegister methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 12:48'! influencingRegisters self is16 ifFalse: [ ^ self as16 influencingRegisters ]. ^ { self as16. self as32. self as64 }! ! !AJx64RipRegister methodsFor: 'converting'! as16 ^ AJx86Registers at: #IP! ! !AJx64RipRegister methodsFor: 'converting'! as32 ^ AJx86Registers at: #EIP! ! !AJx64RipRegister methodsFor: 'converting'! as64 ^ AJx86Registers at: #RIP! ! !AJx64RipRegister methodsFor: 'converting'! as8 self error: 'No 8bit register available for instruction pointer relative addressing'! ! !AJx64RipRegister methodsFor: 'error'! ripAccessError self error: 'RIP register ', self name, ' cannot be used only for relative addressing'! ! !AJx64RipRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:08'! descriptionOn: s s nextPutAll: 'A '; print: self size * 8; nextPutAll: 'bit instruction pointer register'.! ! !AJx64RipRegister methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJx64RipRegister methodsFor: 'testing'! isRip ^ true! ! !AJx64RipRegister methodsFor: 'testing'! isUpperBank ^ false! ! !AJx64RipRegister methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 11:01'! isX86 ^ false! ! AJAssembler subclass: #AJx86Assembler instanceVariableNames: 'instructions last labels stackManager level is64' classVariableNames: '' poolDictionaries: 'AJConstants AJx86Registers' category: 'AsmJit-x86'! !AJx86Assembler commentStamp: '' prior: 0! I am an Assmbler for the Intel x86 (32Bit) architecture. Example: asm := AJx64Assembler new. "by default the assembler will set up a stack frame" asm noStackFrame. "load the constant 16r12 into the RAX register" asm mov: 16r12 to: asm RAX. "output the bytes for this instruction" asm bytes ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:26'! newInstruction ^ AJx86Instruction new! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 8/22/2012 14:26'! newJumpInstruction ^ AJx86JumpInstruction new! ! !AJx86Assembler methodsFor: 'accessing'! numGPRegisters "answer the total number of general-purpose registers for target platform" ^ 8 ! ! !AJx86Assembler methodsFor: 'accessing'! pointerSize "the default pointer size in bytes on this CPU" ^ 4! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2012 14:43'! reg16: index "answer one of 16bit general-purpose registers, based on index" | code | index < 0 ifTrue: [ self invalidRegisterIndex ]. (index >= self numGPRegisters) ifTrue: [ self invalidRegisterIndex ]. code := 16r10 + index. ^ AJx86Registers code: code! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2012 14:43'! reg32: index "answer one of 32bit general-purpose registers, based on index" | code | index < 0 ifTrue: [ self invalidRegisterIndex ]. (index >= self numGPRegisters) ifTrue: [ self invalidRegisterIndex ]. code := 16r20 + index. ^ AJx86Registers code: code! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2012 14:43'! reg8: index "answer one of 8bit general-purpose registers, based on index" index < 0 ifTrue: [ self invalidRegisterIndex ]. (index >= self numGPRegisters) ifTrue: [ self invalidRegisterIndex ]. ^ AJx86Registers code: index! ! !AJx86Assembler methodsFor: 'accessing'! reg: index size: nBytes nBytes = 1 ifTrue: [ ^ self reg8: index ]. nBytes = 2 ifTrue: [ ^ self reg16: index ]. nBytes = 4 ifTrue: [ ^ self reg32: index ]. nBytes = 8 ifTrue: [ ^ self reg64: index ]. self error: 'invalid register size'.! ! !AJx86Assembler methodsFor: 'accessing'! stackManager: aStackManager stackManager := aStackManager ! ! !AJx86Assembler methodsFor: 'accessing'! undefinedLabels "answer a collection of labels, which having no defined position " | lbls | lbls := OrderedCollection new. labels keysAndValuesDo: [:key :value | value ifNil: [ lbls add: key] ]. ^ lbls! ! !AJx86Assembler methodsFor: 'accessing'! wordSize ^ 4! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AH "A 8bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ AH! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! AL "A 8bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ AL! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AX "A 16bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ AX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BH "A 8bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ BH! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BL "A 8bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ BL! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! BP "A 16bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ BP! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BX "A 16bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ BX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CH "A 8bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ CH! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CL "A 8bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ CL! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CX "A 16bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ CX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DH "A 8bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ DH! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DI "A 16bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ DI! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DL "A 8bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ DL! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DX "A 16bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ DX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EAX "A 32bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ EAX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBP "A 32bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ EBP! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBX "A 32bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ EBX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ECX "A 32bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ ECX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDI "A 32bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ EDI! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDX "A 32bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ EDX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ESI "A 32bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ ESI! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ESP "A 32bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ ESP! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM0 "An MMX register" ^ MM0! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM1 "An MMX register" ^ MM1! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM2 "An MMX register" ^ MM2! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM3 "An MMX register" ^ MM3! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM4 "An MMX register" ^ MM4! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM5 "An MMX register" ^ MM5! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM6 "An MMX register" ^ MM6! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM7 "An MMX register" ^ MM7! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! SI "A 16bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ SI! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! SP "A 16bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ SP! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST0 "A floating point register" ^ ST0! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST1 "A floating point register" ^ ST1! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST2 "A floating point register" ^ ST2! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST3 "A floating point register" ^ ST3! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST4 "A floating point register" ^ ST4! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST5 "A floating point register" ^ ST5! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST6 "A floating point register" ^ ST6! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST7 "A floating point register" ^ ST7! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM0 "An SSE register" ^ XMM0! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM1 "An SSE register" ^ XMM1! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM2 "An SSE register" ^ XMM2! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM3 "An SSE register" ^ XMM3! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM4 "An SSE register" ^ XMM4! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM5 "An SSE register" ^ XMM5! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM6 "An SSE register" ^ XMM6! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM7 "An SSE register" ^ XMM7! ! !AJx86Assembler methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:52'! align: aByteSize self addInstruction: (AJAlignmentInstruction align: aByteSize)! ! !AJx86Assembler methodsFor: 'alignment'! alignDouble self addInstruction: AJAlignmentInstruction alignDouble! ! !AJx86Assembler methodsFor: 'alignment'! alignQuad self addInstruction: AJAlignmentInstruction alignQuad! ! !AJx86Assembler methodsFor: 'alignment'! alignWord self addInstruction: AJAlignmentInstruction alignWord! ! !AJx86Assembler methodsFor: 'code generation'! bytes ^ self generatedCode bytes.! ! !AJx86Assembler methodsFor: 'code generation'! generatedCode ^ AJGeneratedCode new fromInstructions: self prepareInstructions. ! ! !AJx86Assembler methodsFor: 'code generation'! prepareInstructions "A final step before generating machine code: prepare instructions by injecting a stack alignment and reifying jump labels. Prepared instructions will contain machine code, ready for use " instructions := stackManager analyzeInstructions: instructions assembler: self. instructions emitCodeAtOffset: 0 assembler: self. ^ instructions! ! !AJx86Assembler methodsFor: 'convenience'! db: aByteValue ^ self addInstruction: (AJData byte: aByteValue)! ! !AJx86Assembler methodsFor: 'convenience' stamp: 'CamilloBruni 4/19/2012 13:20'! dd: aByteArray self assert: aByteArray size == SizeDWord. ^ self addInstruction: (AJData data: aByteArray)! ! !AJx86Assembler methodsFor: 'convenience'! dw: aByteArray self assert: aByteArray size == SizeWord. ^ self addInstruction: (AJData data: aByteArray)! ! !AJx86Assembler methodsFor: 'convenience'! mov: assoc "convenience" ^ self mov: assoc key to: assoc value! ! !AJx86Assembler methodsFor: 'convenience' stamp: 'IgorStasenko 5/26/2012 15:14'! mov: src to: dest "Ensure right src/dest order" src = dest ifTrue: [ ^ self ]. "do not if source and dest are same " ^ self mov: dest with: src! ! !AJx86Assembler methodsFor: 'convenience'! movsx: src to: dest "Ensure right src/dest order" ^ self movsx: dest with: src! ! !AJx86Assembler methodsFor: 'convenience'! movzx: src to: dest "Ensure right src/dest order" ^ self movzx: dest with: src! ! !AJx86Assembler methodsFor: 'converting'! imm: value ^ value asImm ! ! !AJx86Assembler methodsFor: 'converting'! operand: anObject anObject isInteger ifTrue: [ ^ anObject asImm ]. anObject isString ifTrue: [ ^ anObject ]. ^ anObject! ! !AJx86Assembler methodsFor: 'debugging'! gccDisassemble ^ self gccDisassemble: self bytes.! ! !AJx86Assembler methodsFor: 'debugging' stamp: 'CamilloBruni 7/23/2012 15:25'! gccDisassemble: bytes 'disas.sh' asFileReference delete writeStreamDo: [:s| s nextPutAll: '#!!/bin/bash'; lf; nextPutAll: 'gcc -g -O0 '; nextPutAll: (self is32 ifTrue: ['-m32'] ifFalse: [ '-m64' ]); nextPutAll: ' disas.test.c >> /dev/null 2>&1'; lf; nextPutAll: 'gdb -q -x gdb.commands a.out | grep "^0x" > disas.output'; lf]. 'gdb.commands' asFileReference delete writeStreamDo: [:s| s nextPutAll: 'b 4'; lf; nextPutAll: 'r'; lf; nextPutAll: 'x /'; print: bytes size; nextPutAll: 'xb &instructions'; lf; nextPutAll: 'x /'; print: bytes size; nextPutAll: 'ub &instructions'; lf; nextPutAll: 'disas &instructions &instructions+1'; lf; nextPutAll: 'q']. 'disas.test.c' asFileReference delete writeStreamDo: [ :f| { '#include '. 'void main() {' . 'const char instructions[]= {'. String streamContents: [:s| bytes do: [:b | s print: b] separatedBy: [ s << ', ']]. '};'. 'printf("%d", instructions);'. '}' } do: [:x | f nextPutAll: x value asString; lf ]]. Smalltalk at: #OSProcess ifPresent: [ :cls| cls waitForCommand: 'cd "', Smalltalk imagePath, '"; chmod a+x ./disas.sh; sh ./disas.sh'. ^ 'disas.output' asFileReference readStream contents asString]. self inform: 'OSProcess has to be installed to run gccDisassemble'.! ! !AJx86Assembler methodsFor: 'debugging' stamp: 'IgorStasenko 5/28/2012 02:25'! writeCodeToFile: aFileName aFileName asReference asReference delete writeStreamDo: [:s| s nextPutAll: self bytes ] ! ! !AJx86Assembler methodsFor: 'dnu' stamp: 'CamilloBruni 4/17/2012 17:51'! doesNotUnderstand: aMessage "try to dispatch a message based on instruction name" | sel pos | sel := aMessage selector. sel isBinary ifTrue: [ "binary selectors" ^ super doesNotUnderstand: aMessage ]. "use the first keyword to find the instruction" pos := sel indexOf: $:. pos > 0 ifTrue: [ sel := (sel first: pos - 1) asSymbol ]. self instructionDesciptions at: sel ifPresent: [ :description| ^ self addInstruction: sel description: description operands: aMessage arguments ]. ^ super doesNotUnderstand: aMessage! ! !AJx86Assembler methodsFor: 'function calls'! callCleanup: anAJCdeclCallInfo ^ self addInstruction: (AJCallCleanup new callInfo: anAJCdeclCallInfo )! ! !AJx86Assembler methodsFor: 'function calls'! cdeclCall: aBlock alignment: align ^ self performingCall: (self newCdeclCall alignment: align) in: aBlock ! ! !AJx86Assembler methodsFor: 'function calls'! newCdeclCall "answer an instance of CallInfo" ^ stackManager newCdeclCall asm: self.! ! !AJx86Assembler methodsFor: 'function calls'! newStdCall ^ stackManager newStdCall asm: self ! ! !AJx86Assembler methodsFor: 'function calls'! noticePush: numBytes forCall: aCallInfo self addInstruction: (AJCallArgument new size: numBytes; callInfo: aCallInfo ). ! ! !AJx86Assembler methodsFor: 'function calls'! performingCall: ci in: aBlock ci asm: self; alignmentInsertionPoint: last. aBlock value: ci. self callCleanup: ci.! ! !AJx86Assembler methodsFor: 'function calls'! pushArgument: anArgument forCall: call | arg argSize | arg := anArgument. anArgument isInteger ifTrue: [ arg := anArgument asImm size: call defaultArgumentSize. ]. self addInstruction: (AJCallArgument new size: arg stackSize; callInfo: call ). arg emitPushOnStack: self! ! !AJx86Assembler methodsFor: 'initialize-release' stamp: 'CamilloBruni 3/30/2012 16:20'! initialize is64 := false. self reset.! ! !AJx86Assembler methodsFor: 'initialize-release'! reset instructions := last := nil. labels := Dictionary new. stackManager ifNil: [stackManager := AJRoutineStackManager new.] ifNotNil: #reset. level := 0. self addInstruction: AJRoutinePrologue new. ! ! !AJx86Assembler methodsFor: 'instruction list'! addInstruction: anInstruction "add one or multiple instructions to the tail" instructions ifNil: [ instructions := anInstruction. ] ifNotNil: [ last := last last next: anInstruction. ]. anInstruction level: level. last := anInstruction last. ^ anInstruction ! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 4/17/2012 17:51'! addInstruction: sel description: description operands: operands ^ self addInstruction: (self newInstruction: sel description: description operands: operands)! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 4/25/2012 14:23'! addInstruction: sel operands: operands ^ self addInstruction: sel description: (self instructionDesciptions at: sel) operands: operands ! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 7/23/2012 13:29'! decorateWith: annotation during: aBlock self addInstruction: (AJInstructionDecoration new start annotation: annotation). level := level + 1. aBlock ensure: [ level := level - 1. self addInstruction: (AJInstructionDecoration new end annotation: annotation) ] ! ! !AJx86Assembler methodsFor: 'instruction list'! insert: i after: instruction | next | i ifNil: [ "nothing to insert" ^ self ]. i do: [:each | each increaseLevel: instruction level ]. next := instruction next. instruction next: i. i last next: next! ! !AJx86Assembler methodsFor: 'instruction list'! insert: newInstruction before: anInstruction "insert one or more instructions before an instruction" ^ instructions := instructions insert: newInstruction before: anInstruction! ! !AJx86Assembler methodsFor: 'instruction list'! instructionsFor: aBlockWithCode | old new | old := instructions. instructions := nil. [ aBlockWithCode value. ] ensure: [ new := instructions. instructions := old ]. ^ new! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 8/22/2012 14:24'! newInstruction: name description: description operands: operands "check if name is jump " description isJump ifTrue: [ ^ self newJumpInstruction: name description: description operands: operands ]. ^ self newInstruction name: name; description: description; operands: operands ! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 8/22/2012 14:43'! newJumpInstruction: name description: description operands: operands | jumpInstruction destination | jumpInstruction := self newJumpInstruction name: name; description: description. operands size ~= 1 ifTrue: [ Error signal: 'Jump instruction only takes one argument!!' ]. destination := operands first. destination isString ifTrue: [ ^ jumpInstruction label: (self labelNamed: destination) ]. destination isLabel ifTrue: [ ^ jumpInstruction label: destination ]. ^ self newInstruction name: name; description: description; operands: operands ! ! !AJx86Assembler methodsFor: 'instruction list'! replace: anInstruction with: otherInstructions "replace a single instruction with one or more other instructions" ^ instructions := instructions replace: anInstruction with: otherInstructions.! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! adc: aRegisterOrMemoryOperand with: aSource "Add with Carry " ^ self addInstruction: #adc operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! add: aRegisterOrMemoryOperand with: aSource "Add Pseudo Code ----------- DEST = DEST + SRC; Description ----------- Adds the destination operand (first operand) and the source operand (second operand) and then stores the result in the destination operand. The destination operand can be a register or a memory location; the source operand can be an immediate, a register, or a memory location. (However, two memory operands cannot be used in one instruction.) When an immediate value is used as an operand, it is sign-extended to the length of the destination operand format. The ADD instruction performs integer addition. It evaluates the result for both signed and unsigned integer operands and sets the OF and CF flags to indicate a carry (overflow) in the signed or unsigned result, respectively. The SF flag indicates the sign of the signed result. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #add operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! amdprefetch: aMemoryOperand " " ^ self addInstruction: #amdprefetch operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! amdprefetchw: aMemoryOperand " " ^ self addInstruction: #amdprefetchw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! and: aRegisterOrMemoryOperand with: aSource "Logical AND " ^ self addInstruction: #and operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bsf: aRegister with: aSourceRegisterOrMemory "Bit Scan Forward Description ----------- Searches the source operand (second operand) for the least significant set bit (1 bit). If a least significant 1 bit is found, its bit index is stored in the destination operand (first operand). The source operand can be a register or a memory location; the destination operand is a register. The bit index is an unsigned offset from bit 0 of the source operand. If the content of the source operand is 0, the content of the destination operand is undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bsf operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bsr: aRegister with: aSourceRegisterOrMemory "Bit Scan Reverse Description ----------- Searches the source operand (second operand) for the most significant set bit (1 bit). If a most significant 1 bit is found, its bit index is stored in the destination operand (first operand). The source operand can be a register or a memory location; the destination operand is a register. The bit index is an unsigned offset from bit 0 of the source operand. If the content source operand is 0, the content of the destination operand is undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bsr operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bswap: aDestinationRegister "Byte Swap Description ----------- Reverses the byte order of a 32-bit or 64-bit (destination) register. This instruction is provided for converting little-endian values to big-endian format and vice versa. To swap bytes in a word value (16-bit register), use the XCHG instruction. When the BSWAP instruction references a 16-bit register, the result is undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. IA-32 Architecture Legacy Compatibility The BSWAP instruction is not supported on IA-32 processors earlier than the Intel486™ processor family. For compatibility with this instruction, software should include functionally equivalent code for execution on Intel processors earlier than the Intel486 processor family. " ^ self addInstruction: #bswap operands: { aDestinationRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bt: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset (specified by the second operand) and stores the value of the bit in the CF flag. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. In this case, the low-order 3 or 5 bits (3 for 16-bit operands, 5 for 32-bit operands) of the immediate bit offset are stored in the immediate bit offset field, and the high-order bits are shifted and combined with the byte displacement in the addressing mode by the assembler. The processor will ignore the high order bits if they are not zero. When accessing a bit in memory, the processor may access 4 bytes starting from the memory address for a 32-bit operand size, using by the following relationship: Effective Address + (4 \* (BitOffset DIV 32)) Or, it may access 2 bytes starting from the memory address for a 16-bit operand, using this relationship: Effective Address + (2 \* (BitOffset DIV 16)) It may do so even when only a single byte needs to be accessed to reach the given bit. When using this bit addressing mechanism, software should avoid referencing areas of memory close to address space holes. In particular, it should avoid references to memory-mapped I/O registers. Instead, software should use the MOV instructions to load from or store to these addresses, and use the register form of these instructions to manipulate the data. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bit operands. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bt operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! btc: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test and Complement Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Bit(BitBase, BitOffset) = NOT Bit(BitBase, BitOffset); Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset operand (second operand), stores the value of the bit in the CF flag, and complements the selected bit in the bit string. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). This allows any bit position to be selected. - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. See 'BT—Bit Test' in this chapter for more information on this addressingmechanism. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #btc operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! btr: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test and Reset Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Bit(BitBase, BitOffset) = 0; Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset operand (second operand), stores the value of the bit in the CF flag, and clears the selected bit in the bit string to 0. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). This allows any bit position to be selected. - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. See 'BT—Bit Test' in this chapter for more information on this addressingmechanism. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #btr operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bts: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test and Set Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Bit(BitBase, BitOffset) = 1; Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset operand (second operand), stores the value of the bit in the CF flag, and sets the selected bit in the bit string to 1. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). This allows any bit position to be selected. - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. See 'BT—Bit Test' in this chapter for more information on this addressingmechanism. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bts operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! call: anAddressSource "Call Procedure Description ----------- Saves procedure linking information on the stack and branches to the called procedure specified using the target operand. The target operand specifies the address of the first instruction in the called procedure. The operand can be an immediate value, a general-purpose register, or a memory location. This instruction can be used to execute four types of calls: - Near Call — A call to a procedure in the current code segment (the segment currently pointed to by the CS register), sometimes referred to as an intrasegment call. - Far Call — A call to a procedure located in a different segment than the current code segment, sometimes referred to as an inter-segment call. - Inter-privilege-level far call — A far call to a procedure in a segment at a different privilege level than that of the currently executing program or procedure. - Task switch — A call to a procedure located in a different task. The latter two call types (inter-privilege-level call and task switch) can only be executed in protected mode. See 'Calling Procedures Using Call and RET' in Chapter6 of the Intel®64 and IA-32 Architectures Software Developer's Manual, Volume 1, for additional information on near, far, and inter-privilege-level calls. See Chapter 7,'Task Management,' in theIntel® 64 and IA-32 Architectures Software Developer'sManual, Volume 3A, for information on performing task switches with the CALL instruction. Near Call. When executing a near call, the processor pushes the value of the EIP register (which contains the offset of the instruction following the CALL instruction) on the stack (for use later as a return-instruction pointer). The processor then branches to the address in the current code segment specified by the target operand. The target operand specifies either an absolute offset in the code segment (an offset from the base of the code segment) or a relative offset (a signed displacement relative to the current value of the instruction pointer in the EIP register; this value points to the instruction following the CALL instruction). The CS register is not changed on near calls. For a near call absolute, an absolute offset is specified indirectly in a general-purpose register or a memory location (r/m16, r/m32, or r/m64). The operand-size attribute determines the size of the target operand (16, 32 or 64 bits). When in 64-bit mode, the operand size for near call (and all near branches) is forced to 64-bits. Absolute offsets are loaded directly into the EIP(RIP) register. If the operand size attribute is 16, the upper two bytes of the EIP register are cleared, resulting in a maximum instruction pointer size of 16 bits. When accessing an absolute offset indirectly using the stack pointer [ESP] as the base register, the base value used is the value of the ESP before the instruction executes. A relative offset (rel16 or rel32) is generally specified as a label in assembly code. But at the machine code level, it is encoded as a signed, 16- or 32-bit immediate value. This value is added to the value in the EIP(RIP) register. In 64-bit mode the relative offset is always a 32-bit immediate value which is sign extended to 64-bits before it is added to the value in the RIP register for the target calculation. As with absolute offsets, the operand-size attribute determines the size of the target operand (16, 32, or 64 bits). In 64-bit mode the target operand will always be 64-bits because the operand size is forced to 64-bits for near branches. Far Calls in Real-Address or Virtual-8086 Mode. When executing a far call in real- address or virtual-8086 mode, the processor pushes the current value of both the CS and EIP registers on the stack for use as a return-instruction pointer. The processor then performs a 'far branch' to the code segment and offset specified with the target operand for the called procedure. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). With the pointer method, the segment and offset of the called procedure is encoded in the instruction using a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address immediate. With the indirect method, the target operand specifies a memory location that contains a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address. The operand-size attribute determines the size of the offset (16 or 32 bits) in the far address. The far address is loaded directly into the CS and EIP registers. If the operand-size attribute is 16, the upper two bytes of the EIP register are cleared. Far Calls in Protected Mode. When the processor is operating in protected mode, the CALL instruction can be used to perform the following types of far calls: - Far call to the same privilege level - Far call to a different privilege level (inter-privilege level call) - Task switch (far call to another task) In protected mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate, task gate, or TSS) and access rights determine the type of call operation to be performed. If the selected descriptor is for a code segment, a far call to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far call to the same privilege level in protected mode is very similar to one carried out in real-address or virtual-8086 mode. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The operand- size attribute determines the size of the offset (16 or 32 bits) in the far address. The new code segment selector and its descriptor are loaded into CS register; the offset from the instruction is loaded into the EIP register. A call gate (described in the next paragraph) can also be used to perform a far call to a code segment at the same privilege level. Using this mechanism provides an extra level of indirection and is the preferred method of making calls between 16-bit and 32-bit code segments. When executing an inter-privilege-level far call, the code segment for the procedure being called must be accessed through a call gate. The segment selector specified by the target operand identifies the call gate. The target operand can specify the call gate segment selector either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The processor obtains the segment selector for the new code segment and the new instruction pointer (offset) from the call gate descriptor. (The offset from the target operand is ignored when a call gate is used.) On inter-privilege-level calls, the processor switches to the stack for the privilege level of the called procedure. The segment selector for the new stack segment is specified in the TSS for the currently running task. The branch to the new code segment occurs after the stack switch. (Note that when using a call gate to perform a far call to a segment at the same privilege level, no stack switch occurs.) On the new stack, the processor pushes the segment selector and stack pointer for the calling procedure's stack, an optional set of parameters from the calling procedures stack, and the segment selector and instruction pointer for the calling procedure's code segment. (A value in the call gate descriptor determines how many parameters to copy to the new stack.) Finally, the processor branches to the address of the procedure being called within the new code segment. Executing a task switch with the CALL instruction is similar to executing a call through a call gate. The target operand specifies the segment selector of the task gate for the new task activated by the switch (the offset in the target operand is ignored). The task gate in turn points to the TSS for the new task, which contains the segment selectors for the task's code and stack segments. Note that the TSS also contains the EIP value for the next instruction that was to be executed before the calling task was suspended. This instruction pointer value is loaded into the EIP register to re-start the calling task. The CALL instruction can also specify the segment selector of the TSS directly, which eliminates the indirection of the task gate. See Chapter 7, 'Task Management,' in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 3A, for information on the mechanics of a task switch. When you execute at task switch with a CALL instruction, the nested task flag (NT) is set in the EFLAGS register and the new TSS's previous task link field is loaded with the old task's TSS selector. Code is expected to suspend this nested task by executing an IRET instruction which, because the NT flag is set, automatically uses the previous task link to return to the calling task. (See 'Task Linking' in Chapter 7 ofthe Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 3A, for information on nested tasks.) Switching tasks with the CALL instruction differs in this regard from JMP instruction. JMP does not set the NT flag and therefore does not expect an IRET instruction to suspend the task. Mixing 16-Bit and 32-Bit Calls. When making far calls between 16-bit and 32-bit code segments, use a call gate. If the far call is from a 32-bit code segment to a 16-bit code segment, the call should be made from the first 64 KBytes of the 32-bit code segment. This is because the operand-size attribute of the instruction is set to 16, so only a 16-bit return address offset can be saved. Also, the call should be made using a 16-bit call gate so that 16-bit values can be pushed on the stack. See Chapter 18,'Mixing 16-Bit and 32-Bit Code,' in theIntel® 64 and IA-32 Architectures SoftwareDeveloper's Manual, Volume 3A, for more information. Far Calls in Compatibility Mode. When the processor is operating in compatibility mode, the CALL instruction can be used to perform the following types of far calls: - Far call to the same privilege level, remaining in compatibility mode - Far call to the same privilege level, transitioning to 64-bit mode - Far call to a different privilege level (inter-privilege level call), transitioning to 64bit mode Note that a CALL instruction can not be used to cause a task switch in compatibility mode since task switches are not supported in IA-32e mode. In compatibility mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate) and access rights determine the type of call operation to be performed. If the selected descriptor is for a code segment, a far call to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far call to the same privilege level in compatibility mode is very similar to one carried out in protected mode. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The operand-size attribute determines the size of the offset (16 or 32 bits) in the far address. The new code segment selector and its descriptor are loaded into CS register and the offset from the instruction is loaded into the EIP register. The difference is that 64-bit mode may be entered. This specified by the L bit in the new code segment descriptor. Note that a 64-bit call gate (described in the next paragraph) can also be used to perform a far call to a code segment at the same privilege level. However, using this mechanism requires that the target code segment descriptor have the L bit set, causing an entry to 64-bit mode. When executing an inter-privilege-level far call, the code segment for the procedure being called must be accessed through a 64-bit call gate. The segment selector specified by the target operand identifies the call gate. The target operand can specify the call gate segment selector either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The processor obtains the segment selector for the new code segment and the new instruction pointer (offset) from the 16-byte call gate descriptor. (The offset from the target operand is ignored when a call gate is used.) On inter-privilege-level calls, the processor switches to the stack for the privilege level of the called procedure. The segment selector for the new stack segment is set to NULL. The new stack pointer is specified in the TSS for the currently running task. The branch to the new code segment occurs after the stack switch. (Note that when using a call gate to perform a far call to a segment at the same privilege level, an implicit stack switch occurs as a result of entering 64-bit mode. The SS selector is unchanged, but stack segment accesses use a segment base of 0x0, the limit is ignored, and the default stack size is 64-bits. The full value of RSP is used for the offset, of which the upper 32-bits are undefined.) On the new stack, the processor pushes the segment selector and stack pointer for the calling procedure's stack and the segment selector and instruction pointer for the calling procedure's code segment. (Parameter copy is not supported in IA-32e mode.) Finally, the processor branches to the address of the procedure being called within the new code segment. Near/(Far) Calls in 64-bit Mode. When the processor is operating in 64-bit mode, the CALL instruction can be used to perform the following types of far calls: - Far call to the same privilege level, transitioning to compatibility mode - Far call to the same privilege level, remaining in 64-bit mode - Far call to a different privilege level (inter-privilege level call), remaining in 64-bit mode Note that in this mode the CALL instruction can not be used to cause a task switch in 64-bit mode since task switches are not supported in IA-32e mode. In 64-bit mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate) and access rights determine the type of call operation to be performed. If the selected descriptor is for a code segment, a far call to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far call to the same privilege level in 64-bit mode is very similar to one carried out in compatibility mode. The target operand specifies an absolute far address indirectly with a memory location (m16:16, m16:32 or m16:64). The form of CALL with a direct specification of absolute far address is not defined in 64-bit mode. The operand-size attribute determines the size of the offset (16, 32, or 64 bits) in the far address. The new code segment selector and its descriptor are loaded into the CS register; the offset from the instruction is loaded into the EIP register. The new code segment may specify entry either into compatibility or 64-bit mode, based on the L bit value. A 64-bit call gate (described in the next paragraph) can also be used to perform a far call to a code segment at the same privilege level. However, using this mechanism requires that the target code segment descriptor have the L bit set. When executing an inter-privilege-level far call, the code segment for the procedure being called must be accessed through a 64-bit call gate. The segment selector specified by the target operand identifies the call gate. The target operand can only specify the call gate segment selector indirectly with a memory location (m16:16, m16:32 or m16:64). The processor obtains the segment selector for the new code segment and the new instruction pointer (offset) from the 16-byte call gate descriptor. (The offset from the target operand is ignored when a call gate is used.) On inter-privilege-level calls, the processor switches to the stack for the privilege level of the called procedure. The segment selector for the new stack segment is set to NULL. The new stack pointer is specified in the TSS for the currently running task. The branch to the new code segment occurs after the stack switch. Note that when using a call gate to perform a far call to a segment at the same privilege level, an implicit stack switch occurs as a result of entering 64-bit mode. The SS selector is unchanged, but stack segment accesses use a segment base of 0x0, the limit is ignored, and the default stack size is 64-bits. (The full value of RSP is used for the offset.) On the new stack, the processor pushes the segment selector and stack pointer for the calling procedure's stack and the segment selector and instruction pointer for the calling procedure's code segment. (Parameter copy is not supported in IA-32e mode.) Finally, the processor branches to the address of the procedure being called within the new code segment. " ^ self addInstruction: #call operands: { anAddressSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! clflush: aMemoryOperand "Flush Cache Line Pseudo Code ----------- Flush_Cache_Line(SRC); Description ----------- Invalidates the cache line that contains the linear address specified with the source operand from all levels of the processor cache hierarchy (data and instruction). The invalidation is broadcast throughout the cache coherence domain. If, at any level of the cache hierarchy, the line is inconsistent with memory (dirty) it is written to memory before invalidation. The source operand is a byte memory location. The availability of CLFLUSH is indicated by the presence of the CPUID feature flag CLFSH (bit 19 of the EDX register, see 'CPUID—CPU Identification' in this chapter).The aligned cache line size affected is also indicated with the CPUID instruction (bits 8 through 15 of the EBX register when the initial value in the EAX register is 1). The memory attribute of the page containing the affected line has no effect on the behavior of this instruction. It should be noted that processors are free to speculatively fetch and cache data from system memory regions assigned a memory-type allowing for speculative reads (such as, the WB, WC, and WT memory types). PREFETCHh instructions can be used to provide the processor with hints for this speculative behavior. Because this speculative fetching can occur at any time and is not tied to instruction execution, the CLFLUSH instruction is not ordered with respect to PREFETCHh instructions or any of the speculative fetching mechanisms (that is, data can be speculatively loaded into a cache line just before, during, or after the execution of a CLFLUSH instruction that references the cache line). CLFLUSH is only ordered by the MFENCE instruction. It is not guaranteed to be ordered by any other fencing or serializing instructions or by another CLFLUSH instruction. For example, software can use an MFENCE instruction to ensure that previous stores are included in the write-back. The CLFLUSH instruction can be used at all privilege levels and is subject to all permission checking and faults associated with a byte load (and in addition, a CLFLUSH instruction is allowed to flush a linear address in an execute-only segment). Like a load, the CLFLUSH instruction sets the A bit but not the D bit in the page tables. The CLFLUSH instruction was introduced with the SSE2 extensions; however, because it has its own CPUID feature flag, it can be implemented in IA-32 processors that do not include the SSE2 extensions. Also, detecting the presence of the SSE2 extensions with the CPUID instruction does not guarantee that the CLFLUSH instruction is implemented in the processor. CLFLUSH operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #clflush operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmova: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmova operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovae: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovae operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovb: aRegister with: aSourceRegisterOrMemory "Conditional Move - below/not above or equal/carry (CF=1) " ^ self addInstruction: #cmovb operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovbe: aRegister with: aSourceRegisterOrMemory "Conditional Move - below or equal/not above (CF=1 AND ZF=1) " ^ self addInstruction: #cmovbe operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovc: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovc operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmove: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmove operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovg: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovg operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovge: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovge operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovl: aRegister with: aSourceRegisterOrMemory "Conditional Move - less/not greater (SF!!=OF) " ^ self addInstruction: #cmovl operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovle: aRegister with: aSourceRegisterOrMemory "Conditional Move - less or equal/not greater ((ZF=1) OR (SF!!=OF)) " ^ self addInstruction: #cmovle operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovna: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovna operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnae: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnae operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnb: aRegister with: aSourceRegisterOrMemory "Conditional Move - not below/above or equal/not carry (CF=0) " ^ self addInstruction: #cmovnb operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnbe: aRegister with: aSourceRegisterOrMemory "Conditional Move - not below or equal/above (CF=0 AND ZF=0) " ^ self addInstruction: #cmovnbe operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnc: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnc operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovne: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovne operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovng: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovng operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnge: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnge operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnl: aRegister with: aSourceRegisterOrMemory "Conditional Move - not less/greater or equal (SF=OF) " ^ self addInstruction: #cmovnl operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnle: aRegister with: aSourceRegisterOrMemory "Conditional Move - not less nor equal/greater ((ZF=0) AND (SF=OF)) " ^ self addInstruction: #cmovnle operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovno: aRegister with: aSourceRegisterOrMemory "Conditional Move - not overflow (OF=0) " ^ self addInstruction: #cmovno operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnp: aRegister with: aSourceRegisterOrMemory "Conditional Move - not parity/parity odd " ^ self addInstruction: #cmovnp operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovns: aRegister with: aSourceRegisterOrMemory "Conditional Move - not sign (SF=0) " ^ self addInstruction: #cmovns operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnz: aRegister with: aSourceRegisterOrMemory "Conditional Move - not zero/not equal (ZF=1) " ^ self addInstruction: #cmovnz operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovo: aRegister with: aSourceRegisterOrMemory "Conditional Move - overflow (OF=1) " ^ self addInstruction: #cmovo operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovp: aRegister with: aSourceRegisterOrMemory "Conditional Move - parity/parity even (PF=1) " ^ self addInstruction: #cmovp operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovpe: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovpe operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovpo: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovpo operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovs: aRegister with: aSourceRegisterOrMemory "Conditional Move - sign (SF=1) " ^ self addInstruction: #cmovs operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovz: aRegister with: aSourceRegisterOrMemory "Conditional Move - zero/equal (ZF=0) " ^ self addInstruction: #cmovz operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmp: aRegisterOrMemoryOperand with: aSource "Compare Two Operands Pseudo Code ----------- temp = SRC1 - SignExtend(SRC2); ModifyStatusFlags; (* Modify status flags in the same manner as the SUB instruction *) Description ----------- Compares the first source operand with the second source operand and sets the status flags in the EFLAGS register according to the results. The comparison is performed by subtracting the second operand from the first operand and then setting the status flags in the same manner as the SUB instruction. When an immediate value is used as an operand, it is sign-extended to the length of the first operand. The condition codes used by the Jcc, CMOVcc, and SETcc instructions are based on the results of a CMP instruction. Appendix B, 'EFLAGS Condition Codes,' in theIntel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, shows the relationship of the status flags and the condition codes. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #cmp operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmpxchg16b: aMemoryOperand "... " ^ self addInstruction: #cmpxchg16b operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmpxchg8b: aMemoryOperand "Compare and Exchange Bytes " ^ self addInstruction: #cmpxchg8b operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmpxchg: aDestinationRegisterOrMemory with: aSourceRegister "Compare and Exchange Pseudo Code ----------- (* Accumulator = AL, AX, EAX, or RAX depending on whether a byte, word, doubleword, or quadword comparison is being performed *) IF accumulator = DEST ZF = 1; DEST = SRC; ELSE ZF = 0; accumulator = DEST; FI; Description ----------- Compares the value in the AL, AX, EAX, or RAX register with the first operand (destination operand). If the two values are equal, the second operand (source operand) is loaded into the destination operand. Otherwise, the destination operand is loaded into the AL, AX, EAX or RAX register. RAX register is available only in 64-bit mode. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. To simplify the interface to the processor's bus, the destination operand receives a write cycle without regard to the result of the comparison. The destination operand is written back if the comparison fails; otherwise, the source operand is written into the destination. (The processor never produces a locked read without also producing a locked write.) In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #cmpxchg operands: { aDestinationRegisterOrMemory . aSourceRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! crc32: aRegister with: aSourceRegisterOrMemory "Accumulate CRC32 Value Description ----------- Starting with an initial value in the first operand (destination operand), accumulates a CRC32 (polynomial 0x11EDC6F41) value for the second operand (source operand) and stores the result in the destination operand. The source operand can be a register or a memory location. The destination operand must be an r32 or r64 register. If the destination is an r64 register, then the 32-bit result is stored in the least significant double word and 00000000H is stored in the most significant double word of the r64 register. The initial value supplied in the destination operand is a double word integer stored in the r32 register or the least significant double word of the r64 register. To incrementally accumulate a CRC32 value, software retains the result of the previous CRC32 operation in the destination operand, then executes the CRC32 instruction again with new input data in the source operand. Data contained in the source operand is processed in reflected bit order. This means that the most significant bit of the source operand is treated as the least significant bit of the quotient, and so on, for all the bits of the source operand. Likewise, the result of the CRC operation is stored in the destination operand in reflected bit order. This means that the most significant bit of the resulting CRC (bit 31) is stored in the least significant bit of the destination operand (bit 0), and so on, for all the bits of the CRC. " ^ self addInstruction: #crc32 operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! dec: aRegisterOrMemory "Decrement by 1 Pseudo Code ----------- DEST = DEST - 1; Description ----------- Subtracts 1 from the destination operand, while preserving the state of the CF flag. The destination operand can be a register or a memory location. This instruction allows a loop counter to be updated without disturbing the CF flag. (To perform a decrement operation that updates the CF flag, use a SUB instruction with an immediate operand of 1.) This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, DEC r16 and DEC r32 are not encodable (because opcodes 48H through 4FH are REX prefixes). Otherwise, the instruction's 64-bit mode default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #dec operands: { aRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! div: aDestination "Unsigned Divide Description ----------- Divides unsigned the value in the AX, DX:AX, EDX:EAX, or RDX:RAX registers (dividend) by the source operand (divisor) and stores the result in the AX (AH:AL), DX:AX, EDX:EAX, or RDX:RAX registers. The source operand can be a general-purpose register or a memory location. The action of this instruction depends on the operand size (dividend/divisor). Division using 64-bit operand is available only in 64-bit mode. Non-integral results are truncated (chopped) towards 0. The remainder is always less than the divisor in magnitude. Overflow is indicated with the \#DE (divide error) exception rather than with the CF flag. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. In 64-bit mode when REX.W is applied, the instruction divides the unsigned value in RDX:RAX by the source operand and stores the quotient in RAX, the remainder in RDX. See the summary chart at the beginning of this section for encoding data and limits. See the following table. DIV Action Maximum Operand Size Dividend Divisor Quotient Remainder Quotient Word/byte AX r/m8 AL AH 255 Doubleword/word DX:AX r/m16 AX DX 65,535 Quadword/doubleword EDX:EAX r/m32 EAX EDX 2^32^ - 1 Doublequadword/quadword RDX:RAX r/m64 RAX RDX 2^64^ - 1 " ^ self addInstruction: #div operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! enter: stackFrameSize with: lexicalNesting "Make Stack Frame for Procedure Parameters Description ----------- Creates a stack frame for a procedure. The first operand (size operand) specifies the size of the stack frame (that is, the number of bytes of dynamic storage allocated on the stack for the procedure). The second operand (nesting level operand) gives the lexical nesting level (0 to 31) of the procedure. The nesting level determines the number of stack frame pointers that are copied into the 'display area' of the new stack frame from the preceding frame. Both of these operands are immediate values. The stack-size attribute determines whether the BP (16 bits), EBP (32 bits), or RBP (64 bits) register specifies the current frame pointer and whether SP (16 bits), ESP (32 bits), or RSP (64 bits) specifies the stack pointer. In 64-bit mode, stack-size attribute is always 64-bits. The ENTER and companion LEAVE instructions are provided to support block structured languages. The ENTER instruction (when used) is typically the first instruction in a procedure and is used to set up a new stack frame for a procedure. The LEAVE instruction is then used at the end of the procedure (just before the RET instruction) to release the stack frame. If the nesting level is 0, the processor pushes the frame pointer from the BP/EBP/RBP register onto the stack, copies the current stack pointer from the SP/ESP/RSP register into the BP/EBP/RBP register, and loads the SP/ESP/RSP register with the current stack-pointer value minus the value in the size operand. For nesting levels of 1 or greater, the processor pushes additional frame pointers on the stack before adjusting the stack pointer. These additional frame pointers provide the called procedure with access points to other nested frames on the stack. See 'Procedure Calls for Block-Structured Languages' in Chapter 6 of theIntel®64 and IA-32 ArchitecturesSoftware Developer's Manual, Volume 1, for more information about the actions of the ENTER instruction. The ENTER instruction causes a page fault whenever a write using the final value of the stack pointer (within the current stack segment) would do so. In 64-bit mode, default operation size is 64 bits; 32-bit operation size cannot be encoded. " ^ self addInstruction: #enter operands: { stackFrameSize . lexicalNesting }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fadd: aMemoryOperand "Add " ^ self addInstruction: #fadd operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fadd: aX87Register1 with: aX87Register2 " see #fadd" ^ self addInstruction: #fadd operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! faddp: aX87Register "Add and Pop " ^ self addInstruction: #faddp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fbld: aMemoryOperand "Load Binary Coded Decimal Pseudo Code ----------- TOP = TOP - 1; ST(0) = ConvertToDoubleExtendedPrecisionFP(SRC); Description ----------- Converts the BCD source operand into double extended-precision floating-point format and pushes the value onto the FPU stack. The source operand is loaded without rounding errors. The sign of the source operand is preserved, including that of -0. The packed BCD digits are assumed to be in the range 0 through 9; the instruction does not check for invalid digits (AH through FH). Attempting to load an invalid encoding produces an undefined result. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fbld operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fbstp: aMemoryOperand "Store BCD Integer and Pop Pseudo Code ----------- DEST = BCD(ST(0)); PopRegisterStack; Description ----------- Converts the value in the ST(0) register to an 18-digit packed BCD integer, stores the result in the destination operand, and pops the register stack. If the source value is a non-integral value, it is rounded to an integer value, according to rounding mode specified by the RC field of the FPU control word. To pop the register stack, the processor marks the ST(0) register as empty and increments the stack pointer (TOP) by 1. The destination operand specifies the address where the first byte destination value is to be stored. The BCD value (including its sign bit) requires 10 bytes of space in memory. The following table shows the results obtained when storing various classes of numbers in packed BCD format. ST(0) DEST ---------------------------------------- ------ - = or Value Too Large for DEST Format \* F \<= - 1 - D -1 \< F \< -0 \*\* - 0 - 0 + 0 + 0 + 0 \< F \< +1 \*\* F \>= +1 + D + = or Value Too Large for DEST Format \* NaN \* : FBSTP Results - Notes: - F refers to a finite floating-point value. - D refers to packed-BCD number. - \* Indicates floating-point invalid-operation (\#IA) exception. - \*\* ±0 or ±1, depending on the rounding mode. If the converted value is too large for the destination format, or if the source operand is an ∞, SNaN, QNAN, or is in an unsupported format, an invalid-arithmetic-operand condition is signaled. If the invalid-operation exception is not masked, an invalidarithmetic-operand exception (\#IA) is generated and no value is stored in the desti-nation operand. If the invalid-operation exception is masked, the packed BCD indefinite value is stored in memory. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fbstp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovb: aX87Register "FP Conditional Move - below (CF=1) " ^ self addInstruction: #fcmovb operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovbe: aX87Register "FP Conditional Move - below or equal (CF=1 or ZF=1) " ^ self addInstruction: #fcmovbe operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmove: aX87Register "FP Conditional Move - equal (ZF=1) " ^ self addInstruction: #fcmove operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovnb: aX87Register "FP Conditional Move - not below (CF=0) " ^ self addInstruction: #fcmovnb operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovnbe: aX87Register "FP Conditional Move - below or equal (CF=0 and ZF=0) " ^ self addInstruction: #fcmovnbe operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovne: aX87Register "FP Conditional Move - not equal (ZF=0) " ^ self addInstruction: #fcmovne operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovnu: aX87Register "FP Conditional Move - not unordered (PF=0) " ^ self addInstruction: #fcmovnu operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovu: aX87Register "FP Conditional Move - unordered (PF=1) " ^ self addInstruction: #fcmovu operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcom: aMemoryOperand "Compare Real " ^ self addInstruction: #fcom operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcom: aX87Register1 with: aX87Register2 " see #fcom" ^ self addInstruction: #fcom operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomi: aX87Register "Compare Floating Point Values and Set EFLAGS " ^ self addInstruction: #fcomi operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomip: aX87Register "Compare Floating Point Values and Set EFLAGS and Pop " ^ self addInstruction: #fcomip operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomp: aMemoryOperand "Compare Real and Pop " ^ self addInstruction: #fcomp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomp: aX87Register1 with: aX87Register2 " see #fcomp" ^ self addInstruction: #fcomp operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdiv: aMemoryOperand "Divide " ^ self addInstruction: #fdiv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdiv: aX87Register1 with: aX87Register2 " see #fdiv" ^ self addInstruction: #fdiv operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivp: aX87Register "Divide and Pop " ^ self addInstruction: #fdivp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivr: aMemoryOperand "Reverse Divide " ^ self addInstruction: #fdivr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivr: aX87Register1 with: aX87Register2 " see #fdivr" ^ self addInstruction: #fdivr operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivrp: aX87Register "Reverse Divide and Pop " ^ self addInstruction: #fdivrp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ffree: aX87Register "Free Floating-Point Register " ^ self addInstruction: #ffree operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fiadd: aMemoryOperand "Add " ^ self addInstruction: #fiadd operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ficom: aMemoryOperand "Compare Integer " ^ self addInstruction: #ficom operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ficomp: aMemoryOperand "Compare Integer and Pop " ^ self addInstruction: #ficomp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fidiv: aMemoryOperand "Divide " ^ self addInstruction: #fidiv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fidivr: aMemoryOperand "Reverse Divide " ^ self addInstruction: #fidivr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fild: aMemoryOperand "Load Integer Pseudo Code ----------- TOP = TOP - 1; ST(0) = ConvertToDoubleExtendedPrecisionFP(SRC); Description ----------- Converts the signed-integer source operand into double extended-precision floating-point format and pushes the value onto the FPU register stack. The source operand can be a word, doubleword, or quadword integer. It is loaded without rounding errors. The sign of the source operand is preserved. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fild operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fimul: aMemoryOperand "Multiply " ^ self addInstruction: #fimul operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fist: aMemoryOperand "Store Integer " ^ self addInstruction: #fist operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fistp: aMemoryOperand "Store Integer and Pop " ^ self addInstruction: #fistp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fisttp: aMemoryOperand "Store Integer with Truncation and Pop Pseudo Code ----------- DEST = ST; pop ST; Description ----------- FISTTP converts the value in ST into a signed integer using truncation (chop) as rounding mode, transfers the result to the destination, and pop ST. FISTTP accepts word, short integer, and long integer destinations. The following table shows the results obtained when storing various classes of numbers in integer format. ST(0) DEST --------------------------------------- ------ -∞ or Value Too Large for DEST Format \* F ≤ - 1 - I - 1 \< F \< + 1 0 F ≥ + 1 + I +∞ or Value Too Large for DEST Format \* NaN \* : FISTTP Results - Notes - F means finite floating-point value. - I means integer. - Indicates floating-point invalid-operation (\#IA) exception. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fisttp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fisub: aMemoryOperand "Subtract " ^ self addInstruction: #fisub operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fisubr: aMemoryOperand "Reverse Subtract " ^ self addInstruction: #fisubr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fld: aMemoryOrX87Register "Load Floating Point Value Description ----------- Pushes the source operand onto the FPU register stack. The source operand can be in single-precision, double-precision, or double extended-precision floating-point format. If the source operand is in single-precision or double-precision floating-point format, it is automatically converted to the double extended-precision floating-point format before being pushed on the stack. The FLD instruction can also push the value in a selected FPU register [ST(i)] onto the stack. Here, pushing register ST(0) duplicates the stack top. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fld operands: { aMemoryOrX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fldcw: aMemoryOperand "Load x87 FPU Control Word " ^ self addInstruction: #fldcw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fldenv: aMemoryOperand "Load x87 FPU Environment Pseudo Code ----------- FPUControlWord = SRC[FPUControlWord]; FPUStatusWord = SRC[FPUStatusWord]; FPUTagWord = SRC[FPUTagWord]; FPUDataPointer = SRC[FPUDataPointer]; FPUInstructionPointer = SRC[FPUInstructionPointer]; FPULastInstructionOpcode = SRC[FPULastInstructionOpcode]; Description ----------- Loads the complete x87 FPU operating environment from memory into the FPU registers. The source operand specifies the first byte of the operating-environment data in memory. This data is typically written to the specified memory location by a FSTENV or FNSTENV instruction. The FPU operating environment consists of the FPU control word, status word, tag word, instruction pointer, data pointer, and last opcode. Figures 8-9 through 8-12 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, show the layout in memory of the loaded environment, depending on the operating mode of the processor (protected or real) and the current operand-size attribute (16-bit or 32-bit). In virtual-8086 mode, the real mode layouts are used. The FLDENV instruction should be executed in the same operating mode as the corresponding FSTENV/FNSTENV instruction. If one or more unmasked exception flags are set in the new FPU status word, a floating-point exception will be generated upon execution of the next floating-point instruction (except for the no-wait floating-point instructions, see the section titled 'Software Exception Handling' in Chapter 8 of the Intel®64 and IA-32 ArchitecturesSoftware Developer's Manual, Volume 1). To avoid generating exceptions when loading a new environment, clear all the exception flags in the FPU status word that is being loaded. If a page or limit fault occurs during the execution of this instruction, the state of the x87 FPU registers as seen by the fault handler may be different than the state being loaded from memory. In such situations, the fault handler should ignore the status of the x87 FPU registers, handle the fault, and return. The FLDENV instruction will then complete the loading of the x87 FPU registers with no resulting context inconsistency. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fldenv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fmul: aMemoryOperand "Multiply " ^ self addInstruction: #fmul operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fmul: aX87Register1 with: aX87Register2 " see #fmul" ^ self addInstruction: #fmul operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fmulp: aX87Register "Multiply and Pop " ^ self addInstruction: #fmulp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fnsave: aMemoryOperand "Store x87 FPU State " ^ self addInstruction: #fnsave operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fnstcw: aMemoryOperand "Store x87 FPU Control Word " ^ self addInstruction: #fnstcw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fnstenv: aMemoryOperand "Store x87 FPU Environment " ^ self addInstruction: #fnstenv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! frstor: aMemoryOperand "Restore x87 FPU State Description ----------- Loads the FPU state (operating environment and register stack) from the memory area specified with the source operand. This state data is typically written to the specified memory location by a previous FSAVE/FNSAVE instruction. The FPU operating environment consists of the FPU control word, status word, tag word, instruction pointer, data pointer, and last opcode. Figures 8-9 through 8-12 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, show the layout in memory of the stored environment, depending on the operating mode of the processor (protected or real) and the current operand-size attribute (16-bit or 32-bit). In virtual-8086 mode, the real mode layouts are used. The contents of the FPU register stack are stored in the 80 bytes immediately following the operating environment image. The FRSTOR instruction should be executed in the same operating mode as the corresponding FSAVE/FNSAVE instruction. If one or more unmasked exception bits are set in the new FPU status word, a floating-point exception will be generated. To avoid raising exceptions when loading a new operating environment, clear all the exception flags in the FPU status word that is being loaded. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #frstor operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsave: aMemoryOperand "Store x87 FPU State " ^ self addInstruction: #fsave operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fst: aMemoryOrX87Register "Store Floating Point Value " ^ self addInstruction: #fst operands: { aMemoryOrX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fstcw: aMemoryOperand "Store x87 FPU Control Word " ^ self addInstruction: #fstcw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fstenv: aMemoryOperand "Store x87 FPU Environment " ^ self addInstruction: #fstenv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fstp: aMemoryOrX87Register "Store Floating Point Value and Pop " ^ self addInstruction: #fstp operands: { aMemoryOrX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsub: aMemoryOperand "Subtract " ^ self addInstruction: #fsub operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsub: aX87Register1 with: aX87Register2 " see #fsub" ^ self addInstruction: #fsub operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubp: aX87Register "Subtract and Pop " ^ self addInstruction: #fsubp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubr: aMemoryOperand "Reverse Subtract " ^ self addInstruction: #fsubr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubr: aX87Register1 with: aX87Register2 " see #fsubr" ^ self addInstruction: #fsubr operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubrp: aX87Register "Reverse Subtract and Pop " ^ self addInstruction: #fsubrp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucom: aX87Register "Unordered Compare Floating Point Values " ^ self addInstruction: #fucom operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucomi: aX87Register "Unordered Compare Floating Point Values and Set EFLAGS " ^ self addInstruction: #fucomi operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucomip: aX87Register "Unordered Compare Floating Point Values and Set EFLAGS and Pop " ^ self addInstruction: #fucomip operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucomp: aX87Register "Unordered Compare Floating Point Values and Pop " ^ self addInstruction: #fucomp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fxch: aX87Register "Exchange Register Contents Description ----------- Exchanges the contents of registers ST(0) and ST(i). If no source operand is specified, the contents of ST(0) and ST(1) are exchanged. This instruction provides a simple means of moving values in the FPU register stack to the top of the stack [ST(0)], so that they can be operated on by those floating-point instructions that can only operate on values in ST(0). For example, the following instruction sequence takes the square root of the third register from the top of the register stack: FXCH ST(3); FSQRT; FXCH ST(3); This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fxch operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fxrstor: aMemoryOperand "Restore x87 FPU, MMX, XMM, and MXCSR State Pseudo Code ----------- (x87 FPU, MMX, XMM7-XMM0, MXCSR) = Load(SRC); Description ----------- Reloads the x87 FPU, MMX technology, XMM, and MXCSR registers from the 512-byte memory image specified in the source operand. This data should have been written to memory previously using the FXSAVE instruction, and in the same format as required by the operating modes. The first byte of the data should be located on a 16-byte boundary. There are three distinct layouts of the FXSAVE state map: one for legacy and compatibility mode, a second format for 64-bit mode FXSAVE/FXRSTOR with REX.W=0, and the third format is for 64-bit mode with FXSAVE64/FXRSTOR64. Table 3-48 ('Non-64-bit-Mode Layout of FXSAVE and FXRSTOR Memory Region') shows the layout of the legacy/compatibility mode state information inmemory and describes the fields in the memory image for the FXRSTOR and FXSAVE instructions.Table 3-51 shows the layout of the 64-bit mode state information whenREX.W is set (FXSAVE64/FXRSTOR64). Table 3-52 shows the layout of the 64-bitmode state information when REX.W is clear (FXSAVE/FXRSTOR). The state image referenced with an FXRSTOR instruction must have been saved using an FXSAVE instruction or be in the same format as required by Table 3-48, Table 3-51, or Table 3-52. Referencing a state image saved with an FSAVE, FNSAVEinstruction or incompatible field layout will result in an incorrect state restoration. The FXRSTOR instruction does not flush pending x87 FPU exceptions. To check and raise exceptions when loading x87 FPU state information with the FXRSTOR instruction, use an FWAIT instruction after the FXRSTOR instruction. If the OSFXSR bit in control register CR4 is not set, the FXRSTOR instruction may not restore the states of the XMM and MXCSR registers. This behavior is implementation dependent. If the MXCSR state contains an unmasked exception with a corresponding status flag also set, loading the register with the FXRSTOR instruction will not result in a SIMD floating-point error condition being generated. Only the next occurrence of this unmasked exception will result in the exception being generated. Bits 16 through 32 of the MXCSR register are defined as reserved and should be set to 0. Attempting to write a 1 in any of these bits from the saved state image will result in a general protection exception (\#GP) being generated. Bytes 464:511 of an FXSAVE image are available for software use. FXRSTOR ignores the content of bytes 464:511 in an FXSAVE state image. " ^ self addInstruction: #fxrstor operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fxsave: aMemoryOperand "Save x87 FPU, MMX, XMM, and MXCSR State Description ----------- Saves the current state of the x87 FPU, MMX technology, XMM, and MXCSR registers to a 512-byte memory location specified in the destination operand. The content layout of the 512 byte region depends on whether the processor is operating in non-64-bit operating modes or 64-bit sub-mode of IA-32e mode. Bytes 464:511 are available to software use. The processor does not write to bytes 464:511 of an FXSAVE area. The operation of FXSAVE in non-64-bit modes is described first. ### Non-64-Bit Mode Operation The following table shows the layout of the state information in memory when the processoris operating in legacy modes. ------------- --------- -------- ----- -------- ----- ----- ----- --- --- --- --- --- --- --- --- -- 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 Rsrvd CS FPU IP FOP Rs rvd FTW FSW FCW 0 MXCSR\_MASK MXCSR Rsrvd DS FPU DP 16 Reserved ST0/MM0 32 Reserved ST1/MM1 48 Reserved ST2/MM2 64 Reserved ST3/MM3 80 Reserved ST4/MM4 96 Reserved ST5/MM5 112 Reserved ST6/MM6 128 Reserved ST7/MM7 144 XMM0 160 XMM1 176 XMM2 192 XMM3 208 XMM4 224 XMM5 240 XMM6 256 XMM7 272 Reserved 288 Reserved 304 Reserved 320 Reserved 336 Reserved 352 Reserved 368 Reserved 384 Reserved 400 Reserved 416 Reserved 432 Reserved 448 Available 464 Available 480 Available 496 ------------- --------- -------- ----- -------- ----- ----- ----- --- --- --- --- --- --- --- --- -- : Non-64-bit-Mode Layout of FXSAVE and FXRSTOR Memory Region The destination operand contains the first byte of the memory image, and it must be aligned on a 16-byte boundary. A misaligned destination operand will result in a general-protection (\#GP) exception being generated (or in some cases, an alignment check exception [\#AC]). The FXSAVE instruction is used when an operating system needs to perform a context switch or when an exception handler needs to save and examine the current state of the x87 FPU, MMX technology, and/or XMM and MXCSR registers. The fields used in the previous table are defined in the following table. Field Definitions Field Definition FCW x87 FPU Control Word (16 bits). See Figure 8-6 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the x87 FPU control word. FSW x87 FPU Status Word (16 bits). See Figure 8-4 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the x87 FPU status word. Abridged FTW x87 FPU Tag Word (8 bits). The tag information saved here is abridged, as described in the following paragraphs. FOP x87 FPU Opcode (16 bits). The lower 11 bits of this field contain the opcode, upper 5 bits are reserved. See Figure 8-8 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the x87 FPU opcode field. FPU IP x87 FPU Instruction Pointer Offset (32 bits). The contents of this field differ depending on the current addressing mode (32-bit or 16-bit) of the processor when the FXSAVE instruction was executed: - 32-bit mode — 32-bit IP offset. - 16-bit mode — low 16 bits are IP offset; high 16 bits are reserved. See 'x87 FPU Instruction and Operand (Data) Pointers' in Chapter 8 of the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for a description of the x87 FPU instruction pointer. CS x87 FPU Instruction Pointer Selector (16 bits). FPU DP x87 FPU Instruction Operand (Data) Pointer Offset (32 bits). The contents of this field differ depending on the current addressing mode (32-bit or 16bit) of the processor when the FXSAVE instruction was executed: - 32-bit mode — 32-bit DP offset. - 16-bit mode — low 16 bits are DP offset; high 16 bits are reserved. See 'x87 FPU Instruction and Operand (Data) Pointers' in Chapter 8 of the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for a description of the x87 FPU operand pointer. DS x87 FPU Instruction Operand (Data) Pointer Selector (16 bits). MXCSR MXCSR Register State (32 bits). See Figure 10-3 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the MXCSR register. If the OSFXSR bit in control register CR4 is not set, the FXSAVE instruction may not save this register. This behavior is implementation dependent. MXCSR\_ MXCSR\_MASK (32 bits). This mask can be used to adjust values written to MASK the MXCSR register, ensuring that reserved bits are set to 0. Set the mask bits and flags in MXCSR to the mode of operation desired for SSE and SSE2 SIMD floating-point instructions. See 'Guidelines for Writing to the MXCSR Register' in Chapter 11 of the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for instructions for how to determine and use the MXCSR\_MASK value. ST0/MM0 through x87 FPU or MMX technology registers. These 80-bit fields contain the x87 ST7/MM7 FPU data registers or the MMX technology registers, depending on the state of the processor prior to the execution of the FXSAVE instruction. If the processor had been executing x87 FPU instruction prior to the FXSAVE instruction, the x87 FPU data registers are saved; if it had been executing MMX instructions (or SSE or SSE2 instructions that operated on the MMX technology registers), the MMX technology registers are saved. When the MMX technology registers are saved, the high 16 bits of the field are reserved. XMM0 through XMM7 XMM registers (128 bits per field). If the OSFXSR bit in control register CR4 is not set, the FXSAVE instruction may not save these registers. This behavior is implementation dependent. The FXSAVE instruction saves an abridged version of the x87 FPU tag word in the FTW field (unlike the FSAVE instruction, which saves the complete tag word). The tag information is saved in physical register order (R0 through R7), rather than in top-ofstack (TOS) order. With the FXSAVE instruction, however, only a single bit (1 for valid or 0 for empty) is saved for each tag. For example, assume that the tag word is currently set as follows: ---- ---- ---- ---- ---- ---- ---- ---- R7 R6 R5 R4 R3 R2 R1 R0 11 xx xx xx 11 11 11 11 ---- ---- ---- ---- ---- ---- ---- ---- Here, 11B indicates empty stack elements and 'xx' indicates valid (00B), zero (01B), or special (10B). For this example, the FXSAVE instruction saves only the following 8 bits of information: ---- ---- ---- ---- ---- ---- ---- ---- R7 R6 R5 R4 R3 R2 R1 R0 0 1 1 1 0 0 0 0 ---- ---- ---- ---- ---- ---- ---- ---- Here, a 1 is saved for any valid, zero, or special tag, and a 0 is saved for any empty tag. The operation of the FXSAVE instruction differs from that of the FSAVE instruction, the as follows: - FXSAVE instruction does not check for pending unmasked floating-point exceptions. (The FXSAVE operation in this regard is similar to the operation of the FNSAVE instruction). - After the FXSAVE instruction has saved the state of the x87 FPU, MMX technology, XMM, and MXCSR registers, the processor retains the contents of the registers. Because of this behavior, the FXSAVE instruction cannot be used by an application program to pass a 'clean' x87 FPU state to a procedure, since it retains the current state. To clean the x87 FPU state, an application must explicitly execute an FINIT instruction after an FXSAVE instruction to reinitialize the x87 FPU state. - The format of the memory image saved with the FXSAVE instruction is the same regardless of the current addressing mode (32-bit or 16-bit) and operating mode (protected, real address, or system management). This behavior differs from the FSAVE instructions, where the memory image format is different depending on the addressing mode and operating mode. Because of the different image formats, the memory image saved with the FXSAVE instruction cannot be restored correctly with the FRSTOR instruction, and likewise the state saved with the FSAVE instruction cannot be restored correctly with the FXRSTOR instruction. The FSAVE format for FTW can be recreated from the FTW valid bits and the stored 80-bit FP data (assuming the stored data was not the contents of MMX technology registers) using Table 3-50. Exponent all 1's Exponent all 0's Fraction all 0's J and M bits FTW valid bit x87 FTW ----------------------------------- ------------------ ------------------ -------------- --------------- --------- ---- 0 0 0 0x 1 Special 10 0 0 0 1x 1 Valid 00 0 0 1 00 1 Special 10 0 0 1 10 1 Valid 00 0 1 0 0x 1 Special 10 0 1 0 1x 1 Special 10 0 1 1 00 1 Zero 01 0 1 1 10 1 Special 10 1 0 0 1x 1 Special 10 1 0 0 1x 1 Special 10 1 0 1 00 1 Special 10 1 0 1 10 1 Special 10 For all legal combinations above. 0 Empty 11 : Recreating FSAVE Format The J-bit is defined to be the 1-bit binary integer to the left of the decimal place in the significand. The M-bit is defined to be the most significant bit of the fractional portion of the significand (i.e., the bit immediately to the right of the decimal place). When the M-bit is the most significant bit of the fractional portion of the significand, it must be 0 if the fraction is all 0's. ### IA-32e Mode Operation In compatibility sub-mode of IA-32e mode, legacy SSE registers, XMM0 through XMM7, are saved according to the legacy FXSAVE map. In 64-bit mode, all of the SSE registers, XMM0 through XMM15, are saved. Additionally, there are two different layouts of the FXSAVE map in 64-bit mode, corresponding to FXSAVE64 (which requires REX.W=1) and FXSAVE (REX.W=0). In the FXSAVE64 map (following table), theFPU IP and FPU DP pointers are 64-bit wide. In the FXSAVE map for 64-bit mode (see the following tables), the FPU IP and FPU DP pointers are 32-bits. ------------- --------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- --- --- -- 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 FPU IP FOP Reserved FTW FSW FCW 0 MXCSR\_MASK MXCSR FPU DP 16 Reserved ST0/MM0 32 Reserved ST1/MM1 48 Reserved ST2/MM2 64 Reserved ST3/MM3 80 Reserved ST4/MM4 96 Reserved ST5/MM5 112 Reserved ST6/MM6 128 Reserved ST7/MM7 144 XMM0 160 XMM1 176 XMM2 192 XMM3 208 XMM4 224 XMM5 240 XMM6 256 XMM7 272 XMM8 288 XMM9 304 XMM10 320 XMM11 336 XMM12 352 XMM13 368 XMM14 384 XMM15 400 Reserved 416 Reserved 432 Reserved 448 Available 464 Available 480 Available 496 ------------- --------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- --- --- -- : Layout of the 64-bit-mode FXSAVE64 Map (requires REX.W = 1) ------------- --------- ---------- -------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- -- 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 Reserved CS FPU IP FOP Reserved FTW FSW FCW 0 MXCSR\_MASK MXCSR Reserved FPU DP 16 Reserved ST0/MM0 32 Reserved ST1/MM1 48 Reserved ST2/MM2 64 Reserved ST3/MM3 80 ------------- --------- ---------- -------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- -- : Layout of the 64-bit-mode FXSAVE Map (REX.W = 0) Reserved ST4/MM4 96 Reserved ST5/MM5 112 Reserved ST6/MM6 128 Reserved ST7/MM7 144 XMM0 160 XMM1 176 XMM2 192 XMM3 208 XMM4 224 XMM5 240 XMM6 256 XMM7 272 XMM8 288 XMM9 304 XMM10 320 XMM11 336 XMM12 352 XMM13 368 XMM14 384 XMM15 400 Reserved 416 Reserved 432 Reserved 448 Available 464 Available 480 Available 496 " ^ self addInstruction: #fxsave operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! idiv: aDestination "Signed Divide Description ----------- Divides the (signed) value in the AX, DX:AX, or EDX:EAX (dividend) by the source operand (divisor) and stores the result in the AX (AH:AL), DX:AX, or EDX:EAX registers. The source operand can be a general-purpose register or a memory location. The action of this instruction depends on the operand size (dividend/divisor). Non-integral results are truncated (chopped) towards 0. The remainder is always less than the divisor in magnitude. Overflow is indicated with the \#DE (divide error) exception rather than with the CF flag. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. In 64-bit mode when REX.W is applied, the instruction divides the signed value in RDX:RAX by the source operand. RAX contains a 64-bit quotient; RDX contains a 64-bit remainder. See the summary chart at the beginning of this section for encoding data and limits. See the following. Operand Size Dividend Divisor Quotient Remainder Quotient Range ------------------------- ---------- --------- ---------- ----------- --------------------- Word/byte AX r/m8 AL AH -128 to +127 Doubleword/word DX:AX r/m16 AX DX -32,768 to +32,767 Quadword/doubleword EDX:EAX r/m32 EAX EDX -2^31^ to 2^32^ - 1 Doublequadword/quadword RDX:RAX r/m64 RAX RDX -2^63^ to 2^64^ - 1 : IDIV Results " ^ self addInstruction: #idiv operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! imul: aRegisterOrMemory "Signed Multiply Description ----------- Performs a signed multiplication of two operands. This instruction has three forms, depending on the number of operands. - One-operand form — This form is identical to that used by the MUL instruction. Here, the source operand (in a general-purpose register or memory location) is multiplied by the value in the AL, AX, EAX, or RAX register (depending on the operand size) and the product is stored in the AX, DX:AX, EDX:EAX, or RDX:RAX registers, respectively. - Two-operand form — With this form the destination operand (the first operand) is multiplied by the source operand (second operand). The destination operand is a general-purpose register and the source operand is an immediate value, a general-purpose register, or a memory location. The product is then stored in the destination operand location. - Three-operand form — This form requires a destination operand (the first operand) and two source operands (the second and the third operands). Here, the first source operand (which can be a general-purpose register or a memory location) is multiplied by the second source operand (an immediate value). The product is then stored in the destination operand (a general-purpose register). When an immediate value is used as an operand, it is sign-extended to the length of the destination operand format. The CF and OF flags are set when significant bit (including the sign bit) are carried into the upper half of the result. The CF and OF flags are cleared when the result (including the sign bit) fits exactly in the lower half of the result. The three forms of the IMUL instruction are similar in that the length of the product is calculated to twice the length of the operands. With the one-operand form, the product is stored exactly in the destination. With the two- and three- operand forms, however, the result is truncated to the length of the destination before it is stored in the destination register. Because of this truncation, the CF or OF flag should be tested to ensure that no significant bits are lost. The two- and three-operand forms may also be used with unsigned operands because the lower half of the product is the same regardless if the operands are signed or unsigned. The CF and OF flags, however, cannot be used to determine if the upper half of the result is non-zero. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. Use of REX.W modifies the three forms of the instruction as follows. - One-operand form —The source operand (in a 64-bit general-purpose register or memory location) is multiplied by the value in the RAX register and the product is stored in the RDX:RAX registers. - Two-operand form — The source operand is promoted to 64 bits if it is a register or a memory location. If the source operand is an immediate, it is sign extended to 64 bits. The destination operand is promoted to 64 bits. - Three-operand form — The first source operand (either a register or a memory location) and destination operand are promoted to 64 bits. " ^ self addInstruction: #imul operands: { aRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! imul: aRegister with: aRegisterOrMemoryOrImmediate " see #imul" ^ self addInstruction: #imul operands: { aRegister . aRegisterOrMemoryOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! imul: aRegister with: aRegisterOrMemory with: anImmediate " see #imul" ^ self addInstruction: #imul operands: { aRegister . aRegisterOrMemory . anImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! inc: aRegisterOrMemory "Increment by 1 Pseudo Code ----------- DEST = DEST + 1; AFlags Affected The CF flag is not affected. The OF, SF, ZF, AF, and PF flags are set according to the result. Description ----------- Adds 1 to the destination operand, while preserving the state of the CF flag. The destination operand can be a register or a memory location. This instruction allows a loop counter to be updated without disturbing the CF flag. (Use a ADD instruction with an immediate operand of 1 to perform an increment operation that does updates the CF flag.) This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, INC r16 and INC r32 are not encodable (because opcodes 40H through 47H are REX prefixes). Otherwise, the instruction's 64-bit mode default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. " ^ self addInstruction: #inc operands: { aRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ja: targetLabel " " ^ self addInstruction: #ja operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jae: targetLabel " " ^ self addInstruction: #jae operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jb: targetLabel "Jump short if below/not above or equal/carry (CF=1) " ^ self addInstruction: #jb operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jbe: targetLabel "Jump short if below or equal/not above (CF=1 AND ZF=1) " ^ self addInstruction: #jbe operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jc: targetLabel " " ^ self addInstruction: #jc operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! je: targetLabel " " ^ self addInstruction: #je operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jg: targetLabel " " ^ self addInstruction: #jg operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jge: targetLabel " " ^ self addInstruction: #jge operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jl: targetLabel "Jump short if less/not greater (SF!!=OF) " ^ self addInstruction: #jl operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jle: targetLabel "Jump short if less or equal/not greater ((ZF=1) OR (SF!!=OF)) " ^ self addInstruction: #jle operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jmp: aLabelOrRegisterOrMemory "Jump Description ----------- Transfers program control to a different point in the instruction stream without recording return information. The destination (target) operand specifies the address of the instruction being jumped to. This operand can be an immediate value, a general-purpose register, or a memory location. This instruction can be used to execute four different types of jumps: - Near jump—A jump to an instruction within the current code segment (the segment currently pointed to by the CS register), sometimes referred to as an intrasegment jump. - Short jump—A near jump where the jump range is limited to -128 to +127 from the current EIP value. - Far jump—A jump to an instruction located in a different segment than the current code segment but at the same privilege level, sometimes referred to as an intersegment jump. - Task switch—A jump to an instruction located in a different task. A task switch can only be executed in protected mode (see Chapter 7, in theIntel® 64 and IA-32 Architectures Software Developer's Manual, Volume 3A, for information on performing task switches with the JMP instruction). Near and Short Jumps. When executing a near jump, the processor jumps to the address (within the current code segment) that is specified with the target operand. The target operand specifies either an absolute offset (that is an offset from the base of the code segment) or a relative offset (a signed displacement relative to the current value of the instruction pointer in the EIP register). A near jump to a relative offset of 8-bits (rel8) is referred to as a short jump. The CS register is not changed on near and short jumps. An absolute offset is specified indirectly in a general-purpose register or a memory location (r/m16 or r/m32). The operand-size attribute determines the size of the target operand (16 or 32 bits). Absolute offsets are loaded directly into the EIP register. If the operand-size attribute is 16, the upper two bytes of the EIP register are cleared, resulting in a maximum instruction pointer size of 16 bits. A relative offset (rel8, rel16, or rel32) is generally specified as a label in assembly code, but at the machine code level, it is encoded as a signed 8-, 16-, or 32-bit immediate value. This value is added to the value in the EIP register. (Here, the EIP register contains the address of the instruction following the JMP instruction). When using relative offsets, the opcode (for short vs. near jumps) and the operand-size attribute (for near relative jumps) determines the size of the target operand (8, 16, or 32 bits). Far Jumps in Real-Address or Virtual-8086 Mode. When executing a far jump in real-address or virtual-8086 mode, the processor jumps to the code segment and offset specified with the target operand. Here the target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). With the pointer method, the segment and address of the called procedure is encoded in the instruction, using a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address immediate. With the indirect method, the target operand specifies a memory location that contains a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address. The far address is loaded directly into the CS and EIP registers. If the operand-size attribute is 16, the upper two bytes of the EIP register are cleared. Far Jumps in Protected Mode. When the processor is operating in protected mode, the JMP instruction can be used to perform the following three types of far jumps: - A far jump to a conforming or non-conforming code segment. - A far jump through a call gate. - A task switch. (The JMP instruction cannot be used to perform inter-privilege-level far jumps.) In protected mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate, task gate, or TSS) and access rights determine the type of jump to be performed. If the selected descriptor is for a code segment, a far jump to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far jump to the same privilege level in protected mode is very similar to one carried out in real-address or virtual-8086 mode. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The operand-size attribute determines the size of the offset (16 or 32 bits) in the far address. The new code segment selector and its descriptor are loaded into CS register, and the offset from the instruction is loaded into the EIP register. Note that a call gate (described in the next paragraph) can also be used to perform far call to a code segment at the same privilege level. Using this mechanism provides an extra level of indirection and is the preferred method of making jumps between 16-bit and 32-bit code segments. When executing a far jump through a call gate, the segment selector specified by the target operand identifies the call gate. (The offset part of the target operand is ignored.) The processor then jumps to the code segment specified in the call gate descriptor and begins executing the instruction at the offset specified in the call gate. No stack switch occurs. Here again, the target operand can specify the far address of the call gate either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). Executing a task switch with the JMP instruction is somewhat similar to executing a jump through a call gate. Here the target operand specifies the segment selector of the task gate for the task being switched to (and the offset part of the target operand is ignored). The task gate in turn points to the TSS for the task, which contains the segment selectors for the task's code and stack segments. The TSS also contains the EIP value for the next instruction that was to be executed before the task was suspended. This instruction pointer value is loaded into the EIP register so that the task begins executing again at this next instruction. The JMP instruction can also specify the segment selector of the TSS directly, which eliminates the indirection of the task gate. See Chapter 7 inIntel® 64 and IA-32Architectures Software Developer's Manual, Volume 3A, for detailed information on the mechanics of a task switch. Note that when you execute at task switch with a JMP instruction, the nested task flag (NT) is not set in the EFLAGS register and the new TSS's previous task link field is not loaded with the old task's TSS selector. A return to the previous task can thus not be carried out by executing the IRET instruction. Switching tasks with the JMP instruction differs in this regard from the CALL instruction which does set the NT flag and save the previous task link information, allowing a return to the calling task with an IRET instruction. In 64-Bit Mode — The instruction's operation size is fixed at 64 bits. If a selector points to a gate, then RIP equals the 64-bit displacement taken from gate; else RIP equals the zero-extended offset from the far pointer referenced in the instruction. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #jmp operands: { aLabelOrRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jna: targetLabel " " ^ self addInstruction: #jna operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnae: targetLabel " " ^ self addInstruction: #jnae operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnb: targetLabel "Jump short if not below/above or equal/not carry (CF=0) " ^ self addInstruction: #jnb operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnbe: targetLabel "Jump short if not below or equal/above (CF=0 AND ZF=0) " ^ self addInstruction: #jnbe operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnc: targetLabel " " ^ self addInstruction: #jnc operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jne: targetLabel " " ^ self addInstruction: #jne operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jng: targetLabel " " ^ self addInstruction: #jng operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnge: targetLabel " " ^ self addInstruction: #jnge operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnl: targetLabel "Jump short if not less/greater or equal (SF=OF) " ^ self addInstruction: #jnl operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnle: targetLabel "Jump short if not less nor equal/greater ((ZF=0) AND (SF=OF)) " ^ self addInstruction: #jnle operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jno: targetLabel "Jump short if not overflow (OF=0) " ^ self addInstruction: #jno operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnp: targetLabel "Jump short if not parity/parity odd " ^ self addInstruction: #jnp operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jns: targetLabel "Jump short if not sign (SF=0) " ^ self addInstruction: #jns operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnz: targetLabel "Jump short if not zero/not equal (ZF=1) " ^ self addInstruction: #jnz operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jo: targetLabel "Jump short if overflow (OF=1) " ^ self addInstruction: #jo operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jp: targetLabel "Jump short if parity/parity even (PF=1) " ^ self addInstruction: #jp operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jpe: targetLabel " " ^ self addInstruction: #jpe operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jpo: targetLabel " " ^ self addInstruction: #jpo operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! js: targetLabel "Jump short if sign (SF=1) " ^ self addInstruction: #js operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jz: targetLabel "Jump short if zero/equal (ZF=0) " ^ self addInstruction: #jz operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ldmxcsr: aMemoryOperand "Load MXCSR Register Pseudo Code ----------- MXCSR = m32; C/C++ Compiler Intrinsic Equivalent _mm_setcsr(unsigned int i) Description ----------- Loads the source operand into the MXCSR control/status register. The source operand is a 32-bit memory location. See 'MXCSR Control and Status Register' in Chapter 10, of theIntel®64 and IA-32 Architectures Software Developer's Manual,Volume 1, for a description of the MXCSR register and its contents. The LDMXCSR instruction is typically used in conjunction with the STMXCSR instruction, which stores the contents of the MXCSR register in memory. The default MXCSR value at reset is 1F80H. If a LDMXCSR instruction clears a SIMD floating-point exception mask bit and sets the corresponding exception flag bit, a SIMD floating-point exception will not be immediately generated. The exception will be generated only upon the execution of the next SSE or SSE2 instruction that causes that particular SIMD floating-point exception to be reported. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #ldmxcsr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! lea: aDestinationRegister with: aSourceMemory "Load Effective Address " ^ self addInstruction: #lea operands: { aDestinationRegister . aSourceMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! mov: aDestinationRegisterOrMemory with: aSource "Move Description ----------- Copies the second operand (source operand) to the first operand (destination operand). The source operand can be an immediate value, general-purpose register, segment register, or memory location; the destination register can be a general-purpose register, segment register, or memory location. Both operands must be the same size, which can be a byte, a word, a doubleword, or a quadword. The MOV instruction cannot be used to load the CS register. Attempting to do so results in an invalid opcode exception (\#UD). To load the CS register, use the far JMP, CALL, or RET instruction. If the destination operand is a segment register (DS, ES, FS, GS, or SS), the source operand must be a valid segment selector. In protected mode, moving a segment selector into a segment register automatically causes the segment descriptor information associated with that segment selector to be loaded into the hidden (shadow) part of the segment register. While loading this information, the segment selector and segment descriptor information is validated (see the 'Operation' algorithm below). The segment descriptor data is obtained from the GDT or LDT entry for the specified segment selector. A NULL segment selector (values 0000-0003) can be loaded into the DS, ES, FS, and GS registers without causing a protection exception. However, any subsequent attempt to reference a segment whose corresponding segment register is loaded with a NULL value causes a general protection exception (\#GP) and no memory reference occurs. Loading the SS register with a MOV instruction inhibits all interrupts until after the execution of the next instruction. This operation allows a stack pointer to be loaded into the ESP register with the next instruction (MOV ESP, stack-pointer value) before an interrupt occurs1. Be aware that the LSS instruction offers a more efficient method of loading the SS and ESP registers. When operating in 32-bit mode and moving data between a segment register and a general-purpose register, the 32-bit IA-32 processors do not require the use of the 16-bit operand-size prefix (a byte with the value 66H) with this instruction, but most assemblers will insert it if the standard form of the instruction is used (for example, MOV DS, AX). The processor will execute this instruction correctly, but it will usually require an extra clock. With most assemblers, using the instruction form MOV DS, EAX will avoid this unneeded 66H prefix. When the processor executes the instruction with a 32-bit general-purpose register, it assumes that the 16 least-significant bits of the general-purpose register are the destination or source operand. If the register is a destination operand, the resulting value in the two high-order bytes of the register is implementation dependent. For the Pentium 4, Intel Xeon, and P6 family processors, the two high-order bytes are filled with zeros; for earlier 32-bit IA-32 processors, the two high order bytes are undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #mov operands: { aDestinationRegisterOrMemory . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movPtr: aRegisterOrImmedate1 with: aRegisterOrImmedate2 " " ^ self addInstruction: #movPtr operands: { aRegisterOrImmedate1 . aRegisterOrImmedate2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movapd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Aligned Packed Double-FP Values Pseudo Code ----------- DEST = SRC; (* #GP if SRC or DEST unaligned memory operand *) Description ----------- Moves a double quadword containing two packed double-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand must be aligned on a 16-byte boundary or a general-protection exception (\#GP) will be generated. To move double-precision floating-point values to and from unaligned memory locations, use the MOVUPD instruction. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movapd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movaps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Aligned Packed Single-FP Values Pseudo Code ----------- DEST = SRC; (* #GP if SRC or DEST unaligned memory operand *) Description ----------- Moves a double quadword containing four packed single-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand must be aligned on a 16-byte boundary or a general-protection exception (\#GP) is generated. To move packed single-precision floating-point values to or from unaligned memory locations, use the MOVUPS instruction. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movaps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movddup: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move One Double-FP and Duplicate Description ----------- The linear address corresponds to the address of the least-significant byte of the referenced memory data. When a memory address is indicated, the 8 bytes of data at memory location m64 are loaded. When the register-register form of this operation is used, the lower half of the 128-bit source register is duplicated and copied into the 128-bit destination register. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movddup operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movdq2q: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Quadword from XMM to MMX Technology Register Pseudo Code ----------- DEST = SRC[63:0]; Description ----------- Moves the low quadword from the source operand (second operand) to the destination operand (first operand). The source operand is an XMM register and the destination operand is an MMX technology register. This instruction causes a transition from x87 FPU to MMX technology operation (that is, the x87 FPU top-of-stack pointer is set to 0 and the x87 FPU tag word is set to all 0s [valid]). If this instruction is executed while an x87 FPU floating-point exception is pending, the exception is handled before the MOVDQ2Q instruction is executed. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movdq2q operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movdqa: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Aligned Double Quadword Pseudo Code ----------- DEST = SRC; (* #GP if SRC or DEST unaligned memory operand *) Description ----------- Moves a double quadword from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand must be aligned on a 16-byte boundary or a general-protection exception (\#GP) will be generated. To move a double quadword to or from unaligned memory locations, use the MOVDQU instruction. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movdqa operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movdqu: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Unaligned Double Quadword Pseudo Code ----------- DEST = SRC; 1. If alignment checking is enabled (CR0.AM = 1, RFLAGS.AC = 1, and CPL = 3), an alignment-check exception (#AC) may or may not be generated (depending on processor implementation) when the operand is not aligned on an 8-byte boundary. Description ----------- Moves a double quadword from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand may be unaligned on a 16-byte boundary without causing a general-protection exception (\#GP) to be generated.1 To move a double quadword to or from memory locations that are known to be aligned on 16-byte boundaries, use the MOVDQA instruction. While executing in 16-bit addressing mode, a linear address for a 128-bit data access that overlaps the end of a 16-bit segment is not allowed and is defined as reserved behavior. A specific processor implementation may or may not generate a general-protection exception (\#GP) in this situation, and the address that spans the end of the segment may or may not wrap around to the beginning of the segment. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movdqu operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movhlps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Packed Single-FP Values High to Low Pseudo Code ----------- DEST[63:0] = SRC[127:64]; (* DEST[127:64] unchanged *) Description ----------- Moves two packed single-precision floating-point values from the high quadword of the source operand (second operand) to the low quadword of the destination operand (first operand). The high quadword of the destination operand is left unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movhlps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movhpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move High Packed Double-FP Value Pseudo Code ----------- (* MOVHPD instruction for memory to XMM move *) DEST[127:64] = SRC; (* DEST[63:0] unchanged *) (* MOVHPD instruction for XMM to memory move *) DEST = SRC[127:64]; Description ----------- Moves a double-precision floating-point value from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows a double-precision floating-point value to be moved to and from the high quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the low quad-word of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movhpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movhps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move High Packed Single-FP Values Pseudo Code ----------- (* MOVHPS instruction for memory to XMM move *) DEST[127:64] = SRC; (* DEST[63:0] unchanged *) (* MOVHPS instruction for XMM to memory move *) DEST = SRC[127:64]; Description ----------- Moves two packed single-precision floating-point values from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows two single-precision floating-point values to be moved to and from the high quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the low quadword of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movhps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movlhps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Packed Single-FP Values Low to High Pseudo Code ----------- DEST[127:64] = SRC[63:0]; (* DEST[63:0] unchanged *) Description ----------- Moves two packed single-precision floating-point values from the low quadword of the source operand (second operand) to the high quadword of the destination operand (first operand). The low quadword of the destination operand is left unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movlhps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movlpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Low Packed Double-FP Value Pseudo Code ----------- (* MOVLPD instruction for memory to XMM move *) DEST[63:0] = SRC; (* DEST[127:64] unchanged *) (* MOVLPD instruction for XMM to memory move *) DEST = SRC[63:0]; Description ----------- Moves a double-precision floating-point value from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows a double-precision floating-point value to be moved to and from the low quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the high quad-word of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movlpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movlps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Low Packed Single-FP Values Pseudo Code ----------- (* MOVLPD instruction for memory to XMM move *) DEST[63:0] = SRC; (* DEST[127:64] unchanged *) (* MOVLPD instruction for XMM to memory move *) DEST = SRC[63:0]; Description ----------- Moves two packed single-precision floating-point values from the source operand (second operand) and the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows two single-precision floating-point values to be moved to and from the low quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the high quadword of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movlps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movmskpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Extract Packed Double-FP Sign Mask Pseudo Code ----------- DEST[0] = SRC[63]; DEST[1] = SRC[127]; IF DEST = r32 DEST[31:2] = ZeroExtend; ELSE DEST[63:2] = ZeroExtend; FI; Description ----------- Extracts the sign bits from the packed double-precision floating-point values in the source operand (second operand), formats them into a 2-bit mask, and stores the mask in the destination operand (first operand). The source operand is an XMM register, and the destination operand is a general-purpose register. The mask is stored in the 2 low-order bits of the destination operand. Zero-extend the upper bits of the destination. In 64-bit mode, the instruction can access additional registers (XMM8-XMM15, R8-R15) when used with a REX.R prefix. The default operand size is 64-bit in 64-bit mode. " ^ self addInstruction: #movmskpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movmskps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Extract Packed Single-FP Sign Mask Description ----------- Extracts the sign bits from the packed single-precision floating-point values in the source operand (second operand), formats them into a 4-bit mask, and stores the mask in the destination operand (first operand). The source operand is an XMM register, and the destination operand is a general-purpose register. The mask is stored in the 4 low-order bits of the destination operand. Zero-extend the upper bits of the destination operand. In 64-bit mode, the instruction can access additional registers (XMM8-XMM15, R8-R15) when used with a REX.R prefix. The default operand size is 64-bit in 64-bit mode. " ^ self addInstruction: #movmskps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntdq: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Double Quadword Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the double quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to prevent caching of the data during the write to memory. The source operand is an XMM register, which is assumed to contain integer data (packed bytes, words, doublewords, or quadwords). The destination operand is a 128-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTDQ instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movntdq operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntdqa: aRegisterOrMemory1 with: aRegisterOrMemory2 "Load Double Quadword Non-Temporal Aligned Hint Pseudo Code ----------- DST = SRC; Description ----------- MOVNTDQA loads a double quadword from the source operand (second operand) to the destination operand (first operand) using a non-temporal hint. A processor implementation may make use of the non-temporal hint associated with this instruction if the memory source is WC (write combining) memory type. An implementation may also make use of the non-temporal hint associated with this instruction if the memory source is WB (write back) memory type. A processor's implementation of the non-temporal hint does not override the effective memory type semantics, but the implementation of the hint is processor dependent. For example, a processor implementation may choose to ignore the hint and process the instruction as a normal MOVDQA for any memory type. Another implementation of the hint for WC memory type may optimize data transfer throughput of WC reads. A third implementation may optimize cache reads generated by MOVNTDQA on WB memory type to reduce cache evictions. WC Streaming Load Hint For WC memory type in particular, the processor never appears to read the data into the cache hierarchy. Instead, the non-temporal hint may be implemented by loading a temporary internal buffer with the equivalent of an aligned cache line without filling this data to the cache. Any memory-type aliased lines in the cache will be snooped and flushed. Subsequent MOVNTDQA reads to unread portions of the WC cache line will receive data from the temporary internal buffer if data is available. The temporary internal buffer may be flushed by the processor at any time for any reason, for example: - A load operation other than a MOVNTDQA which references memory already resident in a temporary internal buffer. - A non-WC reference to memory already resident in a temporary internal buffer. - Interleaving of reads and writes to memory currently residing in a single temporary internal buffer. - Repeated MOVNTDQA loads of a particular 16-byte item in a streaming line. - Certain micro-architectural conditions including resource shortages, detection of a mis-speculation condition, and various fault conditions The memory type of the region being read can override the non-temporal hint, if the memory address specified for the non-temporal read is not a WC memory region. Information on non-temporal reads and writes can be found in Chapter 11, 'MemoryCache Control' ofIntel® 64 and IA-32 Architectures Software Developer's Manual,Volume 3A. Because the WC protocol uses a weakly-ordered memory consistency model, an MFENCE or locked instruction should be used in conjunction with MOVNTDQA instructions if multiple processors might reference the same WC memory locations or in order to synchronize reads of a processor with writes by other agents in the system. Because of the speculative nature of fetching due to MOVNTDQA, Streaming loads must not be used to reference memory addresses that are mapped to I/O devices having side effects or when reads to these devices are destructive. For additional information on MOVNTDQA usages, see Section 12.10.3 in Chapter 12, 'Programming with SSE3, SSSE3 and SSE4' ofIntel®64 and IA-32 Architectures SoftwareDeveloper's Manual, Volume 1. " ^ self addInstruction: #movntdqa operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movnti: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Doubleword Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the doubleword integer in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is a general-purpose register. The destination operand is a 32-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTI instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #movnti operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Packed Double-FP Values Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the double quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is an XMM register, which is assumed to contain two packed double-precision floating-point values. The destination operand is a 128-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTPD instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movntpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Packed Single-FP Values Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the double quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is an XMM register, which is assumed to contain four packed single-precision floating-point values. The destination operand is a 128-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTPS instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movntps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntq: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store of Quadword Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is an MMX technology register, which is assumed to contain packed integer data (packed bytes, words, or doublewords). The destination operand is a 64-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTQ instructions if multiple processors might use different memory types to read/write the destination memory locations. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #movntq operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movss: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Scalar Single-FP Values Description ----------- Moves a scalar single-precision floating-point value from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be XMM registers or 32-bit memory locations. This instruction can be used to move a single-precision floating-point value to and from the low doubleword of an XMM register and a 32-bit memory location, or to move a single-precision floating-point value between the low doublewords of two XMM registers. The instruction cannot be used to transfer data between memory locations. When the source and destination operands are XMM registers, the three high-order doublewords of the destination operand remain unchanged. When the source operand is a memory location and destination operand is an XMM registers, the three high-order doublewords of the destination operand are cleared to all 0s. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movss operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movsx: aDestinationRegister with: aSourceRegisterOrMemory "Move with Sign-Extension " ^ self addInstruction: #movsx operands: { aDestinationRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movsxd: aDestinationRegister with: aSourceRegisterOrMemory "Move with Sign-Extension " ^ self addInstruction: #movsxd operands: { aDestinationRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movupd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Unaligned Packed Double-FP Value Pseudo Code ----------- DEST = SRC; Description ----------- Moves a double quadword containing two packed double-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, store the contents of an XMM register into a 128-bit memory location, or move data between two XMM registers. When the source or destination operand is a memory operand, the operand may be unaligned on a 16-byte boundary without causing a general-protection exception (\#GP) to be generated.1 To move double-precision floating-point values to and from memory locations that are known to be aligned on 16-byte boundaries, use the MOVAPD instruction. While executing in 16-bit addressing mode, a linear address for a 128-bit data access that overlaps the end of a 16-bit segment is not allowed and is defined as reserved behavior. A specific processor implementation may or may not generate a general-protection exception (\#GP) in this situation, and the address that spans the end of the segment may or may not wrap around to the beginning of the segment. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). ​1. If alignment checking is enabled (CR0.AM = 1, RFLAGS.AC = 1, and CPL = 3), an alignment-check exception (\#AC) may or may not be generated (depending on processor implementation) when the operand is not aligned on an 8-byte boundary. " ^ self addInstruction: #movupd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movups: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Unaligned Packed Single-FP Values Pseudo Code ----------- DEST = SRC; Description ----------- Moves a double quadword containing four packed single-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, store the contents of an XMM register into a 128-bit memory location, or move data between two XMM registers. When the source or destination operand is a memory operand, the operand may be unaligned on a 16-byte boundary without causing a general-protection exception (\#GP) to be generated.1 To move packed single-precision floating-point values to and from memory locations that are known to be aligned on 16-byte boundaries, use the MOVAPS instruction. While executing in 16-bit addressing mode, a linear address for a 128-bit data access that overlaps the end of a 16-bit segment is not allowed and is defined as reserved behavior. A specific processor implementation may or may not generate a general-protection exception (\#GP) in this situation, and the address that spans the end of the segment may or may not wrap around to the beginning of the segment. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). ​1. If alignment checking is enabled (CR0.AM = 1, RFLAGS.AC = 1, and CPL = 3), an alignment-check exception (\#AC) may or may not be generated (depending on processor implementation) when the operand is not aligned on an 8-byte boundary. " ^ self addInstruction: #movups operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movzx: aDestinationRegister with: aSourceRegisterOrMemory "Move with Zero-Extend Pseudo Code ----------- DEST = ZeroExtend(SRC); Description ----------- Copies the contents of the source operand (register or memory location) to the destination operand (register) and zero extends the value. The size of the converted value depends on the operand-size attribute. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bit operands. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #movzx operands: { aDestinationRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! mul: aDestination "Unsigned Multiply Description ----------- Performs an unsigned multiplication of the first operand (destination operand) and the second operand (source operand) and stores the result in the destination operand. The destination operand is an implied operand located in register AL, AX or EAX (depending on the size of the operand); the source operand is located in a general-purpose register or a memory location. The action of this instruction and the location of the result depends on the opcode and the operand size as shown in the following table. The result is stored in register AX, register pair DX:AX, or register pair EDX:EAX (depending on the operand size), with the high-order bits of the product contained in register AH, DX, or EDX, respectively. If the high-order bits of the product are 0, the CF and OF flags are cleared; otherwise, the flags are set. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8 - R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. Operand Size Source 1 Source 2 Destination -------------- ---------- ---------- ------------- Byte AL r/m8 AX Word AX r/m16 DX:AX Doubleword EAX r/m32 EDX:EAX Quadword RAX r/m64 RDX:RAX : MUL Results " ^ self addInstruction: #mul operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! neg: aDestination "Two's Complement Negation Pseudo Code ----------- IF DEST = 0 CF = 0; ELSE CF = 1; FI; DEST = [- (DEST)] Description ----------- Replaces the value of operand (the destination operand) with its two's complement. (This operation is equivalent to subtracting the operand from 0.) The destination operand is located in a general-purpose register or a memory location. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #neg operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! not: aDestination "One's Complement Negation Pseudo Code ----------- DEST = NOT DEST; Description ----------- Performs a bitwise NOT operation (each 1 is set to 0, and each 0 is set to 1) on the destination operand and stores the result in the destination operand location. The destination operand can be a register or a memory location. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #not operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! or: aRegisterOrMemoryOperand with: aSource "Logical Inclusive OR Pseudo Code ----------- DEST = DEST OR SRC; Description ----------- Performs a bitwise inclusive OR operation between the destination (first) and source (second) operands and stores the result in the destination operand location. The source operand can be an immediate, a register, or a memory location; the destination operand can be a register or a memory location. (However, two memory operands cannot be used in one instruction.) Each bit of the result of the OR instruction is set to 0 if both corresponding bits of the first and second operands are 0; otherwise, each bit is set to 1. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #or operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! pop: aRegisterOrMemoryDestination "Pop a Value from the Stack Description ----------- Loads the value from the top of the stack to the location specified with the destination operand (or explicit opcode) and then increments the stack pointer. The destination operand can be a general-purpose register, memory location, or segment register. The address-size attribute of the stack segment determines the stack pointer size (16, 32, 64 bits) and the operand-size attribute of the current code segment determines the amount the stack pointer is incremented (2, 4, 8 bytes). For example, if the address- and operand-size attributes are 32, the 32-bit ESP register (stack pointer) is incremented by 4; if they are 16, the 16-bit SP register is incremented by 2. (The B flag in the stack segment's segment descriptor determines the stack's address-size attribute, and the D flag in the current code segment's segment descriptor, along with prefixes, determines the operand-size attribute and also the address-size attribute of the destination operand.) If the destination operand is one of the segment registers DS, ES, FS, GS, or SS, the value loaded into the register must be a valid segment selector. In protected mode, popping a segment selector into a segment register automatically causes the descriptor information associated with that segment selector to be loaded into the hidden (shadow) part of the segment register and causes the selector and the descriptor information to be validated (see the 'Operation' section below). A NULL value (0000-0003) may be popped into the DS, ES, FS, or GS register without causing a general protection fault. However, any subsequent attempt to reference a segment whose corresponding segment register is loaded with a NULL value causes a general protection exception (\#GP). In this situation, no memory reference occurs and the saved value of the segment register is NULL. The POP instruction cannot pop a value into the CS register. To load the CS register from the stack, use the RET instruction. If the ESP register is used as a base register for addressing a destination operand in memory, the POP instruction computes the effective address of the operand after it increments the ESP register. For the case of a 16-bit stack where ESP wraps to 0H as a result of the POP instruction, the resulting location of the memory write is processor-family-specific. The POP ESP instruction increments the stack pointer (ESP) before data at the old top of stack is written into the destination. A POP SS instruction inhibits all interrupts, including the NMI interrupt, until after execution of the next instruction. This action allows sequential execution of POP SS and MOV ESP, EBP instructions without the danger of having an invalid stack during an interrupt1. However, use of the LSS instruction is the preferred method of loading the SS and ESP registers. In 64-bit mode, using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). When in 64-bit mode, POPs using 32-bit operands are not encodable and POPs to DS, ES, SS are not valid. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #pop operands: { aRegisterOrMemoryDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! popcnt: aRegister with: aSourceRegisterOrMemory "Bit Population Count Description ----------- This instruction calculates of number of bits set to 1 in the second operand (source) and returns the count in the first operand (a destination register). " ^ self addInstruction: #popcnt operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! push: aSource "Push Word, Doubleword or Quadword Onto the Stack " ^ self addInstruction: #push operands: { aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! rcl: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #rcl operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! rcr: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #rcr operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ret: anImmediate " " ^ self addInstruction: #ret operands: { anImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! rol: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #rol operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ror: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #ror operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sal: aDestinationRegisterOrMemory with: aRegisterOrImmediate " " ^ self addInstruction: #sal operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sar: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #sar operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sbb: aRegisterOrMemoryOperand with: aSource "Integer Subtraction with Borrow " ^ self addInstruction: #sbb operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shl: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #shl operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shld: aDestinationRegisterOrMemory with: aSourceRegister with: aSourceRegisterOrImmediate "Double Precision Shift Left Description ----------- The SHLD instruction is used for multi-precision shifts of 64 bits or more. The instruction shifts the first operand (destination operand) to the left the number of bits specified by the third operand (count operand). The second operand (source operand) provides bits to shift in from the right (starting with bit 0 of the destination operand). The destination operand can be a register or a memory location; the source operand is a register. The count operand is an unsigned integer that can be stored in an immediate byte or in the CL register. If the count operand is CL, the shift count is the logical AND of CL and a count mask. In non-64-bit modes and default 64-bit mode; only bits 0 through 4 of the count are used. This masks the count to a value between 0 and 31. If a count is greater than the operand size, the result is undefined. If the count is 1 or greater, the CF flag is filled with the last bit shifted out of the destination operand. For a 1-bit shift, the OF flag is set if a sign change occurred; otherwise, it is cleared. If the count operand is 0, flags are not affected. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits (upgrading the count mask to 6 bits). See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #shld operands: { aDestinationRegisterOrMemory . aSourceRegister . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shr: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #shr operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shrd: aDestinationRegisterOrMemory with: aSourceRegister with: aSourceRegisterOrImmediate "Double Precision Shift Right Description ----------- The SHRD instruction is useful for multi-precision shifts of 64 bits or more. The instruction shifts the first operand (destination operand) to the right the number of bits specified by the third operand (count operand). The second operand (source operand) provides bits to shift in from the left (starting with the most significant bit of the destination operand). The destination operand can be a register or a memory location; the source operand is a register. The count operand is an unsigned integer that can be stored in an immediate byte or the CL register. If the count operand is CL, the shift count is the logical AND of CL and a count mask. In non-64-bit modes and default 64-bit mode, the width of the count mask is 5 bits. Only bits 0 through 4 of the count register are used (masking the count to a value between 0 and 31). If the count is greater than the operand size, the result is undefined. If the count is 1 or greater, the CF flag is filled with the last bit shifted out of the destination operand. For a 1-bit shift, the OF flag is set if a sign change occurred; otherwise, it is cleared. If the count operand is 0, flags are not affected. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits (upgrading the count mask to 6 bits). See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #shrd operands: { aDestinationRegisterOrMemory . aSourceRegister . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! stmxcsr: aMemoryOperand "Store MXCSR Register State Pseudo Code ----------- m32 = MXCSR; Description ----------- Stores the contents of the MXCSR control and status register to the destination operand. The destination operand is a 32-bit memory location. The reserved bits in the MXCSR register are stored as 0s. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #stmxcsr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sub: aRegisterOrMemoryOperand with: aSource "Subtract Pseudo Code ----------- DEST = (DEST - SRC); Description ----------- Subtracts the second operand (source operand) from the first operand (destination operand) and stores the result in the destination operand. The destination operand can be a register or a memory location; the source operand can be an immediate, register, or memory location. (However, two memory operands cannot be used in one instruction.) When an immediate value is used as an operand, it is sign-extended to the length of the destination operand format. The SUB instruction performs integer subtraction. It evaluates the result for both signed and unsigned integer operands and sets the OF and CF flags to indicate an overflow in the signed or unsigned result, respectively. The SF flag indicates the sign of the signed result. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. " ^ self addInstruction: #sub operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! test: aRegisterOrMemory with: aRegisterOrImmediate "Logical Compare Description ----------- Computes the bit-wise logical AND of first operand (source 1 operand) and the second operand (source 2 operand) and sets the SF, ZF, and PF status flags according to the result. The result is then discarded. In 64-bit mode, using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #test operands: { aRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! xadd: aDestinationRegisterOrMemory with: aSourceRegister "Exchange and Add Pseudo Code ----------- TEMP = SRC + DEST; SRC = DEST; DEST = TEMP; Description ----------- Exchanges the first operand (destination operand) with the second operand (source operand), then loads the sum of the two values into the destination operand. The destination operand can be a register or a memory location; the source operand is a register. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. " ^ self addInstruction: #xadd operands: { aDestinationRegisterOrMemory . aSourceRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! xchg: aDestinationRegisterOrMemory with: aSourceRegister "Exchange Register/Memory with Register Pseudo Code ----------- TEMP = DEST; DEST = SRC; SRC = TEMP; Description ----------- Exchanges the contents of the destination (first) and source (second) operands. The operands can be two general-purpose registers or a register and a memory location. If a memory operand is referenced, the processor's locking protocol is automatically implemented for the duration of the exchange operation, regardless of the presence or absence of the LOCK prefix or of the value of the IOPL. (See the LOCK prefix description in this chapter for more information on the locking protocol.) This instruction is useful for implementing semaphores or similar data structures for process synchronization. (See 'Bus Locking' in Chapter 8 of theIntel® 64 and IA-32Architectures Software Developer's Manual, Volume 3A, for more information on bus locking.) The XCHG instruction can also be used instead of the BSWAP instruction for 16-bit operands. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #xchg operands: { aDestinationRegisterOrMemory . aSourceRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! xor: aRegisterOrMemoryOperand with: aSource "Logical Exclusive OR Pseudo Code ----------- DEST = DEST XOR SRC; Description ----------- Performs a bitwise exclusive OR (XOR) operation on the destination (first) and source (second) operands and stores the result in the destination operand location. The source operand can be an immediate, a register, or a memory location; the destination operand can be a register or a memory location. (However, two memory operands cannot be used in one instruction.) Each bit of the result is 1 if the corresponding bits of the operands are different; each bit is 0 if the corresponding bits are the same. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #xor operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'labels' stamp: 'CamilloBruni 5/29/2012 13:15'! label: aNameOrLabel ^ self label: aNameOrLabel ifPresent: [ self error: 'label ', aNameOrLabel asString, ' already set' ].! ! !AJx86Assembler methodsFor: 'labels' stamp: 'CamilloBruni 7/18/2012 16:27'! label: aNameOrLabel ifPresent: anExceptionBlock | label | label := aNameOrLabel. label isString ifTrue: [ label := self labelNamed: label ]. label isSet ifTrue: [ ^ anExceptionBlock cull: label ]. label isSet: true. ^ self addInstruction: label. ! ! !AJx86Assembler methodsFor: 'labels' stamp: 'CamilloBruni 5/29/2012 13:06'! labelNamed: aNameOrLabel "directly use an object as label" aNameOrLabel isString ifFalse: [ self assert: (labels at: aNameOrLabel name ) = aNameOrLabel. ^ aNameOrLabel ]. ^ labels at: aNameOrLabel ifAbsentPut: [ AJJumpLabel new name: aNameOrLabel ]! ! !AJx86Assembler methodsFor: 'labels'! uniqueLabelName: aName ^ self labelNamed: aName, labels size asString! ! !AJx86Assembler methodsFor: 'options'! noStackFrame stackManager noStackFrame.! ! !AJx86Assembler methodsFor: 'register'! accumulator ^ self is32BitMode ifTrue: [ EAX ] ifFalse: [ AX ]! ! !AJx86Assembler methodsFor: 'register'! basePointer ^ self is32BitMode ifTrue: [ EBP ] ifFalse: [ BP ]! ! !AJx86Assembler methodsFor: 'register'! counter ^ self is32BitMode ifTrue: [ ECX ] ifFalse: [ CX ]! ! !AJx86Assembler methodsFor: 'register'! data ^ self is32BitMode ifTrue: [ EDX ] ifFalse: [ DX ]! ! !AJx86Assembler methodsFor: 'register'! destinationIndex ^ self is32BitMode ifTrue: [ EDI ] ifFalse: [ DI ]! ! !AJx86Assembler methodsFor: 'register'! instructionPointer "not available on 32bit x86 CPUs" self notYetImplemented ! ! !AJx86Assembler methodsFor: 'register'! sourceIndex ^ self is32BitMode ifTrue: [ RSI ] ifFalse: [ SI ]! ! !AJx86Assembler methodsFor: 'register'! stackPointer ^ self is32BitMode ifTrue: [ ESP ] ifFalse: [ SP ]! ! !AJx86Assembler methodsFor: 'stack management'! emitEpilogue: popExtraBytes ^ stackManager emitEpilogue: popExtraBytes assembler: self! ! !AJx86Assembler methodsFor: 'stack management'! releaseTemps: count ^ self addInstruction: (AJReleaseTemps new count: count).! ! !AJx86Assembler methodsFor: 'stack management'! reserveExtraBytesOnStack: numBytes ^ stackManager reserveExtraBytesOnStack: numBytes ! ! !AJx86Assembler methodsFor: 'stack management'! reserveTemp ^ self addInstruction: (AJReserveTemp new size: self wordSize). ! ! !AJx86Assembler methodsFor: 'stack management'! strackFrameValueAtOffset: offset ^ EBP ptr32 - offset! ! !AJx86Assembler methodsFor: 'testing'! hasLabelNamed: aName ^ labels includesKey: aName ! ! !AJx86Assembler methodsFor: 'testing'! is32 ^ true! ! !AJx86Assembler methodsFor: 'testing'! isLabelUsed: aLabel | used | used := false. instructions do: [:instr | used := used or: [instr isLabelUsed: aLabel ] ]. ^ used! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJx86Assembler class instanceVariableNames: ''! !AJx86Assembler class methodsFor: 'debugging'! gccDisassemble: bytesArray "compile the given bytes to a C binary and disassemble it using gdb" ^ self new gccDisassemble: bytesArray! ! !AJx86Assembler class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/19/2012 11:46'! noStackFrame ^ self new noStackFrame! ! AJRegister subclass: #AJx86GPRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'AsmJit-x86-Operands'! !AJx86GPRegister commentStamp: 'sig 12/7/2009 03:22' prior: 0! A general purpose x86 & x64 registers! !AJx86GPRegister methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 11:07'! descriptionOn: s s nextPutAll: 'A '; print: self size * 8; nextPutAll: 'bit general purpose register'.! ! !AJx86GPRegister methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2012 18:48'! registerName ^ name asString.! ! !AJx86GPRegister methodsFor: 'accessing'! stackSize ^ self size! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 12:51'! as16 self isHighByte ifTrue: [ ^ self asLowByte as16 ]. ^ AJx86Registers code: (16r10 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:07'! as32 self isHighByte ifTrue: [ ^ self asLowByte as32 ]. ^ AJx86Registers code: (16r20 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:07'! as64 self isHighByte ifTrue: [ ^ self asLowByte as64 ]. ^ AJx86Registers code: (16r30 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:03'! as8 self is8 ifTrue: [ ^ self ]. (self index >= 4 and: [ self index <= 7 ] ) ifTrue: [ Error signal: 'Cannot map ', self asString, ' to corrsponding 8bit register']. ^ AJx86Registers code: (0 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:01'! asHighByte self isHighByte ifTrue: [ ^ self ]. self isLowByte ifFalse: [ Error signal: 'Can only convert high byte 8bit register to low byte' ]. ^ AJx86Registers code: self index + 2r100! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:05'! asLowByte self isLowByte ifTrue: [ ^ self ]. self isHighByte ifFalse: [ Error signal: 'Can only convert high byte 8bit register to low byte' ]. ^ AJx86Registers code: self index - 2r100! ! !AJx86GPRegister methodsFor: 'converting'! ptr "turn receiver into a memory operand with receiver as base" ^ AJMem new base: self! ! !AJx86GPRegister methodsFor: 'emitting'! emitModRM: emitter code: rCode immSize: immSize "Receiver is register, hence mod = 3 immSize is ignored" ^ emitter emitMod: 3 reg: rCode rm: self code! ! !AJx86GPRegister methodsFor: 'printing'! printAsMemBase ^ self registerName ! ! !AJx86GPRegister methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self registerName ! ! !AJx86GPRegister methodsFor: 'testing'! isGeneralPurpose ^ true! ! !AJx86GPRegister methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 13:03'! isHighByte "return true for 8bit high-byte registers (AH - DH)" ^ self is8 and: [ (self code bitAnd: RegHighByteMask) = 2r100 ]! ! !AJx86GPRegister methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 12:57'! isLowByte "return true for 8bit low-byte register (AL - DL)" ^ self code <= 3! ! AJInstruction subclass: #AJx86Instruction instanceVariableNames: 'description' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description ^ description! ! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description: anInstructionDescription description := anInstructionDescription! ! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/29/2012 13:54'! emitByte: byte self assert: byte isByte. machineCode nextPut: byte ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 4/17/2012 17:56'! emitCode: asm "do not generate machine code if it is already there" machineCode ifNotNil: [ ^ self ]. "make sure all operands are converted" operands ifNotNil: [ operands := operands collect: #asAJOperand ]. machineCode := WriteStream on: (ByteArray new: 16). description emitUsing: self operands: operands. machineCode := machineCode contents.! ! !AJx86Instruction methodsFor: 'code generation'! emitDWord: dword "Emit dword (4 bytes) in little-endian order (since our target it x86 anyways)" self emitByte: (dword bitAnd: 255); emitByte: (dword>>8 bitAnd: 255); emitByte: (dword>>16 bitAnd: 255); emitByte: (dword>>24 bitAnd: 255) ! ! !AJx86Instruction methodsFor: 'code generation'! emitImmediate: imm size: size ^ imm emitUsing: self size: size! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/28/2012 15:59'! emitMod: mod reg: reg rm: rm "Emit MODR/M byte. mmrrrxxx mm = mod rrr = REG (r8/r16/r32/mm/xmm xxx = r/m " ^ self emitByte: (mod & 3) << 3 + (reg & 7) << 3 + (rm & 7) ! ! !AJx86Instruction methodsFor: 'code generation'! emitOpCode: opCode | byte | "instruction prefix" (byte := (opCode bitAnd: 16rFF000000)) = 0 ifFalse: [ self emitByte: byte >> 24 ]. (byte := (opCode bitAnd: 16r00FF0000)) = 0 ifFalse: [ self emitByte: byte >> 16 ]. (byte := (opCode bitAnd: 16r0000FF00)) = 0 ifFalse: [ self emitByte: byte >> 8 ]. self emitByte: (opCode bitAnd: 16rFF). ! ! !AJx86Instruction methodsFor: 'code generation'! emitQWord: dword "Emit a qword (8 bytes) in little-endian order (since our target it x86 anyways)" self emitByte: (dword bitAnd: 255); emitByte: (dword>>8 bitAnd: 255); emitByte: (dword>>16 bitAnd: 255); emitByte: (dword>>24 bitAnd: 255); emitByte: (dword>>32 bitAnd: 255); emitByte: (dword>>40 bitAnd: 255); emitByte: (dword>>48 bitAnd: 255); emitByte: (dword>>56 bitAnd: 255) ! ! !AJx86Instruction methodsFor: 'code generation'! emitRexForInteger: anInt op2: op2 self emitRexPrefixW: op2 is64 R: false X: false B: op2 isUpperBank.! ! !AJx86Instruction methodsFor: 'code generation'! emitRexForOp1: op1 op2: op2 "In 64-bit mode, the instruction’s default operation size is 32 bits. Use of the REX.W prefix promotes operation to 64 bits. Use of the REX.R prefix permits access to additional registers (R8-R15) for the op2 register. Use of the REX.B prefix permits access to additional registers (R8-R15) for the op1 register. See the summary chart at the beginning of this section for encoding data and limits." | requires64Bit | "no-op in 32 bit mode" self is32BitMode ifTrue: [ ^ self ]. op1 isInteger ifTrue: [ ^ self emitRexForInteger: op1 op2: op2 ]. requires64Bit := op1 is64 or: [ op2 isReg and: [ op2 is64 ] ]. self emitRexPrefixW: requires64Bit R: op1 isUpperBank X: false B: op2 isUpperBank.! ! !AJx86Instruction methodsFor: 'code generation'! emitRexForSingleOperand: op "In 64-bit mode, the instruction’s default operation size is 32 bits. Use of the REX.W prefix promotes operation to 64 bits. Use of the REX.B prefix permits access to additional registers (R8-R15). See the summary chart at the beginning of this section for encoding data and limits." self emitRexPrefixW: op is64 R: false X: false B: op isUpperBank .! ! !AJx86Instruction methodsFor: 'code generation'! emitRexPrefixW: w R: r X: x B: b " field bit def - 7-4 2r0100 REX prefix identifier W 3 0 = Operand size determined by CS.D 1 = 64 Bit Operand Size R 2 Extension of the ModR/M reg field X 1 Extension of the SIB index field B 0 Extension of the ModR/M r/m field. SIB base field, or Opcode reg field " "no-op in 32 bit mode" self is32BitMode ifTrue: [ ^ self ]. "an empty REX prefix has no effect, hence we ignore it" (w or: [ r or: [ x or: b]]) ifFalse: [ ^ self ]. self emitByte: 2r0100 << 4 | (w asBit << 3) | (r asBit << 2)| (x asBit << 1) | (b asBit)! ! !AJx86Instruction methodsFor: 'code generation'! emitRexR: w opReg: opReg regCode: regCode "no-op in 32 bit mode" ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 4/4/2012 17:10'! emitRexRM: opRequires64Bit regCode: regCode rm: rm self emitRexPrefixW: opRequires64Bit R: (regCode > 7) X: false B: rm isUpperBank ! ! !AJx86Instruction methodsFor: 'code generation'! emitScale: shift index: indexCode base: baseCode self emitByte: shift << 3 + indexCode << 3 + baseCode! ! !AJx86Instruction methodsFor: 'code generation'! emitSegmentPrefix: aMem (aMem isMem and: [ aMem hasSegmentPrefix ]) ifTrue: [ self emitByte: aMem segmentPrefixCode. ] ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/30/2012 17:10'! emitX86Inl: opCode reg: reg "Emit instruction where register is inlined to opcode." ^ self emitX86Inl: opCode reg: reg withRex: true! ! !AJx86Instruction methodsFor: 'code generation'! emitX86Inl: opCode reg: reg withRex: useREX "Emit instruction where register is inlined to opcode." | byte | "16 bit prefix" reg size == 2 ifTrue: [ self emitByte: 16r66 ]. "instruction prefix" (byte := (opCode bitAnd: 16rFF000000)) = 0 ifFalse: [ self emitByte: byte >> 24 ]. useREX ifTrue: [ self emitRexForSingleOperand: reg ]. (byte := (opCode bitAnd: 16r00FF0000)) = 0 ifFalse: [ self emitByte: byte >> 16 ]. (byte := (opCode bitAnd: 16r0000FF00)) = 0 ifFalse: [ self emitByte: byte >> 8 ]. self emitByte: (opCode bitAnd: 16rFF) + (reg code bitAnd: 7). ! ! !AJx86Instruction methodsFor: 'code generation'! emitX86RM: opCode size: aSize regOrCode: regOrCode rm: regOrMem "Emit instruction with reg/memory operand." ^ self emitX86RM: opCode size: aSize regOrCode: regOrCode rm: regOrMem immSize: 0 ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/30/2012 16:50'! emitX86RM: opCode size: aSize regOrCode: regOrCode rm: regOrMem immSize: immSize "Emit instruction with reg/memory operand." | byte code | code := regOrCode isInteger ifTrue: [ regOrCode ] ifFalse: [ regOrCode code ]. "16 bit prefix" aSize == 2 ifTrue: [ self emitByte: 16r66 ]. "segment prefix" self emitSegmentPrefix: regOrMem. "instruction prefix" (byte := (opCode bitAnd: 16rFF000000)) = 0 ifFalse: [ self emitByte: byte >> 24 ]. self emitRexForOp1: regOrCode op2: regOrMem. (byte := (opCode bitAnd: 16r00FF0000)) = 0 ifFalse: [ self emitByte: byte >> 16 ]. (byte := (opCode bitAnd: 16r0000FF00)) = 0 ifFalse: [ self emitByte: byte >> 8 ]. self emitByte: (opCode bitAnd: 16rFF). "ModR/M" ^ regOrMem emitModRM: self code: code immSize: immSize ! ! !AJx86Instruction methodsFor: 'code generation'! setLabelPosition: label "set label position for immediate operand(s), if any" label position: self position + machineCode size. ! ! !AJx86Instruction methodsFor: 'code generation - prefixes' stamp: 'CamilloBruni 3/30/2012 17:07'! emitOperandSizeOverridePrefix: anOperand "If creating 64bit code, this must be called last of the prefix-generators, as the 64-bit prefixes are required to precede the opcode" "Switch to 16-bit operand mode for the next opcode if necessary" anOperand is16 ifTrue: [ self emitByte: 16r66]. self emitRexRM: anOperand is64 regCode: 0 rm: anOperand ! ! !AJx86Instruction methodsFor: 'emitting code'! emitWord: aWord "little-endian" self emitByte: (aWord bitAnd: 255); emitByte: ((aWord >> 8) bitAnd: 255) ! ! !AJx86Instruction methodsFor: 'testing'! is32BitMode ^ true! ! !AJx86Instruction methodsFor: 'testing'! is64BitMode ^ false! ! !AJx86Instruction methodsFor: 'testing'! isGPNRegister: reg "answer true if given register is native general purpose register, matching the target native size i.e. 32 bits for x86 or 64 bits for x64" ^ reg isGeneralPurpose and: [ reg size = 4 ]! ! !AJx86Instruction methodsFor: 'visitor'! accept: anObject "generic instruction" ^ anObject visitInstruction: self ! ! Object subclass: #AJx86InstructionDescription instanceVariableNames: 'name group comment description o1Flags o2Flags opCodeR opCode1 opCode2 groupEmitSelector' classVariableNames: '' poolDictionaries: 'AJConstants AJx86Registers' category: 'AsmJit-x86-Instructions'! !AJx86InstructionDescription commentStamp: 'sig 12/7/2009 10:36' prior: 0! name: an instruction mnemonic group: an instruction encoding group o1Flags: operand1 flags o2Flags: operand2 flags opCode1: opcode 1 opCode2: opcode 2 opCodeR: code for inlining in MR field as register Operand flags: bit: 9 | 8 | 7 | 6 | 5 | 4 | 3 | 2 | 1 | 0 | ______________________________________________ *86| *64 | XMM | MM | IMM | MEM | 64 | 32 | 16 | 8| - *64 , set on o1Flags, meaning that instruction available only for x64 processor mode - *86 , set on o1Flags, meaning that instruction available only for x86 processor mode ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 15:44'! comment ^ comment! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 15:44'! comment: aString comment := aString! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 14:51'! description ^ description! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 14:51'! description: aString description := aString! ! !AJx86InstructionDescription methodsFor: 'accessing'! group ^ group! ! !AJx86InstructionDescription methodsFor: 'accessing'! group: anObject "Set the value of group" group := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! name ^ name! ! !AJx86InstructionDescription methodsFor: 'accessing'! name: anObject "Set the value of name" name := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! o1Flags "Answer the value of o1Flags" ^ o1Flags! ! !AJx86InstructionDescription methodsFor: 'accessing'! o1Flags: anObject "Set the value of o1Flags" o1Flags := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! o2Flags "Answer the value of o2Flags" ^ o2Flags! ! !AJx86InstructionDescription methodsFor: 'accessing'! o2Flags: anObject "Set the value of o2Flags" o2Flags := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode1 "Answer the value of opCode1" ^ opCode1! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode1: anObject "Set the value of opCode1" opCode1 := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode2 "Answer the value of opCode2" ^ opCode2! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode2: anObject "Set the value of opCode2" opCode2 := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCodeR "Answer the value of opCodeR" ^ opCodeR! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCodeR: anObject "Set the value of opCodeR" opCodeR := anObject! ! !AJx86InstructionDescription methodsFor: 'code emitting' stamp: 'CamilloBruni 3/30/2012 17:36'! emittest: emitter operand1: op1 operand2: op2 operand3: op3 | immSize | op1 isRegMem & op2 isReg ifTrue: [ (op1 size = op2 size) ifFalse: [ self error: 'Operands ', op1 asString, ' and ', op2 asString, ' don''t match in size: ', op1 size asString, ' !!= ', op2 size asString ]. self upperBankHighByteGuardOp1: op1 op2: op2. ^ emitter emitX86RM: 16r84 + (op1 isRegTypeGPB not) asBit size: op2 size regOrCode: op2 rm: op1 ]. (op1 isReg and: [ op1 index = 0 and: [ op2 isImm ]]) ifTrue: [ immSize := op1 size min: 4. op1 is16 ifTrue: [ emitter emitByte: 16r66 "16bit" ]. emitter emitRexRM: op1 is64 regCode: 0 rm: op1. emitter emitByte: 16rA8 + (op1 size ~= 1) asBit. ^ emitter emitImmediate: op2 size: immSize ]. (op1 isRegMem and: [ op2 isImm ]) ifFalse: [ self invalidInstruction ]. immSize := op1 size min: 4. (op2 fitsInSize: immSize) ifFalse: [ self invalidInstruction ]. emitter emitSegmentPrefix: op1. emitter emitOperandSizeOverridePrefix: op1. emitter emitByte: 16rF6 + (op1 size ~= 1) asBit. op1 emitModRM: emitter code: 0 immSize: immSize. emitter emitImmediate: op2 size: immSize ! ! !AJx86InstructionDescription methodsFor: 'code emitting'! upperBankHighByteGuardOp1: op1 op2: op2 "REX prefix and AH BH CH DH don't go along on 64bit" (((op1 isUpperBank or: [op1 is64]) and: [{ AH. BH. CH. DH} includes: op2 ]) or: [ ((op2 isUpperBank or: [op2 is64]) and: [{ AH. BH. CH. DH} includes: op1 ])]) ifTrue: [ Error signal: '64 bit mode doesn''t allow operand combination ', op1 asString, ' with ', op2 asString ]! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitalu: emitter operand1: op1 operand2: op2 operand3: op3 | opCode opReg | opCode := opCode1. opReg := opCodeR. " Mem <- Reg " (op1 isMem and: [ op2 isReg ]) ifTrue: [ ^ emitter emitX86RM: opCode + op2 isRegTypeGPB not asBit size: op2 size regOrCode: op2 rm: op1 ]. "Reg <- Reg|Mem" (op1 isReg and: [op2 isRegMem]) ifTrue: [ ^ emitter emitX86RM: opCode + 2 + op1 isRegTypeGPB not asBit size: op1 size regOrCode: op1 rm: op2 ]. op2 isImm ifFalse: [ self invalidInstruction ]. "short constant" op2 isInt8 ifTrue: [ | szBits | szBits := op1 size = 1 ifTrue: [ 0 ] ifFalse: [ 3 ]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: 1. ^ emitter emitImmediate: op2 size: 1. ]. " AL, AX, EAX, RAX register shortcuts" (op1 isRegIndex: 0) ifTrue: [ op1 isRegTypeGPW ifTrue: [ emitter emitByte: 16r66 " 16 bit " ]. op1 isRegTypeGPQ ifTrue: [ emitter emitByte: 16r48 " REX.W" ]. emitter emitByte: (opReg << 3 bitOr: (16r04 + op1 isRegTypeGPB not asBit)). ^ emitter emitImmediate: op2 size: (op1 size min: 4) ]. (op1 isRegMem) ifTrue: [ | immSize szBits | immSize := op2 isInt8 ifTrue: [1] ifFalse: [ op1 size min: 4]. szBits := op1 size ~= 1 ifTrue: [ immSize ~= 1 ifTrue: [1] ifFalse: [3]] ifFalse: [ 0]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: immSize. ^ emitter emitImmediate: op2 size: immSize. ]. self invalidInstruction. ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitbswap: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ emitter emitRexR: op1 isRegTypeGPQ opReg: 1 regCode: op1 code. emitter emitByte: 16r0F. ^ emitter emitModR: 1 r: op1 code ]. self invalidInstruction.! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 5/15/2012 14:18'! emitbt: emitter operand1: dst operand2: src operand3: op3 dst isRegMem ifFalse: [ self error: 'Expected register or memory but got ', dst asString ]. (dst isReg and: [ dst is8 ]) ifTrue: [ self error: '8 bit register ', dst asString, ' not supported for bit test operations']. src isReg ifTrue: [ ^ emitter emitX86RM: opCode1 size: src size regOrCode: src rm: dst ]. src isImm ifTrue: [ src isInt8 ifFalse: [ self error: 'Expected imm8 but got ', src size asString, ' immediate.' ]. emitter emitX86RM: opCode2 size: dst size regOrCode: opCodeR rm: dst immSize: 1. ^ emitter emitImmediate: src size: 1 ]. self invalidInstruction ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitcall: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isMem or: [ op1 isReg and: [ op1 index = 0 "EAX" ] ]) ifTrue: [ ^ emitter emitX86RM: 16rFF size: 4 regOrCode: 2 rm: op1 ]. op1 isImm ifTrue: [ "call by relative offset, you should be really sure what you're' doing" emitter emitByte: 16rE8. op1 emitUsing: emitter size: 4. ^ self. ]. op1 isLabel ifTrue: [ emitter emitByte: 16rE8. emitter emitDisplacement: op1 inlinedDisp: -4. ^ self ]. self invalidInstruction. ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitcjmp: emitter operand1: target operand2: hint operand3: op3 "Conditional jump. Use only symbols as labels" target isString ifTrue: [ "jump on label" ^ emitter addJump: target condition: opCode1 hint: hint ]. "we could check if label is bound , and emit short jump, instead of 32-bit relative jump address" self invalidInstruction. emitter emitByte: 16r0F; emitByte: (16r80 bitOr: opCode1); emitDisplacement: target inlinedDisp: -4 ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitcrc32: emitter operand1: dst operand2: src operand3: op3 (dst isReg and: [ src isRegMem ]) ifTrue: [ self assert: (dst isRegTypeGPD | dst isRegTypeGPQ). ^ emitter emitX86RM: opCode1 + (src size ~= 1) asBit size: src size regOrCode: dst rm: src ]. self invalidInstruction. ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitemit: emitter operand1: op1 operand2: op2 operand3: op3 ^ emitter emitOpCode: opCode1! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitenter: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isImm and: [ op2 isImm ]) ifFalse: [ self invalidInstruction ]. emitter emitByte: 16rC8. emitter emitImmediate: op1 size: 2. emitter emitImmediate: op2 size: 1. ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 4/17/2012 19:02'! emitimul: emitter operand1: op1 operand2: op2 operand3: op3 | immSize | op1 isRegMem ifFalse: [ ^ self invalidInstruction ]. " 1 operand " (op2 isNil and: [ op3 isNil ]) ifTrue: [ ^ emitter emitX86RM: 16rF6 + (op1 size ~= 1) asBit size: op1 size regOrCode: 5 rm: op1 ]. op1 isReg ifFalse: [ ^ self invalidInstruction ]. "2 operands" op3 isNil ifTrue: [ " self assert: op1 isRegTypeGPW." op2 isRegMem ifTrue: [ ^ emitter emitX86RM: 16r0FAF size: op1 size regOrCode: op1 code rm: op2 ]. op2 isImm ifFalse: [ ^ self invalidInstruction ]. (op2 isInt8 and: [ op2 relocMode == #RelocNone ]) ifTrue: [ emitter emitX86RM: 16r6B size: op1 size regOrCode: op1 code rm: op1 immSize: 1. ^ emitter emitImmediate: op2 size: 1. ]. immSize := op1 isRegTypeGPW ifTrue: [ 2 ] ifFalse: [ 4 ]. emitter emitX86RM: 16r69 size: op1 size regOrCode: op1 code rm: op1 immSize: immSize. ^ emitter emitImmediate: op2 size: immSize. ]. " 3 operands " (op2 isRegMem and: [op3 isImm ]) ifFalse: [ ^ self invalidInstruction ]. (op3 isInt8 and: [ op3 relocMode == #RelocNone ]) ifTrue: [ emitter emitX86RM: 16r6B size: op1 size regOrCode: op1 rm: op2 immSize: 1. ^ emitter emitImmediate: op3 size: 1. ]. immSize := op1 isRegTypeGPW ifTrue: [2] ifFalse: [4]. emitter emitX86RM: 16r69 size: op1 size regOrCode: op1 rm: op2 immSize: immSize. emitter emitImmediate: op3 size: immSize. ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitincdec: emitter operand1: dst operand2: op2 operand3: op3 dst isRegMem ifFalse: [ ^ self invalidInstruction ]. "INC [r16|r32] in 64 bit mode is not encodable." emitter is32BitMode ifTrue: [ (dst isReg & dst isRegTypeGPW & dst isRegTypeGPD) ifTrue: [ ^ emitter emitX86Inl: opCode1 reg: dst ]]. emitter emitX86RM: opCode2 + (dst size ~= 1) asBit size: dst size regOrCode: opCodeR rm: dst ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitjmp: emitter operand1: target operand2: op2 operand3: op3 target isString ifTrue: [ "jump on label" ^ emitter addJump: target condition: nil hint: nil ]. target isRegMem ifTrue: [ ^ emitter emitX86RM: 16rFF size: 0 regOrCode: 4 rm: target ]. emitter emitByte: 16rE9. emitter emitDisplacement: target inlinedDisp: -4 ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 4/17/2012 17:41'! emitlea: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isReg and: [ op2 isMem ]) ifFalse: [ self error: 'LEA: Expected Reg and Mem but got ', op1 asString, ' and ', op2 asString ]. emitter emitX86RM: 16r8D size: op1 size regOrCode: op1 rm: op2! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmem: emitter operand1: op1 operand2: op2 operand3: op3 op1 isMem ifFalse: [ self invalidInstruction ]. self assert: (opCode2 = 0 or: [ opCode2 = 1 ]). emitter emitX86RM: opCode1 size: opCode2 << 3 regOrCode: opCodeR rm: op1 ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuMov: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented. self assert: o1Flags ~= 0. self assert: o2Flags ~= 0. "Check parameters (X)MM|GP32_64 <- (X)MM|GP32_64|Mem|Imm" (op1 isMem & ((o1Flags bitAnd: OMEM) = 0)) | (op1 isRegTypeMM & ((o1Flags bitAnd: OMM) = 0)) | (op1 isRegTypeXMM & ((o1Flags bitAnd: OXMM) = 0)) | (op1 isRegTypeGPD & ((o1Flags bitAnd: OG32) = 0)) | (op1 isRegTypeGPQ & ((o1Flags bitAnd: OG64) = 0)) | (op2 isRegTypeMM & ((o2Flags bitAnd: OMM) = 0)) | (op2 isRegTypeXMM & ((o2Flags bitAnd: OXMM) = 0)) | (op2 isRegTypeGPD & ((o2Flags bitAnd: OG32) = 0)) | (op2 isRegTypeGPQ & ((o2Flags bitAnd: OG64) = 0)) | (op2 isMem & ((o2Flags bitAnd: OMEM) = 0)) | (op1 isMem & op2 isMem) ifTrue: [ self invalidInstruction ]. ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuMovD: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuMovQ: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuPextr: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuPrefetch: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuRm3DNow: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuRmImm8: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmurmi: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'IgorStasenko 3/20/2012 16:08'! emitmov: emitter operand1: dst operand2: src operand3: op3 src isReg & dst isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ]. " reg <- mem " dst isReg & src isRegMem ifTrue: [ self assert: (dst isRegTypeGPB | dst isRegTypeGPW | dst isRegTypeGPD | dst isRegTypeGPQ ). " (src size = dst size) ifFalse: [ self invalidInstruction ]. " ^ emitter emitX86RM: 16r0000008A + dst isRegTypeGPB not asBit size: dst size regOrCode: dst rm: src ]. " reg <- imm " dst isReg & src isImm ifTrue: [ | immSize | immSize := dst size. emitter is64BitMode & immSize = 8 & src isInt32 & (src relocMode == #RelocNone) ifTrue: [ "Optimize instruction size by using 32 bit immediate if value can fit to it" emitter emitX86RM: 16rC7 size: dst size regOrCode: 0 rm: dst. immSize := 4 ] ifFalse: [ emitter emitX86Inl: (immSize=1 ifTrue: [16rB0] ifFalse: [16rB8]) reg: dst ]. ^ emitter emitImmediate: src size: immSize ]. "mem <- reg" dst isMem & src isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ^ emitter emitX86RM: 16r88 + src isRegTypeGPB not asBit size: src size regOrCode: src rm: dst ]. "mem <- imm" dst isMem & src isImm ifTrue: [ | immSize | immSize := dst size <= 4 ifTrue: [ dst size ] ifFalse: [4]. emitter emitX86RM: 16rC6 + ((dst size = 1) not) asBit size: dst size regOrCode: 0 rm: dst immSize: immSize. ^ emitter emitImmediate: src size: immSize ]. self invalidInstruction ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmovPtr: emitter operand1: op1 operand2: op2 operand3: op3 | reg imm opCode | (op1 isReg & op2 isImm) | (op1 isImm & op2 isReg) ifFalse: [ self invalidInstruction ]. opCode := op1 isReg ifTrue: [reg := op1. imm := op2. 16rA0] ifFalse: [reg := op2. imm := op1. 16rA2]. reg index ~= 0 ifTrue: [ self invalidInstruction ]. reg isRegTypeGPW ifTrue: [ emitter emitByte: 16r66 ]. emitter emitRexR: (reg size=8) opReg: 0 regCode: 0. emitter emitByte: opCode + (reg size ~=1) asBit. emitter emitImmediate: imm size: reg size ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmovSxZx: emitter operand1: dst operand2: src operand3: op3 dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. dst isRegTypeGPB ifTrue: [ self invalidInstruction ]. (src size ~= 2 and: [src size ~= 1 ]) ifTrue: [ self invalidInstruction ]. (src size = 2 and: [dst isRegTypeGPW ]) ifTrue: [ self invalidInstruction ]. src size = 2 ifTrue: [ ^ emitter emitX86RM: opCode1 + 1 size: dst size regOrCode: dst rm: src ]. emitter emitX86RM: opCode1 size: dst size regOrCode: dst rm: src ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmovbe: anAJx86Assembler operand1: anUndefinedObject operand2: anUndefinedObject3 operand3: anUndefinedObject4 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmovsxd: emitter operand1: dst operand2: src operand3: op3 emitter is64BitMode ifFalse: [ self invalidInstruction ]. dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. emitter emitX86RM: 16r63 size: dst size regOrCode: dst rm: src! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 4/25/2012 15:15'! emitpop: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ (op1 isRegTypeGPW | (emitter isGPNRegister: op1)) ifFalse: [ self error: 'Invalid register given: ', op1 asString]. ^ emitter emitX86Inl: opCode1 reg: op1. ]. op1 isMem ifFalse: [ self invalidInstruction ]. emitter emitX86RM: opCode2 size: op1 size regOrCode: opCodeR rm: op1 ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitpush: emitter operand1: op1 operand2: op2 operand3: op3 "This section is only for immediates, memory/register operands are handled in emitpop:..." op1 isImm ifTrue: [ op1 isInt8 & (op1 relocMode == #RelocNone) ifTrue: [ emitter emitByte: 16r6A. ^ emitter emitImmediate: op1 size: 1 ]. emitter emitByte: 16r68. ^ emitter emitImmediate: op1 size: 4 ]. ^ self emitpop: emitter operand1: op1 operand2: op2 operand3: op3 ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitret: emitter operand1: op1 operand2: op2 operand3: op3 op1 ifNil: [ ^ emitter emitByte: 16rC3 ]. op1 isImm ifFalse: [ self invalidInstruction ]. self assert: (op1 isUnsigned and: [op1 fitsInSize: 2]). (op1 value = 0 and: [ op1 relocMode == #RelocNone ]) ifTrue: [ ^ emitter emitByte: 16rC3 ]. emitter emitByte: 16rC2. emitter emitImmediate: op1 size: 2! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitrm: emitter operand1: dst operand2: src operand3: op3 emitter emitX86RM: opCode1 + (dst isRegTypeGPB not) asBit size: dst size regOrCode: opCodeR rm: dst! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitrmr: emitter operand1: dst operand2: src operand3: op3 dst isRegMem & src isReg ifFalse: [ self invalidInstruction ]. emitter emitX86RM: opCode1 + (src isRegTypeGPB not) asBit size: src size regOrCode: src rm: dst! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitrot: emitter operand1: op1 operand2: op2 operand3: op3 | useImm8 opCode | op1 isRegMem & ((op2 isRegTypeGPB and: [ op2 index = 1 "cl" ]) | op2 isImm) ifFalse: [ self invalidInstruction ]. useImm8 := op2 isImm and: [ (op2 value ~= 1) | (op2 relocMode ~~ #RelocNone) ]. opCode := useImm8 ifTrue: [ 16rC0 ] ifFalse: [ 16rD0 ]. op1 size ~= 1 ifTrue: [ opCode := opCode bitOr: 1 ]. op2 isReg ifTrue: [ opCode := opCode bitOr: 2 ]. emitter emitX86RM: opCode size: op1 size regOrCode: opCodeR rm: op1 immSize: useImm8 asBit. useImm8 ifTrue: [ emitter emitImmediate: op2 size: 1 ] ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitrrm: emitter operand1: dst operand2: src operand3: op3 dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. self assert: (dst isRegTypeGPB not). emitter emitX86RM: opCode1 size: dst size regOrCode: dst rm: src! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitshldShrd: emitter operand1: dst operand2: src1 operand3: src2 (src2 isImm or: [ src2 isRegTypeGPB and: [ src2 index = 1 "cl"]]) ifFalse: [ self invalidInstruction ]. dst isRegMem & src1 isReg ifFalse: [ self invalidInstruction ]. self assert: (dst size = src1 size). emitter emitX86RM: opCode1 + src2 isReg asBit size: src1 size regOrCode: src1 rm: dst immSize: src2 isImm asBit. src2 isImm ifTrue: [ emitter emitImmediate: src2 size: 1 ]! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 7/17/2012 11:10'! emitx87addp: emitter operand1: op1 operand2: op2 operand3: op3 | opp | opp := op1 ifNil: [ AJx87Register new code: 1 ]. opp isRegTypeX87 ifTrue: [ emitter emitByte: (opCode1 bitAnd: 16rFF00)>>8. emitter emitByte: (opCode1 bitAnd: 16rFF) + opp index. ^ self ]. ^self emitx87sti: emitter operand1: opp operand2: op2 operand3: op3 ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitx87fpu: emitter operand1: op1 operand2: op2 operand3: op3 "Either we are in memory, and carry out by using D8 / DC followed by modRM where reg indicates the operation" op1 isMem ifTrue: [ (op2 notNil or: [op3]) notNil ifTrue: [self error: 'Invalid arguments!!']. emitter emitByte: (opCode1 >> (32 - (op1 size* 2)) bitAnd: 16rFF). ^op1 emitModRM: emitter code: opCodeR immSize: nil]. "Or both my arguments are X87 registers, one of which is ST0. Store in op1 register." (op1 isRegTypeX87 and: [op2 isRegTypeX87]) ifTrue: [|shift offset| op1 index = 0 ifTrue: [shift := 24. offset := op2 index] ifFalse: [ op2 index = 0 ifTrue: [shift = 16. offset := op1 index] ifFalse: [self error: 'ST0 must be one of arguments']]. "D8 if Storing in ST0, DC if storing in other" emitter emitByte: (opCode1 >> shift bitAnd: 16rFF). emitter emitByte: (opCode1 >> (shift - 16) bitAnd: 16rFF) + offset ] ifFalse: [self error: 'Invalid arguments!!'] ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitx87fstsw: anAJx86Assembler operand1: anUndefinedObject operand2: anUndefinedObject3 operand3: anUndefinedObject4 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitx87mem: emitter operand1: m operand2: op2 operand3: op3 | opCode mod | m isMem ifFalse: [ ^ self invalidInstruction ]. opCode := mod := 0. (m is16 and: [ (o1Flags bitAnd: OFM2) ~= 0 ]) ifTrue: [ opCode := (opCode1 bitAnd: 16rFF000000) >> 24. mod := opCodeR ]. (m is32 and: [ (o1Flags bitAnd: OFM4) ~= 0 ]) ifTrue: [ opCode := (opCode1 bitAnd: 16r00FF0000) >> 16. mod := opCodeR ]. (m is64 and: [ (o1Flags bitAnd: OFM8) ~= 0 ]) ifTrue: [ opCode := (opCode1 bitAnd: 16r0000FF00) >> 8. mod := (opCode1 bitAnd: 16r000000FF) ]. opCode = 0 ifTrue: [ self invalidInstruction ]. emitter emitSegmentPrefix: m; emitByte: opCode. m emitModRM: emitter code: mod immSize: 0. ! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitx87memSti: emitter operand1: op1 operand2: op2 operand3: op3 op1 isRegTypeX87 ifTrue: [ emitter emitByte: (opCode2 bitAnd: 16rFF000000)>>24. emitter emitByte: (opCode2 bitAnd: 16r00FF0000)>>16 + op1 index. ^ self ]. " ... fall through to I_X87_MEM ... " ^ self emitx87mem: emitter operand1: op1 operand2: op2 operand3: op3 ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 7/23/2012 15:21'! emitx87sti: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isNil and: [ op2 isNil and: [ op3 isNil ]]) ifTrue: [ "Convenience fallback for ST1 " ^ self emitx87sti: emitter operand1: AJx86Registers ST1 operand2: nil operand3: nil ]. op1 isRegTypeX87 ifTrue: [ emitter emitByte: (opCode1 bitAnd: 16rFF00)>>8. emitter emitByte: (opCode1 bitAnd: 16rFF) + op1 index. ^ self ]. self invalidInstruction! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitxchg: emitter operand1: dst operand2: src operand3: op3 dst isRegMem & src isReg ifFalse: [ self invalidInstruction ]. emitter emitSizePrefix: src segment: dst. "Special opcode for index 0 registers (AX, EAX, RAX vs register)" dst isReg & (dst size > 1) & (dst index =0 or: [ src index = 0 ] ) ifTrue: [ | index | index := dst index + src index. ^ emitter emitByte: 16r90 + index. ]. emitter emitByte: 16r86 + src isRegTypeGPB not asBit. dst emitModRM: emitter code: src code immSize: 0! ! !AJx86InstructionDescription methodsFor: 'emitting-dispatch'! emitUsing: emitter operand1: op1 operand2: op2 operand3: op3 (self is64BitOnly and: [ emitter is64BitMode not ]) ifTrue: [ self error: 'instruction is only for 64 bit mode' ]. (self is32BitOnly and: [ emitter is32BitMode not ]) ifTrue: [ self error: 'instruction is only for 32 bit mode' ]. ^ self perform: groupEmitSelector withArguments: { emitter. op1. op2. op3 }! ! !AJx86InstructionDescription methodsFor: 'emitting-dispatch' stamp: 'CamilloBruni 3/30/2012 17:05'! emitUsing: emitter operands: operands |args| (self is64BitOnly and: [ emitter is64BitMode not ]) ifTrue: [ self error: 'instruction ', self name asUppercase,' is only for 64 bit mode' ]. (self is32BitOnly and: [ emitter is32BitMode not ]) ifTrue: [ self error: 'instruction ', self name asUppercase,' is only for 32 bit mode' ]. "manually create the arguments array" args := Array new: 4. args at: 1 put: emitter. args replaceFrom: 2 to: (operands size + 1 min: 4) with: operands startingAt: 1. ^ self perform: groupEmitSelector withArguments: args! ! !AJx86InstructionDescription methodsFor: 'errors'! invalidInstruction self error: 'invalid instruction'! ! !AJx86InstructionDescription methodsFor: 'initialize-release'! fromArray: arr | tmp | name := arr at: 1. group := arr at: 2. groupEmitSelector := ('emit', group,':operand1:operand2:operand3:') asSymbol. tmp := arr at: 3. tmp isSymbol ifTrue: [ tmp := self translateSymFlag: tmp ]. o1Flags := tmp. o2Flags := arr at: 4. opCodeR := arr at: 5. opCode1 := arr at: 6. opCode2 := arr at: 7.! ! !AJx86InstructionDescription methodsFor: 'initialize-release'! translateSymFlag: aflag " 64-bit mode only instruction " aflag == #x64 ifTrue: [ ^ 2r100000000 ]. " 32-bit mode only instruction " aflag == #x86 ifTrue: [ ^ 2r1000000000 ]. self error: 'unknown flag'.! ! !AJx86InstructionDescription methodsFor: 'printing'! printDWord: value | str | str := value printStringBase: 16. [str size < 8] whileTrue: [ str:= '0',str ]. ^ '16r', str! ! !AJx86InstructionDescription methodsFor: 'printing'! printOn: aStream aStream nextPutAll: '('; nextPutAll: name printString; space; nextPutAll: group printString; space. "print o1Flags" o1Flags > 0 ifTrue: [ aStream nextPutAll: '"op1" 2r' , (o1Flags printStringBase: 2) ] ifFalse: [ aStream nextPutAll: '0']. aStream space. "print o2Flags" o2Flags > 0 ifTrue: [ aStream nextPutAll: '"op2" 2r' , (o2Flags printStringBase: 2) ] ifFalse: [ aStream nextPutAll: '0']. aStream space. "print opCodeR" aStream nextPutAll: '"R" '. opCodeR printOn: aStream. aStream space. "print opCode1" opCode1 > 0 ifTrue: [ aStream nextPutAll: '"C1" '. aStream nextPutAll: (self printDWord: opCode1 ) ] ifFalse: [ aStream nextPutAll: '0']. aStream space. "print opCode2" opCode2 > 0 ifTrue: [ aStream nextPutAll: '"C2" '. aStream nextPutAll: (self printDWord: opCode2 ) ] ifFalse: [ aStream nextPutAll: '0']. aStream space; nextPut: $) ! ! !AJx86InstructionDescription methodsFor: 'testing'! is32BitOnly ^ (o1Flags bitAnd: 2r1000000000) ~= 0! ! !AJx86InstructionDescription methodsFor: 'testing'! is64BitOnly ^ (o1Flags bitAnd: 2r100000000) ~= 0! ! !AJx86InstructionDescription methodsFor: 'testing'! isJump ^ group == #cjmp or: [ group == #jmp ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJx86InstructionDescription class instanceVariableNames: 'instructions reference'! !AJx86InstructionDescription class methodsFor: 'accessing'! instructions ^ instructions ifNil: [ self initInstructions ]! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'CamilloBruni 4/17/2012 17:39'! at: instructionName ^ instructions at: instructionName ! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'CamilloBruni 4/13/2012 14:47'! initInstructions " self initInstructions " | data | instructions := IdentityDictionary new. data := OrderedCollection new. data addAll: self instructionData; addAll: self instructionsCDQ; addAll: self instructionsOther. data do: [:dt | instructions at: dt first put: (self fromArray: dt) ]. ^ instructions! ! !AJx86InstructionDescription class methodsFor: 'initialization'! initialize self initInstructions.! ! !AJx86InstructionDescription class methodsFor: 'initialization'! instructionData ^ #( (#adc #alu 0 0 "R" 2 "C1" 16r00000010 "C2" 16r00000080 ) (#add #alu 0 0 "R" 0 0 "C2" 16r00000080 ) (#addpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F58 0 ) (#addps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F58 0 ) (#addsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F58 0 ) (#addss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F58 0 ) (#addsubpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000FD0 0 ) (#addsubps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000FD0 0 ) (#amdprefetch #mem "op1" 2r1000000 0 "R" 0 "C1" 16r00000F0D 0 ) (#amdprefetchw #mem "op1" 2r1000000 0 "R" 1 "C1" 16r00000F0D 0 ) (#and #alu 0 0 "R" 4 "C1" 16r00000020 "C2" 16r00000080 ) (#andnpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F55 0 ) (#andnps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F55 0 ) (#andpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F54 0 ) (#andps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F54 0 ) (#blendpd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0D 0 ) (#blendps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0C 0 ) (#blendvpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3815 0 ) (#blendvps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3814 0 ) (#bsf #rrm 0 0 "R" 0 "C1" 16r00000FBC 0 ) (#bsr #rrm 0 0 "R" 0 "C1" 16r00000FBD 0 ) (#bswap #bswap 0 0 "R" 0 0 0 ) (#bt #bt "op1" 2r1001110 "op2" 2r10001110 "R" 4 "C1" 16r00000FA3 "C2" 16r00000FBA ) (#btc #bt "op1" 2r1001110 "op2" 2r10001110 "R" 7 "C1" 16r00000FBB "C2" 16r00000FBA ) (#btr #bt "op1" 2r1001110 "op2" 2r10001110 "R" 6 "C1" 16r00000FB3 "C2" 16r00000FBA ) (#bts #bt "op1" 2r1001110 "op2" 2r10001110 "R" 5 "C1" 16r00000FAB "C2" 16r00000FBA ) (#call #call 0 0 "R" 0 0 0 ) (#clc #emit 0 0 "R" 0 "C1" 16r000000F8 0 ) (#cld #emit 0 0 "R" 0 "C1" 16r000000FC 0 ) (#clflush #mem "op1" 2r1000000 0 "R" 7 "C1" 16r00000FAE 0 ) (#cmc #emit 0 0 "R" 0 "C1" 16r000000F5 0 ) (#cmova #rrm 0 0 "R" 0 "C1" 16r00000F47 0 ) (#cmovae #rrm 0 0 "R" 0 "C1" 16r00000F43 0 ) (#cmovb #rrm 0 0 "R" 0 "C1" 16r00000F42 0 ) (#cmovbe #rrm 0 0 "R" 0 "C1" 16r00000F46 0 ) (#cmovc #rrm 0 0 "R" 0 "C1" 16r00000F42 0 ) (#cmove #rrm 0 0 "R" 0 "C1" 16r00000F44 0 ) (#cmovg #rrm 0 0 "R" 0 "C1" 16r00000F4F 0 ) (#cmovge #rrm 0 0 "R" 0 "C1" 16r00000F4D 0 ) (#cmovl #rrm 0 0 "R" 0 "C1" 16r00000F4C 0 ) (#cmovle #rrm 0 0 "R" 0 "C1" 16r00000F4E 0 ) (#cmovna #rrm 0 0 "R" 0 "C1" 16r00000F46 0 ) (#cmovnae #rrm 0 0 "R" 0 "C1" 16r00000F42 0 ) (#cmovnb #rrm 0 0 "R" 0 "C1" 16r00000F43 0 ) (#cmovnbe #rrm 0 0 "R" 0 "C1" 16r00000F47 0 ) (#cmovnc #rrm 0 0 "R" 0 "C1" 16r00000F43 0 ) (#cmovne #rrm 0 0 "R" 0 "C1" 16r00000F45 0 ) (#cmovng #rrm 0 0 "R" 0 "C1" 16r00000F4E 0 ) (#cmovnge #rrm 0 0 "R" 0 "C1" 16r00000F4C 0 ) (#cmovnl #rrm 0 0 "R" 0 "C1" 16r00000F4D 0 ) (#cmovnle #rrm 0 0 "R" 0 "C1" 16r00000F4F 0 ) (#cmovno #rrm 0 0 "R" 0 "C1" 16r00000F41 0 ) (#cmovnp #rrm 0 0 "R" 0 "C1" 16r00000F4B 0 ) (#cmovns #rrm 0 0 "R" 0 "C1" 16r00000F49 0 ) (#cmovnz #rrm 0 0 "R" 0 "C1" 16r00000F45 0 ) (#cmovo #rrm 0 0 "R" 0 "C1" 16r00000F40 0 ) (#cmovp #rrm 0 0 "R" 0 "C1" 16r00000F4A 0 ) (#cmovpe #rrm 0 0 "R" 0 "C1" 16r00000F4A 0 ) (#cmovpo #rrm 0 0 "R" 0 "C1" 16r00000F4B 0 ) (#cmovs #rrm 0 0 "R" 0 "C1" 16r00000F48 0 ) (#cmovz #rrm 0 0 "R" 0 "C1" 16r00000F44 0 ) (#cmp #alu 0 0 "R" 7 "C1" 16r00000038 "C2" 16r00000080 ) (#cmppd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000FC2 0 ) (#cmpps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000FC2 0 ) (#cmpsd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000FC2 0 ) (#cmpss #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000FC2 0 ) (#cmpxchg #rmr 0 0 "R" 0 "C1" 16r00000FB0 0 ) (#cmpxchg16b #mem "op1" 2r1000000 0 "R" 1 "C1" 16r00000FC7 "C2" 16r00000001 ) (#cmpxchg8b #mem "op1" 2r1000000 0 "R" 1 "C1" 16r00000FC7 0 ) (#comisd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2F 0 ) (#comiss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2F 0 ) (#cpuid #emit 0 0 "R" 0 "C1" 16r00000FA2 0 ) (#crc32 #crc32 0 0 "R" 0 "C1" 16rF20F38F0 0 ) (#cvtdq2pd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000FE6 0 ) (#cvtdq2ps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5B 0 ) (#cvtpd2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000FE6 0 ) (#cvtpd2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2D 0 ) (#cvtpd2ps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5A 0 ) (#cvtpi2pd #mmurmi "op1" 2r100000 "op2" 2r1010000 "R" 0 "C1" 16r66000F2A 0 ) (#cvtpi2ps #mmurmi "op1" 2r100000 "op2" 2r1010000 "R" 0 "C1" 16r00000F2A 0 ) (#cvtps2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5B 0 ) (#cvtps2pd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5A 0 ) (#cvtps2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2D 0 ) (#cvtsd2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF2000F2D 0 ) (#cvtsd2ss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5A 0 ) (#cvtsi2sd #mmurmi "op1" 2r100000 "op2" 2r1001100 "R" 0 "C1" 16rF2000F2A 0 ) (#cvtsi2ss #mmurmi "op1" 2r100000 "op2" 2r1001100 "R" 0 "C1" 16rF3000F2A 0 ) (#cvtss2sd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5A 0 ) (#cvtss2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF3000F2D 0 ) (#cvttpd2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000FE6 0 ) (#cvttpd2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2C 0 ) (#cvttps2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5B 0 ) (#cvttps2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2C 0 ) (#cvttsd2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF2000F2C 0 ) (#cvttss2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF3000F2C 0 ) (#daa #emit #x86 0 "R" 0 "C1" 16r00000027 0 ) (#das #emit #x86 0 "R" 0 "C1" 16r0000002F 0 ) (#dec #incdec 0 0 "R" 1 "C1" 16r00000048 "C2" 16r000000FE ) (#div #rm 0 0 "R" 6 "C1" 16r000000F6 0 ) (#divpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5E 0 ) (#divps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5E 0 ) (#divsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5E 0 ) (#divss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5E 0 ) (#dppd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A41 0 ) (#dpps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A40 0 ) (#emms #emit 0 0 "R" 0 "C1" 16r00000F77 0 ) (#enter #enter 0 0 "R" 0 "C1" 16r000000C8 0 ) (#extractps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A17 0 ) (#f2xm1 #emit 0 0 "R" 0 "C1" 16r0000D9F0 0 ) (#fabs #emit 0 0 "R" 0 "C1" 16r0000D9E1 0 ) (#fadd #x87fpu 0 0 "R" 0 "C1" 16rD8DCC0C0 0 ) (#faddp #x87sti 0 0 "R" 0 "C1" 16r0000DEC0 0 ) (#fbld #mem "op1" 2r1000000 0 "R" 4 "C1" 16r000000DF 0 ) (#fbstp #mem "op1" 2r1000000 0 "R" 6 "C1" 16r000000DF 0 ) (#fchs #emit 0 0 "R" 0 "C1" 16r0000D9E0 0 ) (#fclex #emit 0 0 "R" 0 "C1" 16r9B00DBE2 0 ) (#fcmovb #x87sti 0 0 "R" 0 "C1" 16r0000DAC0 0 ) (#fcmovbe #x87sti 0 0 "R" 0 "C1" 16r0000DAD0 0 ) (#fcmove #x87sti 0 0 "R" 0 "C1" 16r0000DAC8 0 ) (#fcmovnb #x87sti 0 0 "R" 0 "C1" 16r0000DBC0 0 ) (#fcmovnbe #x87sti 0 0 "R" 0 "C1" 16r0000DBD0 0 ) (#fcmovne #x87sti 0 0 "R" 0 "C1" 16r0000DBC8 0 ) (#fcmovnu #x87sti 0 0 "R" 0 "C1" 16r0000DBD8 0 ) (#fcmovu #x87sti 0 0 "R" 0 "C1" 16r0000DAD8 0 ) (#fcom #x87fpu 0 0 "R" 2 "C1" 16rD8DCD0D0 0 ) (#fcomi #x87sti 0 0 "R" 0 "C1" 16r0000DBF0 0 ) (#fcomip #x87sti 0 0 "R" 0 "C1" 16r0000DFF0 0 ) (#fcomp #x87fpu 0 0 "R" 3 "C1" 16rD8DCD8D8 0 ) (#fcompp #emit 0 0 "R" 0 "C1" 16r0000DED9 0 ) (#fcos #emit 0 0 "R" 0 "C1" 16r0000D9FF 0 ) (#fdecstp #emit 0 0 "R" 0 "C1" 16r0000D9F6 0 ) (#fdiv #x87fpu 0 0 "R" 6 "C1" 16rD8DCF0F8 0 ) (#fdivp #x87sti 0 0 "R" 0 "C1" 16r0000DEF8 0 ) (#fdivr #x87fpu 0 0 "R" 7 "C1" 16rD8DCF8F0 0 ) (#fdivrp #x87sti 0 0 "R" 0 "C1" 16r0000DEF0 0 ) (#ffree #x87sti 0 0 "R" 0 "C1" 16r0000DDC0 0 ) (#fiadd #x87mem "op1" 2r110 0 "R" 0 "C1" 16rDEDA0000 0 ) (#ficom #x87mem "op1" 2r110 0 "R" 2 "C1" 16rDEDA0000 0 ) (#ficomp #x87mem "op1" 2r110 0 "R" 3 "C1" 16rDEDA0000 0 ) (#fidiv #x87mem "op1" 2r110 0 "R" 6 "C1" 16rDEDA0000 0 ) (#fidivr #x87mem "op1" 2r110 0 "R" 7 "C1" 16rDEDA0000 0 ) (#fild #x87mem "op1" 2r1110 0 "R" 0 "C1" 16rDFDBDF05 0 ) (#fimul #x87mem "op1" 2r110 0 "R" 1 "C1" 16rDEDA0000 0 ) (#fincstp #emit 0 0 "R" 0 "C1" 16r0000D9F7 0 ) (#finit #emit 0 0 "R" 0 "C1" 16r9B00DBE3 0 ) (#fist #x87mem "op1" 2r110 0 "R" 2 "C1" 16rDFDB0000 0 ) (#fistp #x87mem "op1" 2r1110 0 "R" 3 "C1" 16rDFDBDF07 0 ) (#fisttp #x87mem "op1" 2r1110 0 "R" 1 "C1" 16rDFDBDD01 0 ) (#fisub #x87mem "op1" 2r110 0 "R" 4 "C1" 16rDEDA0000 0 ) (#fisubr #x87mem "op1" 2r110 0 "R" 5 "C1" 16rDEDA0000 0 ) (#fld #x87memSti "op1" 2r11100 0 "R" 0 "C1" 16r00D9DD00 "C2" 16rD9C0DB05 ) (#fld1 #emit 0 0 "R" 0 "C1" 16r0000D9E8 0 ) (#fldcw #mem "op1" 2r1000000 0 "R" 5 "C1" 16r000000D9 0 ) (#fldenv #mem "op1" 2r1000000 0 "R" 4 "C1" 16r000000D9 0 ) (#fldl2e #emit 0 0 "R" 0 "C1" 16r0000D9EA 0 ) (#fldl2t #emit 0 0 "R" 0 "C1" 16r0000D9E9 0 ) (#fldlg2 #emit 0 0 "R" 0 "C1" 16r0000D9EC 0 ) (#fldln2 #emit 0 0 "R" 0 "C1" 16r0000D9ED 0 ) (#fldpi #emit 0 0 "R" 0 "C1" 16r0000D9EB 0 ) (#fldz #emit 0 0 "R" 0 "C1" 16r0000D9EE 0 ) (#fmul #x87fpu 0 0 "R" 1 "C1" 16rD8DCC8C8 0 ) (#fmulp #x87sti 0 0 "R" 0 "C1" 16r0000DEC8 0 ) (#fnclex #emit 0 0 "R" 0 "C1" 16r0000DBE2 0 ) (#fninit #emit 0 0 "R" 0 "C1" 16r0000DBE3 0 ) (#fnop #emit 0 0 "R" 0 "C1" 16r0000D9D0 0 ) (#fnsave #mem "op1" 2r1000000 0 "R" 6 "C1" 16r000000DD 0 ) (#fnstcw #mem "op1" 2r1000000 0 "R" 7 "C1" 16r000000D9 0 ) (#fnstenv #mem "op1" 2r1000000 0 "R" 6 "C1" 16r000000D9 0 ) (#fnstsw #x87fstsw "op1" 2r1000000 0 "R" 7 "C1" 16r000000DD "C2" 16r0000DFE0 ) (#fpatan #emit 0 0 "R" 0 "C1" 16r0000D9F3 0 ) (#fprem #emit 0 0 "R" 0 "C1" 16r0000D9F8 0 ) (#fprem1 #emit 0 0 "R" 0 "C1" 16r0000D9F5 0 ) (#fptan #emit 0 0 "R" 0 "C1" 16r0000D9F2 0 ) (#frndint #emit 0 0 "R" 0 "C1" 16r0000D9FC 0 ) (#frstor #mem "op1" 2r1000000 0 "R" 4 "C1" 16r000000DD 0 ) (#fsave #mem "op1" 2r1000000 0 "R" 6 "C1" 16r9B0000DD 0 ) (#fscale #emit 0 0 "R" 0 "C1" 16r0000D9FD 0 ) (#fsin #emit 0 0 "R" 0 "C1" 16r0000D9FE 0 ) (#fsincos #emit 0 0 "R" 0 "C1" 16r0000D9FB 0 ) (#fsqrt #emit 0 0 "R" 0 "C1" 16r0000D9FA 0 ) (#fst #x87memSti "op1" 2r1100 0 "R" 2 "C1" 16r00D9DD02 "C2" 16rDDD00000 ) (#fstcw #mem "op1" 2r1000000 0 "R" 7 "C1" 16r9B0000D9 0 ) (#fstenv #mem "op1" 2r1000000 0 "R" 6 "C1" 16r9B0000D9 0 ) (#fstp #x87memSti "op1" 2r11100 0 "R" 3 "C1" 16r00D9DD03 "C2" 16rDDD8DB07 ) (#fstsw #x87fstsw "op1" 2r1000000 0 "R" 7 "C1" 16r9B0000DD "C2" 16r9B00DFE0 ) (#fsub #x87fpu 0 0 "R" 4 "C1" 16rD8DCE0E8 0 ) (#fsubp #x87sti 0 0 "R" 0 "C1" 16r0000DEE8 0 ) (#fsubr #x87fpu 0 0 "R" 5 "C1" 16rD8DCE8E0 0 ) (#fsubrp #x87sti 0 0 "R" 0 "C1" 16r0000DEE0 0 ) (#ftst #emit 0 0 "R" 0 "C1" 16r0000D9E4 0 ) (#fucom #x87sti 0 0 "R" 0 "C1" 16r0000DDE0 0 ) (#fucomi #x87sti 0 0 "R" 0 "C1" 16r0000DBE8 0 ) (#fucomip #x87sti 0 0 "R" 0 "C1" 16r0000DFE8 0 ) (#fucomp #x87sti 0 0 "R" 0 "C1" 16r0000DDE8 0 ) (#fucompp #emit 0 0 "R" 0 "C1" 16r0000DAE9 0 ) (#fwait #emit 0 0 "R" 0 "C1" 16r0000009B 0 ) (#fxam #emit 0 0 "R" 0 "C1" 16r0000D9E5 0 ) (#fxch #x87sti 0 0 "R" 0 "C1" 16r0000D9C8 0 ) (#fxrstor #mem 0 0 "R" 1 "C1" 16r00000FAE 0 ) (#fxsave #mem 0 0 "R" 0 "C1" 16r00000FAE 0 ) (#fxtract #emit 0 0 "R" 0 "C1" 16r0000D9F4 0 ) (#fyl2x #emit 0 0 "R" 0 "C1" 16r0000D9F1 0 ) (#fyl2xp1 #emit 0 0 "R" 0 "C1" 16r0000D9F9 0 ) (#haddpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F7C 0 ) (#haddps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F7C 0 ) (#hsubpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F7D 0 ) (#hsubps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F7D 0 ) (#idiv #rm 0 0 "R" 7 "C1" 16r000000F6 0 ) (#imul #imul 0 0 "R" 0 0 0 ) (#inc #incdec 0 0 "R" 0 "C1" 16r00000040 "C2" 16r000000FE ) (#int3 #emit 0 0 "R" 0 "C1" 16r000000CC 0 ) (#ja #cjmp 0 0 "R" 0 "C1" 16r00000007 0 ) (#jae #cjmp 0 0 "R" 0 "C1" 16r00000003 0 ) (#jb #cjmp 0 0 "R" 0 "C1" 16r00000002 0 ) (#jbe #cjmp 0 0 "R" 0 "C1" 16r00000006 0 ) (#jc #cjmp 0 0 "R" 0 "C1" 16r00000002 0 ) (#je #cjmp 0 0 "R" 0 "C1" 16r00000004 0 ) (#jg #cjmp 0 0 "R" 0 "C1" 16r0000000F 0 ) (#jge #cjmp 0 0 "R" 0 "C1" 16r0000000D 0 ) (#jl #cjmp 0 0 "R" 0 "C1" 16r0000000C 0 ) (#jle #cjmp 0 0 "R" 0 "C1" 16r0000000E 0 ) (#jmp #jmp 0 0 "R" 0 0 0 ) (#jna #cjmp 0 0 "R" 0 "C1" 16r00000006 0 ) (#jnae #cjmp 0 0 "R" 0 "C1" 16r00000002 0 ) (#jnb #cjmp 0 0 "R" 0 "C1" 16r00000003 0 ) (#jnbe #cjmp 0 0 "R" 0 "C1" 16r00000007 0 ) (#jnc #cjmp 0 0 "R" 0 "C1" 16r00000003 0 ) (#jne #cjmp 0 0 "R" 0 "C1" 16r00000005 0 ) (#jng #cjmp 0 0 "R" 0 "C1" 16r0000000E 0 ) (#jnge #cjmp 0 0 "R" 0 "C1" 16r0000000C 0 ) (#jnl #cjmp 0 0 "R" 0 "C1" 16r0000000D 0 ) (#jnle #cjmp 0 0 "R" 0 "C1" 16r0000000F 0 ) (#jno #cjmp 0 0 "R" 0 "C1" 16r00000001 0 ) (#jnp #cjmp 0 0 "R" 0 "C1" 16r0000000B 0 ) (#jns #cjmp 0 0 "R" 0 "C1" 16r00000009 0 ) (#jnz #cjmp 0 0 "R" 0 "C1" 16r00000005 0 ) (#jo #cjmp 0 0 "R" 0 0 0 ) (#jp #cjmp 0 0 "R" 0 "C1" 16r0000000A 0 ) (#jpe #cjmp 0 0 "R" 0 "C1" 16r0000000A 0 ) (#jpo #cjmp 0 0 "R" 0 "C1" 16r0000000B 0 ) (#js #cjmp 0 0 "R" 0 "C1" 16r00000008 0 ) (#jz #cjmp 0 0 "R" 0 "C1" 16r00000004 0 ) (#lddqu #mmurmi "op1" 2r100000 "op2" 2r1000000 "R" 0 "C1" 16rF2000FF0 0 ) (#ldmxcsr #mem "op1" 2r1000000 0 "R" 2 "C1" 16r00000FAE 0 ) (#lea #lea 0 0 "R" 0 0 0 ) (#leave #emit 0 0 "R" 0 "C1" 16r000000C9 0 ) (#lfence #emit 0 0 "R" 0 "C1" 16r000FAEE8 0 ) (#lock #emit 0 0 "R" 0 "C1" 16r000000F0 0 ) (#maskmovdqu #mmurmi "op1" 2r100000 "op2" 2r100000 "R" 0 "C1" 16r66000F57 0 ) (#maskmovq #mmurmi "op1" 2r10000 "op2" 2r10000 "R" 0 "C1" 16r00000FF7 0 ) (#maxpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5F 0 ) (#maxps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5F 0 ) (#maxsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5F 0 ) (#maxss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5F 0 ) (#mfence #emit 0 0 "R" 0 "C1" 16r000FAEF0 0 ) (#minpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5D 0 ) (#minps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5D 0 ) (#minsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5D 0 ) (#minss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5D 0 ) (#monitor #emit 0 0 "R" 0 "C1" 16r000F01C8 0 ) (#mov #mov 0 0 "R" 0 0 0 ) (#movPtr #movPtr 0 0 "R" 0 0 0 ) (#movapd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F28 "C2" 16r66000F29 ) (#movaps #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F28 "C2" 16r00000F29 ) (#movbe #movbe "op1" 2r1001110 "op2" 2r1001110 "R" 0 "C1" 16r000F38F0 "C2" 16r000F38F1 ) (#movd #mmuMovD 0 0 "R" 0 0 0 ) (#movddup #mmuMov "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F12 0 ) (#movdq2q #mmuMov "op1" 2r10000 "op2" 2r100000 "R" 0 "C1" 16rF2000FD6 0 ) (#movdqa #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F6F "C2" 16r66000F7F ) (#movdqu #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F6F "C2" 16rF3000F7F ) (#movhlps #mmuMov "op1" 2r100000 "op2" 2r100000 "R" 0 "C1" 16r00000F12 0 ) (#movhpd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F16 "C2" 16r66000F17 ) (#movhps #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F16 "C2" 16r00000F17 ) (#movlhps #mmuMov "op1" 2r100000 "op2" 2r100000 "R" 0 "C1" 16r00000F16 0 ) (#movlpd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F12 "C2" 16r66000F13 ) (#movlps #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F12 "C2" 16r00000F13 ) (#movmskpd #mmuMov "op1" 2r1101 "op2" 2r100000 "R" 0 "C1" 16r66000F50 0 ) (#movmskps #mmuMov "op1" 2r1101 "op2" 2r100000 "R" 0 "C1" 16r00000F50 0 ) (#movntdq #mmuMov "op1" 2r1000000 "op2" 2r100000 "R" 0 0 "C2" 16r66000FE7 ) (#movntdqa #mmuMov "op1" 2r100000 "op2" 2r1000000 "R" 0 "C1" 16r660F382A 0 ) (#movnti #mmuMov "op1" 2r1000000 "op2" 2r1100 "R" 0 0 "C2" 16r00000FC3 ) (#movntpd #mmuMov "op1" 2r1000000 "op2" 2r100000 "R" 0 0 "C2" 16r66000F2B ) (#movntps #mmuMov "op1" 2r1000000 "op2" 2r100000 "R" 0 0 "C2" 16r00000F2B ) (#movntq #mmuMov "op1" 2r1000000 "op2" 2r10000 "R" 0 0 "C2" 16r00000FE7 ) (#movq #mmuMovQ 0 0 "R" 0 0 0 ) (#movq2dq #mmurmi "op1" 2r100000 "op2" 2r10000 "R" 0 "C1" 16rF3000FD6 0 ) (#movsd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F10 "C2" 16rF2000F11 ) (#movshdup #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F16 0 ) (#movsldup #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F12 0 ) (#movss #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F10 "C2" 16rF3000F11 ) (#movsx #movSxZx 0 0 "R" 0 "C1" 16r00000FBE 0 ) (#movsxd #movsxd 0 0 "R" 0 0 0 ) (#movupd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F10 "C2" 16r66000F11 ) (#movups #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F10 "C2" 16r00000F11 ) (#movzx #movSxZx 0 0 "R" 0 "C1" 16r00000FB6 0 ) (#mpsadbw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A42 0 ) (#mul #rm 0 0 "R" 4 "C1" 16r000000F6 0 ) (#mulpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F59 0 ) (#mulps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F59 0 ) (#mulsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F59 0 ) (#mulss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F59 0 ) (#mwait #emit 0 0 "R" 0 "C1" 16r000F01C9 0 ) (#neg #rm 0 0 "R" 3 "C1" 16r000000F6 0 ) (#nop #emit 0 0 "R" 0 "C1" 16r00000090 0 ) (#not #rm 0 0 "R" 2 "C1" 16r000000F6 0 ) (#or #alu 0 0 "R" 1 "C1" 16r00000008 "C2" 16r00000080 ) (#orpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F56 0 ) (#orps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F56 0 ) (#pabsb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F381C 0 ) (#pabsd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F381E 0 ) (#pabsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F381D 0 ) (#packssdw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F6B 0 ) (#packsswb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F63 0 ) (#packusdw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F382B 0 ) (#packuswb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F67 0 ) (#paddb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFC 0 ) (#paddd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFE 0 ) (#paddq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD4 0 ) (#paddsb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEC 0 ) (#paddsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FED 0 ) (#paddusb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDC 0 ) (#paddusw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDD 0 ) (#paddw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFD 0 ) (#palignr #mmuRmImm8 "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3A0F 0 ) (#pand #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDB 0 ) (#pandn #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDF 0 ) (#pause #emit 0 0 "R" 0 "C1" 16rF3000090 0 ) (#pavgb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE0 0 ) (#pavgw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE3 0 ) (#pblendvb #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3810 0 ) (#pblendw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0E 0 ) (#pcmpeqb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F74 0 ) (#pcmpeqd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F76 0 ) (#pcmpeqq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3829 0 ) (#pcmpeqw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F75 0 ) (#pcmpestri #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A61 0 ) (#pcmpestrm #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A60 0 ) (#pcmpgtb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F64 0 ) (#pcmpgtd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F66 0 ) (#pcmpgtq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3837 0 ) (#pcmpgtw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F65 0 ) (#pcmpistri #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A63 0 ) (#pcmpistrm #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A62 0 ) (#pextrb #mmuPextr "op1" 2r1000101 "op2" 2r100000 "R" 0 "C1" 16r000F3A14 0 ) (#pextrd #mmuPextr "op1" 2r1000100 "op2" 2r100000 "R" 0 "C1" 16r000F3A16 0 ) (#pextrq #mmuPextr "op1" 2r1001100 "op2" 2r100000 "R" 1 "C1" 16r000F3A16 0 ) (#pextrw #mmuPextr "op1" 2r1000100 "op2" 2r110000 "R" 0 "C1" 16r000F3A16 0 ) (#pf2id #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000001D ) (#pf2iw #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000001C ) (#pfacc #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000AE ) (#pfadd #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000009E ) (#pfcmpeq #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000B0 ) (#pfcmpge #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000090 ) (#pfcmpgt #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A0 ) (#pfmax #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A4 ) (#pfmin #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000094 ) (#pfmul #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000B4 ) (#pfnacc #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000008A ) (#pfpnacc #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000008E ) (#pfrcp #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000096 ) (#pfrcpit1 #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A6 ) (#pfrcpit2 #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000B6 ) (#pfrsqit1 #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A7 ) (#pfrsqrt #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000097 ) (#pfsub #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000009A ) (#pfsubr #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000AA ) (#phaddd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3802 0 ) (#phaddsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3803 0 ) (#phaddw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3801 0 ) (#phminposuw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3841 0 ) (#phsubd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3806 0 ) (#phsubsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3807 0 ) (#phsubw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3805 0 ) (#pi2fd #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000000D ) (#pi2fw #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000000C ) (#pinsrb #mmuRmImm8 "op1" 2r100000 "op2" 2r1000100 "R" 0 "C1" 16r660F3A20 0 ) (#pinsrd #mmuRmImm8 "op1" 2r100000 "op2" 2r1000100 "R" 0 "C1" 16r660F3A22 0 ) (#pinsrq #mmuRmImm8 "op1" 2r100000 "op2" 2r1001000 "R" 0 "C1" 16r660F3A22 0 ) (#pinsrw #mmuRmImm8 "op1" 2r110000 "op2" 2r1000100 "R" 0 "C1" 16r00000FC4 0 ) (#pmaddubsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3804 0 ) (#pmaddwd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF5 0 ) (#pmaxsb #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383C 0 ) (#pmaxsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383D 0 ) (#pmaxsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEE 0 ) (#pmaxub #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDE 0 ) (#pmaxud #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383F 0 ) (#pmaxuw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383E 0 ) (#pminsb #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3838 0 ) (#pminsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3839 0 ) (#pminsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEA 0 ) (#pminub #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDA 0 ) (#pminud #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383B 0 ) (#pminuw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383A 0 ) (#pmovmskb #mmurmi "op1" 2r1100 "op2" 2r110000 "R" 0 "C1" 16r00000FD7 0 ) (#pmovsxbd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3821 0 ) (#pmovsxbq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3822 0 ) (#pmovsxbw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3820 0 ) (#pmovsxdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3825 0 ) (#pmovsxwd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3823 0 ) (#pmovsxwq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3824 0 ) (#pmovzxbd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3831 0 ) (#pmovzxbq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3832 0 ) (#pmovzxbw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3830 0 ) (#pmovzxdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3835 0 ) (#pmovzxwd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3833 0 ) (#pmovzxwq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3834 0 ) (#pmuldq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3828 0 ) (#pmulhrsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F380B 0 ) (#pmulhuw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE4 0 ) (#pmulhw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE5 0 ) (#pmulld #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3840 0 ) (#pmullw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD5 0 ) (#pmuludq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF4 0 ) (#pop #pop 0 0 "R" 0 "C1" 16r00000058 "C2" 16r0000008F ) (#popad #emit #x86 0 "R" 0 "C1" 16r00000061 0 ) (#popcnt #rrm 0 0 "R" 0 "C1" 16rF3000FB8 0 ) (#popfd #emit 0 0 "R" 0 "C1" 16r0000009D 0 ) (#popfq #emit 0 0 "R" 0 "C1" 16r4800009D 0 ) (#por #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEB 0 ) (#prefetch #mmuPrefetch "op1" 2r1000000 "op2" 2r10000000 "R" 0 0 0 ) (#psadbw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF6 0 ) (#pshufb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3800 0 ) (#pshufd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F70 0 ) (#pshufhw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F70 0 ) (#pshuflw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F70 0 ) (#pshufw #mmuRmImm8 "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F70 0 ) (#psignb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3808 0 ) (#psignd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F380A 0 ) (#psignw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3809 0 ) (#pslld #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 6 "C1" 16r00000FF2 "C2" 16r00000F72 ) (#pslldq #mmurmi "op1" 2r100000 "op2" 2r10000000 "R" 7 0 "C2" 16r66000F73 ) (#psllq #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 6 "C1" 16r00000FF3 "C2" 16r00000F73 ) (#psllw #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 6 "C1" 16r00000FF1 "C2" 16r00000F71 ) (#psrad #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 4 "C1" 16r00000FE2 "C2" 16r00000F72 ) (#psraw #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 4 "C1" 16r00000FE1 "C2" 16r00000F71 ) (#psrld #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 2 "C1" 16r00000FD2 "C2" 16r00000F72 ) (#psrldq #mmurmi "op1" 2r100000 "op2" 2r10000000 "R" 3 0 "C2" 16r66000F73 ) (#psrlq #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 2 "C1" 16r00000FD3 "C2" 16r00000F73 ) (#psrlw #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 2 "C1" 16r00000FD1 "C2" 16r00000F71 ) (#psubb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF8 0 ) (#psubd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFA 0 ) (#psubq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFB 0 ) (#psubsb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE8 0 ) (#psubsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE9 0 ) (#psubusb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD8 0 ) (#psubusw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD9 0 ) (#psubw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF9 0 ) (#pswapd #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000BB ) (#ptest #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3817 0 ) (#punpckhbw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F68 0 ) (#punpckhdq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F6A 0 ) (#punpckhqdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F6D 0 ) (#punpckhwd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F69 0 ) (#punpcklbw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F60 0 ) (#punpckldq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F62 0 ) (#punpcklqdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F6C 0 ) (#punpcklwd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F61 0 ) (#push #push 0 0 "R" 6 "C1" 16r00000050 "C2" 16r000000FF ) (#pushad #emit #x86 0 "R" 0 "C1" 16r00000060 0 ) (#pushf #emit 0 0 "R" 0 "C1" 16r6600009C 0 ) (#pushfd #emit #x86 0 "R" 0 "C1" 16r0000009C 0 ) (#pushfq #emit #x64 0 "R" 0 "C1" 16r0000009C 0 ) (#pxor #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEF 0 ) (#rcl #rot 0 0 "R" 2 0 0 ) (#rcpps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F53 0 ) (#rcpss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F53 0 ) (#rcr #rot 0 0 "R" 3 0 0 ) (#rdtsc #emit 0 0 "R" 0 "C1" 16r00000F31 0 ) (#rdtscp #emit 0 0 "R" 0 "C1" 16r000F01F9 0 ) (#ret #ret 0 0 "R" 0 0 0 ) (#rol #rot 0 0 "R" 0 0 0 ) (#ror #rot 0 0 "R" 1 0 0 ) (#roundpd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A09 0 ) (#roundps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A08 0 ) (#roundsd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0B 0 ) (#roundss #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0A 0 ) (#rsqrtps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F52 0 ) (#rsqrtss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F52 0 ) (#sahf #emit 0 0 "R" 0 "C1" 16r0000009E 0 ) (#sal #rot 0 0 "R" 4 0 0 ) (#sar #rot 0 0 "R" 7 0 0 ) (#sbb #alu 0 0 "R" 3 "C1" 16r00000018 "C2" 16r00000080 ) (#sfence #emit 0 0 "R" 0 "C1" 16r000FAEF8 0 ) (#shl #rot 0 0 "R" 4 0 0 ) (#shld #shldShrd 0 0 "R" 0 "C1" 16r00000FA4 0 ) (#shr #rot 0 0 "R" 5 0 0 ) (#shrd #shldShrd 0 0 "R" 0 "C1" 16r00000FAC 0 ) (#shufps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000FC6 0 ) (#sqrtpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F51 0 ) (#sqrtps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F51 0 ) (#sqrtsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F51 0 ) (#sqrtss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F51 0 ) (#stc #emit 0 0 "R" 0 "C1" 16r000000F9 0 ) (#std #emit 0 0 "R" 0 "C1" 16r000000FD 0 ) (#stmxcsr #mem "op1" 2r1000000 0 "R" 3 "C1" 16r00000FAE 0 ) (#sub #alu 0 0 "R" 5 "C1" 16r00000028 "C2" 16r00000080 ) (#subpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5C 0 ) (#subps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5C 0 ) (#subsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5C 0 ) (#subss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5C 0 ) (#test #test 0 0 "R" 0 0 0 ) (#ucomisd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2E 0 ) (#ucomiss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2E 0 ) (#ud2 #emit 0 0 "R" 0 "C1" 16r00000F0B 0 ) (#unpckhpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F15 0 ) (#unpckhps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F15 0 ) (#unpcklpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F14 0 ) (#unpcklps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F14 0 ) (#xadd #rmr 0 0 "R" 0 "C1" 16r00000FC0 0 ) (#xchg #xchg 0 0 "R" 0 0 0 ) (#xor #alu 0 0 "R" 6 "C1" 16r00000030 "C2" 16r00000080 ) (#xorpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F57 0 ) (#xorps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F57 0 ) ) ! ! !AJx86InstructionDescription class methodsFor: 'initialization'! instructionsCDQ "CBW/CWDE/CDQE Convert Byte to Word/Convert Word to Doubleword/Convert Doubleword to Quadword" ^#( (#cbw #emit 0 0 "R" 0 "C1" 16r66000098 0 ) (#cwde #emit 0 0 "R" 0 "C1" 16r00000098 0 ) (#cdqe #emit #x64 0 "R" 0 "C1" 16r48000098 0 ) "CWD/CDQ/CQO Convert Word to Doubleword/Convert Doubleword to Quadword" (#cwd #emit 0 0 "R" 0 "C1" 16r66000099 0 ) (#cdq #emit 0 0 "R" 0 "C1" 16r00000099 0 ) (#cqo #emit #x64 0 "R" 0 "C1" 16r48000099 0 ) )! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'IgorStasenko 9/18/2012 17:23'! instructionsOther ^ #( (#femms #emit 0 0 "R" 0 "C1" 16r00000F0E 0 ) " looks like invalid one " (#movsb #emit 0 0 "R" 0 "C1" 16r000000A4 0 ) (#movsd #emit 0 0 "R" 0 "C1" 16r000000A5 0 ) "in 64bit mode - moves 64bits" (#rep #emit 0 0 "R" 0 "C1" 16r000000F3 0 ) "repeat prefix" (#repe #emit 0 0 "R" 0 "C1" 16r000000F3 0 ) "repeat prefix" (#repz #emit 0 0 "R" 0 "C1" 16r000000F3 0 ) "repeat prefix" (#repne #emit 0 0 "R" 0 "C1" 16r000000F2 0 ) "repeat prefix" (#repnz #emit 0 0 "R" 0 "C1" 16r000000F2 0 ) "repeat prefix" (#cmpsb #emit 0 0 "R" 0 "C1" 16r000000A6 0 ) "(#cmpsw #emit 0 0 0 16r000000A7 0 ) " (#cmpsd #emit 0 0 "R" 0 "C1" 16r000000A7 0 ) )! ! !AJx86InstructionDescription class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/13/2012 14:30'! fromArray: aSpecArray ^ self basicNew fromArray: aSpecArray! ! !AJx86InstructionDescription class methodsFor: 'printing'! printInstructions " AJInstructionDescription printInstructions. AJInstructionDescription printInstructions openInWorkspaceWithTitle: 'x86 instructions' " ^ String streamContents: [:str | self printInstructionsOn: str ] ! ! !AJx86InstructionDescription class methodsFor: 'printing'! printInstructionsOn: aStream " AJInstructionDescription printInstructionsOn: (FileStream newFileNamed: 'asm.st'). " aStream nextPutAll: '#(' ; cr. self instructions keys asSortedCollection do: [:aname | | instr | instr := instructions at: aname. instr printOn: aStream. aStream cr. ]. aStream cr; nextPut: $); cr ! ! !AJx86InstructionDescription class methodsFor: 'testing'! checkInstructionsIntegrity " self checkInstructionsIntegrity" | data | data := self instructionData. data do: [:dt | | instr | instr := instructions at: dt first. self assert: [ (instr name = (dt at: 1)) & (instr group = (dt at: 2)) & (instr o1Flags = (dt at:3)) & (instr o2Flags = (dt at:4)) & (instr opCodeR = (dt at:5)) & (instr opCode1 = (dt at:6)) & (instr opCode2 = (dt at:7)) ]. ]. ! ! AJJumpInstruction subclass: #AJx86JumpInstruction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx86JumpInstruction methodsFor: 'accessing'! codeSize machineCode ifNil: [ ^ 2 ]. ^ machineCode size! ! !AJx86JumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86JumpInstruction methodsFor: 'accessing'! machineCodeSize machineCode ifNil: [ ^ 2 ]. ^ machineCode size! ! !AJx86JumpInstruction methodsFor: 'convenience' stamp: 'CamilloBruni 8/22/2012 18:07'! errorUndefinedLabel: aLabel ^ self error: 'undefined label: ', aLabel name! ! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 8/22/2012 14:34'! emitCode: asm "generate opcodes" | delta code nextInstruction target desc | target := label position. target ifNil: [ ^ machineCode := nil ]. nextInstruction := position + 2. delta := (target - nextInstruction) asImm. desc := self instructionDesciptions at: name. "can we use 8bit offset?" machineCode := delta isInt8 ifTrue: [ self emitShortJump: desc offset: delta ] ifFalse: [ self emitLongJump: desc target: target ]! ! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 8/22/2012 18:07'! emitCodeAtOffset: offset assembler: asm position := offset. [ | labelPos | labelPos := label position. labelPos ifNotNil: [ self emitCode: asm ]. next ifNotNil: [ next emitCodeAtOffset: offset + self machineCodeSize assembler: asm ]. label position ~= labelPos ] whileTrue. label position ifNil: [ self errorUndefinedLabel: label ]! ! !AJx86JumpInstruction methodsFor: 'emitting code'! emitConditionalJump: addr to: desc ^ {16r0F. (16r80 + desc opCode1). (addr bitAnd: 255). (addr >> 8 bitAnd: 255). (addr >> 16 bitAnd: 255). (addr >> 24 bitAnd: 255)} asByteArray! ! !AJx86JumpInstruction methodsFor: 'emitting code'! emitLongJump: desc target: target | addr sz nextInstruction | sz := self isConditional ifTrue: [ 2 ] ifFalse: [ 1 ]. nextInstruction := position + 4 + sz. addr := (AJImmediate ivalue: target - nextInstruction) asDWord. ^ self isConditional ifFalse: [ self emitUnconditionalJumpTo: addr ] ifTrue: [ self emitConditionalJump: addr to: desc ]! ! !AJx86JumpInstruction methodsFor: 'emitting code'! emitShortJump: desc offset: delta "short jump" ^ self isConditional ifTrue: [ {(16r70 + desc opCode1). (delta asByte)} asByteArray ] ifFalse: [ {16rEB. (delta asByte)} asByteArray ]! ! !AJx86JumpInstruction methodsFor: 'emitting code'! emitUnconditionalJumpTo: addr ^ { 16rE9. (addr bitAnd: 255). (addr >> 8 bitAnd: 255). (addr >> 16 bitAnd: 255). (addr >> 24 bitAnd: 255)} asByteArray! ! !AJx86JumpInstruction methodsFor: 'testing'! isConditional ^ name ~~ #jmp! ! SharedPool subclass: #AJx86Registers instanceVariableNames: '' classVariableNames: 'AH AL AX BH BL BP BX CH CL CX Codes DH DI DL DX EAX EBP EBX ECX EDI EDX EIP ESI ESP IP MM0 MM1 MM2 MM3 MM4 MM5 MM6 MM7 R10 R10B R10D R10W R11 R11B R11D R11W R12 R12B R12D R12W R13 R13B R13D R13W R14 R14B R14D R14W R15 R15B R15D R15W R8 R8B R8D R8W R9 R9B R9D R9W RAX RBP RBX RCX RDI RDX RIP RSI RSP SI SP ST0 ST1 ST2 ST3 ST4 ST5 ST6 ST7 XMM0 XMM1 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9' poolDictionaries: '' category: 'AsmJit-x86'! !AJx86Registers commentStamp: '' prior: 0! I am a SHaredPool which initializes all the registers needed by the Assmbler.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJx86Registers class instanceVariableNames: ''! !AJx86Registers class methodsFor: 'accessing'! all ^ Codes values collect: [ :each| self classPool at: each ]! ! !AJx86Registers class methodsFor: 'accessing'! all16 ^ self all select: [:reg| reg is16 ]! ! !AJx86Registers class methodsFor: 'accessing'! all32 ^ self all select: [:reg| reg is32 ]! ! !AJx86Registers class methodsFor: 'accessing'! all64 ^ self all select: [:reg| reg is64 ]! ! !AJx86Registers class methodsFor: 'accessing'! all8 ^ self all select: [:reg| reg is8 ]! ! !AJx86Registers class methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 10:54'! at: aRegisterIdentifierSymbol ^ self classPool at: aRegisterIdentifierSymbol! ! !AJx86Registers class methodsFor: 'accessing'! code: registerCode "Access a register by its code. Example: RBP == (self code: RBP code)" ^ self classPool at: (Codes at: registerCode)! ! !AJx86Registers class methodsFor: 'accessing'! doesNotUnderstand: aMessage self classPool at: aMessage selector ifPresent: [:val| ^ val ]. ^ super doesNotUnderstand: aMessage! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose ^ self all select: [ :reg| reg isGeneralPurpose ]! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose16 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is16 ])! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose32 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is32 ])! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose64 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is64 ])! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose8 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is8 ])! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AH "A 8bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #AH! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! AL "A 8bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #AL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AX "A 16bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #AX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BH "A 8bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #BH! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BL "A 8bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #BL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BP "A 16bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #BP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BX "A 16bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #BX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CH "A 8bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #CH! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CL "A 8bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #CL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CX "A 16bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #CX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DH "A 8bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #DH! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DI "A 16bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #DI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DL "A 8bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #DL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DX "A 16bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #DX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EAX "A 32bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #EAX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBP "A 32bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #EBP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBX "A 32bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #EBX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ECX "A 32bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #ECX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDI "A 32bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #EDI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDX "A 32bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #EDX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EIP "A 32bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #EIP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ESI "A 32bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #ESI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ESP "A 32bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #ESP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! IP "A 16bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #IP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM0 "An MMX register" ^ self at: #MM0! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM1 "An MMX register" ^ self at: #MM1! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM2 "An MMX register" ^ self at: #MM2! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM3 "An MMX register" ^ self at: #MM3! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM4 "An MMX register" ^ self at: #MM4! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM5 "An MMX register" ^ self at: #MM5! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM6 "An MMX register" ^ self at: #MM6! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM7 "An MMX register" ^ self at: #MM7! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10 "A 64bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10B "A 8bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10D "A 32bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10W "A 16bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11 "A 64bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11B "A 8bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11D "A 32bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11W "A 16bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12 "A 64bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12B "A 8bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12D "A 32bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12W "A 16bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13 "A 64bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R13B "A 8bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13D "A 32bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13W "A 16bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14 "A 64bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14B "A 8bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14D "A 32bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14W "A 16bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15 "A 64bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15B "A 8bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15D "A 32bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15W "A 16bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8 "A 64bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8B "A 8bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8D "A 32bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8W "A 16bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9 "A 64bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R9B "A 8bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9D "A 32bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9W "A 16bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RAX "A 64bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #RAX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RBP "A 64bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #RBP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RBX "A 64bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #RBX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RCX "A 64bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #RCX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RDI "A 64bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #RDI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RDX "A 64bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #RDX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RIP "A 64bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #RIP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RSI "A 64bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #RSI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RSP "A 64bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #RSP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! SI "A 16bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #SI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! SP "A 16bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #SP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST0 "A floating point register" ^ self at: #ST0! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST1 "A floating point register" ^ self at: #ST1! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST2 "A floating point register" ^ self at: #ST2! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST3 "A floating point register" ^ self at: #ST3! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST4 "A floating point register" ^ self at: #ST4! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST5 "A floating point register" ^ self at: #ST5! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST6 "A floating point register" ^ self at: #ST6! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST7 "A floating point register" ^ self at: #ST7! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM0 "An SSE register" ^ self at: #XMM0! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM1 "An SSE register" ^ self at: #XMM1! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM10 "An SSE register" ^ self at: #XMM10! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM11 "An SSE register" ^ self at: #XMM11! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM12 "An SSE register" ^ self at: #XMM12! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM13 "An SSE register" ^ self at: #XMM13! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM14 "An SSE register" ^ self at: #XMM14! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM15 "An SSE register" ^ self at: #XMM15! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM2 "An SSE register" ^ self at: #XMM2! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM3 "An SSE register" ^ self at: #XMM3! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM4 "An SSE register" ^ self at: #XMM4! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM5 "An SSE register" ^ self at: #XMM5! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM6 "An SSE register" ^ self at: #XMM6! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM7 "An SSE register" ^ self at: #XMM7! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM8 "An SSE register" ^ self at: #XMM8! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM9 "An SSE register" ^ self at: #XMM9! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 8/23/2012 17:12'! initialize | author | self classPool at: #Codes put: IdentityDictionary new. self initializeGeneralPurpose8BitRegisters. self initializeGeneralPurpose16BitRegisters. self initializeGeneralPurpose32BitRegisters. self initializeGeneralPurpose64BitRegisters. self initializeInstructionPointerRegisters. self initializeX87Registers. self initializeMMXRegisters. self initializeSSERegisters.! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose16BitRegisters "initialize general purpose 16 bit registers " self registerBase: 16r10 class: AJx86GPRegister values: #( #AX #CX #DX #BX #SP #BP #SI #DI #R8W #R9W #R10W #R11W #R12W #R13W #R14W #R15W ).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose32BitRegisters "initialize general purpose 32 bit registers " self registerBase: 16r20 class: AJx86GPRegister values: #( #EAX #ECX #EDX #EBX #ESP #EBP #ESI #EDI #R8D #R9D #R10D #R11D #R12D #R13D #R14D #R15D ).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose64BitRegisters "initialize general purpose 64 bit registers" self registerBase: 16r30 class: AJx86GPRegister values: #( #RAX #RCX #RDX #RBX #RSP #RBP #RSI #RDI #R8 #R9 #R10 #R11 #R12 #R13 #R14 #R15).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose8BitRegisters "general purpose 8 bit registers " self registerBase: 0 class: AJx86GPRegister values: #( #AL #CL #DL #BL #AH #CH #DH #BH #R8B #R9B #R10B #R11B #R12B #R13B #R14B #R15B).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeInstructionPointerRegisters | ip eip rip | ip := AJx64RipRegister code: SI code name: #IP. eip := AJx64RipRegister code: ESI code name: #EIP. rip := AJx64RipRegister code: RSI code name: #RIP. Codes at: SI code negated put: #IP; at: ESI code negated put: #EIP; at: RSI code negated put: #RIP. self classPool at: #IP put: ip; at: #EIP put: eip; at: #RIP put: rip.! ! !AJx86Registers class methodsFor: 'initialization'! initializeMMXRegisters " MMX registers " self registerBase: 16r60 class: AJMMRegister values: #( #MM0 #MM1 #MM2 #MM3 #MM4 #MM5 #MM6 #MM7 ).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:10'! initializeSSERegisters " SSE registers " self registerBase: 16r70 class: AJxMMRegister values: #( #XMM0 #XMM1 #XMM2 #XMM3 #XMM4 #XMM5 #XMM6 #XMM7 #XMM8 #XMM9 #XMM10 #XMM11 #XMM12 #XMM13 #XMM14 #XMM15).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:10'! initializeX87Registers "X87 registers" self registerBase: 16r50 class: AJx87Register values: #( #ST0 #ST1 #ST2 #ST3 #ST4 #ST5 #ST6 #ST7 ).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2012 18:45'! registerBase: base class: regClass values: names | val | val := base. names do: [ :regName | | reg | reg := regClass code: val name: regName. self classPool at: regName put: reg. Codes at: val put: regName. val := val + 1]. ! ! !AJx86Registers class methodsFor: 'initialization'! sortRegistersByIndex: aRegisterCollection ^ aRegisterCollection sort: [ :regA :regB| regA index < regB index ].! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:28'! installRegister: register accessorCategory: registerAccessorsCategory ^ self class compile:(String streamContents: [ :s | s nextPutAll: register name; crtab. self printRegister: register descriptionOn: s. s crtab; nextPutAll: '^ self at: #'; nextPutAll: register name ]) classified: registerAccessorsCategory! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:18'! installRegister: register accessorCategory: registerAccessorsCategory on: aClass aClass compile: (String streamContents: [ :s | s nextPutAll: register name; crtab. self printRegister: register descriptionOn: s. s crtab; nextPutAll: '^ '; nextPutAll: register name ]) classified: registerAccessorsCategory ! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:14'! installRegisterAccessors "this method creates simple accessors for all registers" | registerAccessorsCategory | registerAccessorsCategory := 'accessing registers'. "remove all methods in the 'accessing register' category" self class methodDict values select: [ :method | method category = registerAccessorsCategory ] thenDo: [ :method | self class removeSelector: method selector ]. self all do: [ :register | | method | "install the direct accessor on this class" self installRegister: register accessorCategory: registerAccessorsCategory. "install the accessor on the assembler" self installRegister: register accessorCategory: registerAccessorsCategory on: (register isX86 ifTrue: [ AJx86Assembler ] ifFalse: [ AJx64Assembler ])] displayingProgress: [ :each| each name ].! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:27'! printRegister: register descriptionOn: s s nextPut: $". register descriptionOn: s. register influencingRegisters ifNotEmpty: [ :registers| s crtab nextPutAll: 'This register overlaps with '. registers do: [ :reg| s nextPutAll: reg name ] separatedBy: [ s nextPutAll: ', ']]. s nextPut: $"! ! AJBaseReg subclass: #AJx87Register instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Operands'! !AJx87Register commentStamp: '' prior: 0! I am an c87 Floating Point register! !AJx87Register methodsFor: 'accessing'! code: aCode code := aCode bitOr: RegX87. size := 10.! ! !AJx87Register methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:12'! descriptionOn: s s nextPutAll: 'A floating point register'.! ! !AJx87Register methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJx87Register methodsFor: 'testing'! isRegTypeX87 ^ true! ! AJBaseReg subclass: #AJxMMRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Operands'! !AJxMMRegister methodsFor: 'accessing'! code: aCode code := aCode. size := 16! ! !AJxMMRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:15'! descriptionOn: s s nextPutAll: 'An SSE register'.! ! !AJxMMRegister methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJxMMRegister methodsFor: 'testing'! isRegTypeXMM ^ true! ! WeakIdentityKeyDictionary subclass: #ASTCache instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Parser'! !ASTCache commentStamp: '' prior: 0! I am a simple cache for AST nodes corresponding to CompiledMethods in the image. The cache is emptied when the image is saved.! !ASTCache methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:32'! at: aCompiledMethod ^ self at: aCompiledMethod ifAbsentPut: [ aCompiledMethod parseTree annotateInClass: aCompiledMethod methodClass ]! ! !ASTCache methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:29'! reset self removeAll! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ASTCache class instanceVariableNames: 'default'! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:22'! at: aCompiledMethod ^ default at: aCompiledMethod! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:30'! default ^ default! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:30'! default: anASTCache default := anASTCache.! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:27'! reset default reset.! ! !ASTCache class methodsFor: 'class initialization' stamp: 'CamilloBruni 2/20/2012 18:54'! initialize default := self new. Smalltalk addToShutDownList: self.! ! !ASTCache class methodsFor: 'system startup' stamp: 'CamilloBruni 2/17/2012 15:10'! shutDown self reset.! ! Exception subclass: #Abort instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !Abort methodsFor: 'as yet unclassified' stamp: 'ajh 3/24/2003 00:55'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! DialogWindow subclass: #AboutDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AboutDialogWindow commentStamp: 'gvc 5/18/2007 13:53' prior: 0! Default superclass for application about dialogs.! !AboutDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 16:32'! newButtons "Answer new buttons as appropriate." ^{self newCloseButton isDefault: true}! ! Path variableSubclass: #AbsolutePath instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !AbsolutePath commentStamp: '' prior: 0! I represent an absolute path (a position starting from Path root)! !AbsolutePath methodsFor: '*zinc-resource-meta-filesystem' stamp: 'SvenVanCaekenberghe 1/14/2013 10:03'! asZnUrl "Convert the receiver in a file:// ZnUrl" | fileUrl | fileUrl := ZnUrl new. fileUrl scheme: #file. self do: [ :each | fileUrl addPathSegment: each ]. ^ fileUrl! ! !AbsolutePath methodsFor: 'enumerating' stamp: 'EstebanLorenzano 4/2/2012 11:42'! withParents ^ super withParents addFirst: (Path root); yourself! ! !AbsolutePath methodsFor: 'printing' stamp: 'EstebanLorenzano 4/3/2012 11:15'! printOn: aStream aStream nextPutAll: 'Path'. self isRoot ifTrue: [aStream nextPutAll: ' root'] ifFalse: [1 to: self size do: [:i | aStream nextPutAll: ' / '''; nextPutAll: (self at: i); nextPut: $']]! ! !AbsolutePath methodsFor: 'testing' stamp: 'cwp 2/26/2011 10:58'! isAbsolute ^ true! ! !AbsolutePath methodsFor: 'testing' stamp: 'cwp 2/26/2011 11:03'! isRoot ^ self size = 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbsolutePath class instanceVariableNames: ''! !AbsolutePath class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 1/19/2012 15:12'! addEmptyElementTo: result! ! !AbsolutePath class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 1/19/2012 15:02'! from: aString delimiter: aDelimiterCharater aString = '/' ifTrue: [ ^ self root ]. ^ super from: aString delimiter: aDelimiterCharater! ! ComposableModel subclass: #AbstractApiSetter instanceVariableNames: 'choice method model selector retrievingMethod isSetting' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! choice ^ choice! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! isSetting ^ isSetting! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! isSetting: aBoolean isSetting := aBoolean ! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! method ^ method contents! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! method: anObject method contents: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! model ^ model contents! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! model: anObject model contents: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! retrievingMethod ^ retrievingMethod contents! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! retrievingMethod: anObject retrievingMethod contents: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! selector ^ selector! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! initialize "Initialization code for BooleanApiSetter" method := nil asValueHolder. model := nil asValueHolder. retrievingMethod := nil asValueHolder. isSetting := false. super initialize. self registerEvents! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! initializeWidgets self instantiateModels: #( selector LabelModel choice DropListModel ). self selector text: ''. self choice items: (#(true false) collect: [:b | DropListItem named: b printString do: [ self setValueTo: b ]]).! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 19:45'! registerEvents self registerRetrievingMethodEvent. self registerModelEvent. self registerMethodEvents! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/13/2012 02:41'! registerMethodEvents method whenChangedDo: [ :s | selector text: s asString. self model ifNotNil: [ :m | choice help: (m class lookupSelector: s) comment ] ]! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:34'! registerModelEvent model whenChangedDo: [ :m | self retrievingMethod ifNotNil: [ :meth || value | value := m perform: meth. self internUpdateWith: value ]]! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:34'! registerRetrievingMethodEvent retrievingMethod whenChangedDo: [ :meth | self model ifNotNil: [ :m || value | value := m perform: meth. self internUpdateWith: value ]]! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:41'! setValueTo: anObject self model ifNil: [ ^ self ]. self method ifNil: [ ^ self ]. self isSetting ifFalse: [ self isSetting: true. self model perform: (self method) with: anObject. self isSetting: false ].! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:46'! initialExtent ^ 450@25! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 20:34'! internUpdateWith: aValue self subclassResponsibility! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 19:25'! selectorWidth: aNumber | layout | layout := SpecLayout composed newRow: [:r | r newColumn: [:c | c add: #selector ] width: aNumber; add: #choice ] height: 25; yourself. self needRebuild: false. selector needRebuild: false. choice needRebuild: false. self buildWithSpecLayout: layout.! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:59'! updateWith: aValue self isSetting ifFalse: [ self isSetting: true. self internUpdateWith: aValue. self isSetting: false ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractApiSetter class instanceVariableNames: ''! !AbstractApiSetter class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! spec ^ SpecLayout composed newRow: [:r | r add: #selector; newColumn: [:c | c add: #choice ] width: 75] height: 25; yourself! ! ComposableModel subclass: #AbstractBasicWidget instanceVariableNames: 'helpHolder borderWidth borderColor enabledHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !AbstractBasicWidget commentStamp: '' prior: 0! AbstractBasicWidget is an abstract class for basic widgets! !AbstractBasicWidget methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/22/2013 00:22'! buildWithSpec: aSpec "Build the widget using the spec name provided as argument" | widget | (self spec notNil and: [ self needRebuild not ]) ifTrue: [ ^ self widget ] ifFalse: [ widget := SpecInterpreter buildWidgetFor: self withSpec: aSpec ]. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !AbstractBasicWidget methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/22/2013 00:22'! buildWithSpecLayout: aSpecLayout "Build the widget using the spec name provided as argument" | widget | (self spec notNil and: [ self needRebuild not ]) ifTrue: [ ^ self widget ] ifFalse: [ widget := SpecInterpreter interpretASpec: aSpecLayout model: self ]. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !AbstractBasicWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/16/2012 18:09'! initialize "Initialization code for AbstractBasicWidget" super initialize. helpHolder := nil asValueHolder. borderWidth := 0 asValueHolder. borderColor := Color transparent asValueHolder. enabledHolder := true asValueHolder. helpHolder whenChangedDo: [:string | self widget ifNotNil: [:w | w setBalloonText: string ]]. borderWidth whenChangedDo: [:int | self widget ifNotNil: [:w | w borderWidth: int ]]. borderColor whenChangedDo: [:color | self widget ifNotNil: [:w | w borderColor: color ]]. enabledHolder whenChangedDo: [:b | self widget ifNotNil: [:w | w enabled: b ]].! ! !AbstractBasicWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:10'! initializeWidgets "ignore this method since there is no composition in basic widgets"! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:27'! borderColor "Return the border color" ^ borderColor contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:31'! borderColor: aColor "Set the border width" borderColor contents: aColor ! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:17'! borderWidth "Return the border width" ^ borderWidth contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 17:46'! borderWidth: anInteger "Set the border width" borderWidth contents: anInteger! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:51'! color ^ self widget ifNil: [ Color white ] ifNotNil: [:w | w color ]! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:51'! color: aColor ^ self widget ifNotNil: [:w | w color: aColor ]! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:06'! disable "Disable the label" self enabled: false! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:06'! enable "Enable the label" self enabled: true! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:02'! enabled ^ enabledHolder contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:02'! enabled: aBoolean "Set if the button is enabled (clickable)" enabledHolder contents: aBoolean! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 17:55'! help "Return the ballon text" ^ helpHolder contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:18'! help: aString "Set the help string" helpHolder contents: aString! ! !AbstractBasicWidget methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:36'! whenBorderColorChanged: aBlock "Set a block to be performed when the brder width changed" borderColor whenChangedDo: aBlock! ! !AbstractBasicWidget methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:36'! whenBorderWidthChanged: aBlock "Set a block to be performed when the brder width changed" borderWidth whenChangedDo: aBlock! ! !AbstractBasicWidget methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 18:03'! whenEnabledChanged: aBlock "Set a block to performed when the widget is enabled or disabled" enabledHolder whenChangedDo: aBlock! ! !AbstractBasicWidget methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:36'! whenHelpChanged: aBlock "Set a block to be performed when the help changed" helpHolder whenChangedDo: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractBasicWidget class instanceVariableNames: ''! !AbstractBasicWidget class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 6/13/2012 16:36'! defaultSpec ^ SpecLayout composed! ! Object subclass: #AbstractBindings instanceVariableNames: 'classSymbols selectorSymbols' classVariableNames: '' poolDictionaries: '' category: 'Spec-Bindings'! !AbstractBindings commentStamp: '' prior: 0! AbstractHolder is an abstract class which handle two dictionaries: one for classes symbol, and one for selectors symbols.! !AbstractBindings methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/23/2012 14:55'! initialize "Initialization code for AbstractHolder" super initialize. classSymbols := self initializeClassesDictionary. selectorSymbols := self initializeSelectorsDictionary! ! !AbstractBindings methodsFor: 'initialization'! initializeClassesDictionary ^ IdentityDictionary new! ! !AbstractBindings methodsFor: 'initialization'! initializeSelectorsDictionary ^ IdentityDictionary new! ! !AbstractBindings methodsFor: 'protocol'! classSymbolFor: aSymbol ^ classSymbols at: aSymbol! ! !AbstractBindings methodsFor: 'protocol'! classSymbolFor: aSymbol ifAbsent: aBlock ^ classSymbols at: aSymbol ifAbsent: aBlock! ! !AbstractBindings methodsFor: 'protocol'! classSymbolFor: aSymbol is: aClassSymbol ^ classSymbols at: aSymbol put: aClassSymbol! ! !AbstractBindings methodsFor: 'protocol'! selectorSymbolFor: aSymbol ^ selectorSymbols at: aSymbol! ! !AbstractBindings methodsFor: 'protocol'! selectorSymbolFor: aSymbol ifAbsent: aBlock ^ selectorSymbols at: aSymbol ifAbsent: aBlock! ! !AbstractBindings methodsFor: 'protocol'! selectorSymbolFor: aSymbol is: aSelector ^ selectorSymbols at: aSymbol put: aSelector! ! AbstractWidget subclass: #AbstractCategoryWidget instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractCategoryWidget commentStamp: '' prior: 0! AbstractCategoryWidget is an abstraction describing a widget used to manage categories! !AbstractCategoryWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:34'! dragPassengersFor: item inMorph: dragSource | transferType object | (dragSource isKindOf: PluggableListMorph) ifFalse: [^ nil ]. transferType := self dragTransferTypeForMorph: dragSource. object := item originalObject. transferType == #getCategoryItem: ifTrue: [ ^ self selectedCategories ifEmpty: [ { object } ] ]. ^ nil! ! !AbstractCategoryWidget methodsFor: 'drag and drop'! dropMethod: aCollectionOfMethods inARow: aRow self model dropMethod: aCollectionOfMethods inARow: aRow! ! !AbstractCategoryWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:35'! wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM "We are only interested in TransferMorphs as wrappers for informations. If their content is really interesting for us, will determined later in >>acceptDroppingMorph:event:." | srcType dstType | "only want drops on lists (not, for example, on pluggable texts)" (destinationLM isKindOf: PluggableListMorph) ifFalse: [ ^ false ]. srcType := transferMorph dragTransferType. dstType := self dragTransferTypeForMorph: destinationLM. ^ srcType == #getMethodItem: and: [ dstType == #getCategoryItem:]! ! !AbstractCategoryWidget methodsFor: 'icon'! thereIsNoIconsOnCategories! ! !AbstractCategoryWidget methodsFor: 'item creation'! buildCategoriesList ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! categoriesMenu: aMenuMorph shifted: aBoolean ^ self model categoriesMenu: aMenuMorph shifted: aBoolean ! ! !AbstractCategoryWidget methodsFor: 'protocol'! categoriesSelection ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! keyPressedOnCategory: anEvent ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! label: aString ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/17/2012 16:57'! okToChange ^ self model okToChange! ! !AbstractCategoryWidget methodsFor: 'protocol'! searchedElement: index ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! selectedCategories ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! selectedCategory ^ self model selectedCategory! ! !AbstractCategoryWidget methodsFor: 'protocol'! showInstance ^ self model showInstance! ! !AbstractCategoryWidget methodsFor: 'protocol'! takeKeyboardFocus ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! vScrollValue ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! vScrollValue: aNumber ^ self subclassResponsibility! ! Object subclass: #AbstractDescription instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AbstractDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:35'! generate ^ self generateSpec asOrderedCollection addFirst: #model; asArray! ! !AbstractDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:44'! generateSpec ^ self subclassResponsibility! ! Object subclass: #AbstractEcryptor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !AbstractEcryptor commentStamp: '' prior: 0! An AbstractEcryptor is an interface for encryptor. It's basically just an algorithm to encrypt a string, without ensuring it can be decrypted! !AbstractEcryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:08'! encrypt: aString ^ self subclassResponsibility! ! Object subclass: #AbstractEcryptorDecryptor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !AbstractEcryptorDecryptor commentStamp: '' prior: 0! An AbstractEcryptorDecryptor is an interface providing the method for encrypting/decrypting a string! !AbstractEcryptorDecryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:07'! decrypt: aString base: aBase ^ self subclassResponsibility! ! !AbstractEcryptorDecryptor methodsFor: 'protocol' stamp: 'Camillo 5/15/2012 11:21'! encrypt: aString base: aBase ^ self subclassResponsibility! ! FileSystemVisitor subclass: #AbstractEnumerationVisitor instanceVariableNames: 'out block' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !AbstractEnumerationVisitor commentStamp: '' prior: 0! I'm an abstract superclass for enumeration operations on directory entries. ! !AbstractEnumerationVisitor methodsFor: 'initialization' stamp: 'CamilloBruni 8/9/2011 15:46'! initializeWithBlock: aBlock self initialize. block := aBlock! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'EstebanLorenzano 4/2/2012 11:37'! breadthFirst: aReference ^ self visit: aReference with: (BreadthFirstGuide for: self)! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'EstebanLorenzano 4/2/2012 11:38'! postorder: aReference ^ self visit: aReference with: (PostorderGuide for: self)! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'EstebanLorenzano 4/2/2012 11:38'! preorder: aReference ^ self visit: aReference with: (PreorderGuide for: self)! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'CamilloBruni 8/9/2011 15:46'! visit: aReference with: aGuide out := (Array new: 10) writeStream. aGuide show: aReference. ^ out contents! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'CamilloBruni 8/9/2011 15:48'! visitReference: anEntry self subclassResponsibility! ! SingleTreeTest subclass: #AbstractEnumerationVisitorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !AbstractEnumerationVisitorTest methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 4/2/2012 11:43'! assertEntries: references are: expected | strings | self assert: references isArray. references do: [ :ea | self assert: ea class = FileSystemDirectoryEntry ]. strings := references collect: [ :ea | ea reference pathString ]. self assert: strings = expected! ! !AbstractEnumerationVisitorTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 15:45'! root ^ filesystem / 'alpha'! ! !AbstractEnumerationVisitorTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/9/2011 16:01'! setUp super setUp. self setUpGreek.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractEnumerationVisitorTest class instanceVariableNames: ''! !AbstractEnumerationVisitorTest class methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 4/3/2012 09:42'! isAbstract ^ self name = #AbstractEnumerationVisitorTest! ! Object subclass: #AbstractFileReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Public'! !AbstractFileReference commentStamp: '' prior: 0! I am an abstract superclass for FileLocator and FileReference. By implementing most of the methods on myself most code duplucation between the locator and the reference can be avoided! !AbstractFileReference methodsFor: '*Network-Url' stamp: 'CamilloBruni 7/10/2012 15:03'! asUrl "Convert my path into a file:// type url - a FileUrl." ^ self path asUrl! ! !AbstractFileReference methodsFor: '*Polymorph-Widgets' stamp: 'CamilloBruni 1/23/2013 12:41'! item ^ self! ! !AbstractFileReference methodsFor: '*codeimport' stamp: 'CamilloBruni 7/10/2012 20:14'! fileIn self readStreamDo: [ :stream | CodeImporter evaluateFileStream: stream ]! ! !AbstractFileReference methodsFor: '*zinc-resource-meta-filesystem' stamp: 'SvenVanCaekenberghe 1/14/2013 10:01'! asZnUrl "Convert the receiver in a file:// ZnUrl. Only an absolute path can be represented as a file:// URL" ^ self asAbsolute path asZnUrl! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! absolutePath "Returns the absolute path" ^ self subclassResponsibility! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:27'! base "Returns the base of the basename, i.e. /foo/gloops.taz base is 'gloops'" ^ self fullPath base! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:28'! basename "Returns the basename, i.e. /foo/gloops.taz basename is 'gloops.taz'" ^ self fullPath basename! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:07'! basenameWithIndicator "Returns the basename with the indicator appended, i.e. /foo/gloops.taz basenameWithIndicator is 'gloops.taz', whereras /foo basenameWithIndicator is 'foo/'" ^ self basename, self indicator ! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:28'! basenameWithoutExtension "Returns the basename, i.e. /foo/gloops.taz basenameWithoutExtension is 'gloops'" ^ self fullPath basenameWithoutExtension! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:51'! creationTime ^ self resolve creationTime ! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:04'! entry ^ self resolve entry! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:30'! extension ^ self fullPath extension.! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:27'! extensions "#('foo' 'foo.tar' 'foo.tar.gz' 'foo.1.tar' 'foo.1.tar.gz') collect: [:thing| thing extensions] => #(#() #('tar') #('tar' 'gz') #('1' 'tar') #('1' 'tar' 'gz'))" ^ self fullPath extensions! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:01'! fileSystem ^ self resolve fileSystem! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:30'! fullNameWithIndicator "Returns the basename with the indicator appended, i.e. /foo/gloops.taz basenameWithIndicator is '/foo/gloops.taz', whereras /foo basenameWithIndicator is '/foo/'" ^ self fullName, self indicator ! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! fullPath "Returns the absolute path, better use absolutePath" ^ self subclassResponsibility! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:12'! humanReadableSize ^ self size humanReadableSIByteSize! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:51'! modificationTime ^ self resolve modificationTime ! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:31'! pathSegments ^ self fullPath segments! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 21:29'! permissions "Return the FileSystemPermission for this node" ^ self resolve permissions! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:05'! size ^ self resolve size! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:31'! uri "Convert my path into a file:// type url. For odd characters use %20 notation." self flag: 'TODO: return a real URI object instead of a string'. ^(String streamContents: [:strm | strm nextPutAll: 'file:'. self pathSegments do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP]. strm nextPut: $/]) asURI! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 7/10/2012 15:20'! <= other ^ self path <= self other path! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:02'! contains: anObject "Return true if anObject is in a subfolder of me" ^ anObject isContainedBy: self resolve! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 7/10/2012 15:32'! containsPath: aPath ^ self fullPath containsPath: aPath! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 8/9/2012 12:31'! hash "Hash is reimplemented because #= is reimplemented" ^ self path hash! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:07'! isContainedBy: anObject "DoubleDispatch helper for #contains:" ^ anObject containsReference: self resolve! ! !AbstractFileReference methodsFor: 'converting' stamp: 'PavelKrivanek 11/23/2012 12:21'! asAbsolute self subclassResponsibility! ! !AbstractFileReference methodsFor: 'converting' stamp: 'PavelKrivanek 11/23/2012 12:21'! asFileReference self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'copying' stamp: 'PavelKrivanek 11/23/2012 12:21'! copyWithPath: newPath self subclassResponsibility! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! asPathWith: anObject ^ self resolve asPathWith: anObject! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! copyTo: aReference ^ self resolve copyTo: aReference resolve! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! exists ^ self resolve exists! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! filesystem self deprecated: 'Use fileSystem' on: '3 April 2012' in: 'Pharo 1.4'. ^ self fileSystem! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! fullName ^ self resolve fullName! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! macTypeAndCreator ^ self resolve macTypeAndCreator! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! mimeTypes ^ self resolve mimeTypes! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! parent ^ self withPath: self path parent! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! pathString ^ self resolve pathString! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:43'! allChildren "Return all the files and folders recursively nested in the receiver" ^ CollectVisitor breadthFirst: self resolve collect: [:entry | entry reference]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:46'! allDirectories "Return all the directories recursively nested in the receiver." ^ (SelectVisitor breadthFirst: self resolve select: [:entry | entry isDirectory ]) collect: [ :each| each reference ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:35'! allEntries ^ CollectVisitor breadthFirst: self resolve! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:45'! allFiles "Return all the files (not directories) recursively nested in the receiver." ^ (SelectVisitor breadthFirst: self resolve select: [:entry | entry isFile ]) collect: [ :each| each reference ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 8/9/2012 11:38'! childNames ^ self children collect: #basename! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:37'! children "Answer an array containing references to the direct children of this reference." | reference | reference := self resolve. ^ (reference fileSystem childNamesAt: reference path) collect: [ :aName | self / aName ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:35'! childrenMatching: patterns " FileSystem disk workingDirectory childrenMatching: '*' FileSystem disk workingDirectory childrenMatching: '*.image;*.changes' " ^ self childGeneratorBlock: [:reference : aBlock| reference fileSystem childNamesAt: reference path do: aBlock ] matching: patterns ! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:47'! directories "Return all the directories (by opposition to files) contained in the receiver" | reference | reference := self resolve. ^ (reference fileSystem directoryNamesAt: reference path) collect: [ :aName | self withPath: self path / aName ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:35'! directoriesMatching: patterns " FileSystem disk workingDirectory directoriesMatching: '*' FileSystem disk workingDirectory directoriesMatching: 'package-cache' " ^ self childGeneratorBlock: [:reference : aBlock| reference fileSystem directoryNamesAt: reference path do: aBlock ] matching: patterns ! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 8/9/2012 11:38'! directoryNames ^ self directories collect: #basename! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:04'! entries ^ self resolve entries! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:30'! fileNames ^ self files collect: #basename! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:47'! files "Return all the files (as opposed to folders) contained in the receiver" | reference | reference := self resolve. ^ (reference fileSystem fileNamesAt: reference path) collect: [ :aName | self withPath: self path / aName ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:35'! filesMatching: patterns " FileSystem disk workingDirectory filesMatching: '*' FileSystem disk workingDirectory filesMatching: '*.image;*.changes' " ^ self childGeneratorBlock: [:reference : aBlock| reference fileSystem fileNamesAt: reference path do: aBlock ] matching: patterns ! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:35'! glob: aBlock ^ SelectVisitor breadthFirst: self resolve select: aBlock! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:08'! , extension ^ self withPath: self path, extension! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 20:36'! / aString ^ self withPath: self path / aString! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:49'! makeRelative: anObject ^ anObject relativeToReference: self resolve! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 9/5/2012 11:26'! relativeTo: landmark "Answer a new path relative to landmark." "parent/child/grandChild relativeTo: parent returns child/grandChild (Filesystem disk / 'griffle' / 'plonk' / 'nurp') relativeTo: (Filesystem disk / 'griffle') returns plonk/nurp" ^ landmark makeRelative: self resolve! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:50'! relativeToPath: landmarkPath ^ self fullPath relativeTo: landmarkPath! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:51'! relativeToReference: landmarkReference "Return the path of the receiver relative to landmarkReference." ^ self fullPath relativeTo: landmarkReference path! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'PavelKrivanek 11/23/2012 12:21'! resolve ^ self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:05'! resolve: anObject ^ anObject asResolvedBy: self! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! resolvePath: aPath ^ self withPath: (self path resolvePath: aPath)! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! resolveReference: aReference ^ aReference isAbsolute ifTrue: [ aReference ] ifFalse: [ self withPath: aReference path ]! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'PavelKrivanek 11/23/2012 12:21'! resolveString: aString self subclassResponsibility! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:05'! withExtension: aString ^ self withPath: (self path withExtension: aString)! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! withPath: newPath ^ self path == newPath ifTrue: [ self ] ifFalse: [ self copyWithPath: newPath ]! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:51'! copyAllTo: aResolvable CopyVisitor copy: self resolve asAbsolute to: aResolvable resolve! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! createDirectory self resolve createDirectory! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:04'! delete ^ self resolve delete! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! deleteAll "delete this directory and all children of it" DeleteVisitor delete: self resolve! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! deleteAllChildren "delete all children of the receiver" self children do: [:aReference | aReference deleteAll ]! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:56'! deleteIfAbsent: aBlock self resolve deleteIfAbsent: aBlock! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:54'! ensureDeleted self deleteIfAbsent: [].! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:04'! ensureDirectory ^ self resolve ensureDirectory! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:53'! ensureFile "Create if necessary a file for the receiver." self writeStream close. ! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:04'! moveTo: aReference ^ self resolve moveTo: aReference! ! !AbstractFileReference methodsFor: 'operations' stamp: 'PavelKrivanek 11/23/2012 12:21'! renameTo: newBasename self subclassResponsibility! ! !AbstractFileReference methodsFor: 'printing' stamp: 'CamilloBruni 7/10/2012 20:15'! indicator "Returns a string indicating the type of reference: - '?' for a non existing reference', - '/' for a directory, - the empty string for a file." "When this framework gets more complete, it is possible to extend this behavior with the following indicators (taken from unix ls utility): - '*' for a regular file that is executable - '@' for a symbolic link - '|' for FIFOs - '=' for sockets - '>' for doors" ^ self exists ifTrue: [self isDirectory ifTrue: ['/'] ifFalse: [''] ] ifFalse: ['?']! ! !AbstractFileReference methodsFor: 'resolving' stamp: 'CamilloBruni 7/10/2012 15:20'! asResolvedBy: anObject ^ anObject resolveReference: self! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 20:16'! openWritable: aBoolean ^ self resolve openWritable: aBoolean! ! !AbstractFileReference methodsFor: 'streams' stamp: 'PavelKrivanek 11/23/2012 12:21'! readStream self subclassResponsibility! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamDo: aBlock | stream | stream := self readStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamDo: doBlock ifAbsent: absentBlock ^ self isFile ifTrue: [ self readStreamDo: doBlock ] ifFalse: absentBlock! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamIfAbsent: absentBlock ^ self isFile ifTrue: [ self readStream ] ifFalse: absentBlock! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 22:34'! streamWritable: writable do: aBlock ^ writable ifTrue: [ self writeStreamDo: aBlock ] ifFalse: [ self readStreamDo: aBlock ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'PavelKrivanek 11/23/2012 12:21'! writeStream self subclassResponsibility! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamDo: aBlock | stream | stream := self writeStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamDo: doBlock ifPresent: presentBlock ^ self isFile ifTrue: presentBlock ifFalse: [ self writeStreamDo: doBlock ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamIfPresent: presentBlock ^ self isFile ifTrue: presentBlock ifFalse: [ self writeStream ]! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasChildren ^self resolve hasChildren! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasDirectories ^self resolve hasDirectories! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasFiles ^self resolve hasFiles! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:17'! ifFile: fBlock ifDirectory: dBlock ifAbsent: aBlock ^ self isFile ifTrue: fBlock ifFalse: [ self isDirectory ifTrue: dBlock ifFalse: aBlock ]! ! !AbstractFileReference methodsFor: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isAbsolute self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:17'! isChildOf: anObject ^ self parent = anObject! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isDirectory ^ self resolve isDirectory! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isFile ^ self resolve isFile! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isReadable ^ self resolve isReadable! ! !AbstractFileReference methodsFor: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isRelative self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isRoot ^ self resolve isRoot! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:19'! isWritable ^ self resolve isWritable! ! !AbstractFileReference methodsFor: 'utility' stamp: 'CamilloBruni 7/10/2012 15:04'! nextVersion ^ self resolve nextVersion! ! !AbstractFileReference methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 20:36'! childGeneratorBlock: doBlock matching: patterns " FileDirectory default fileNamesMatching: '*' FileDirectory default fileNamesMatching: '*.image;*.changes' " | files reference| files := Set new. reference := self resolve. (patterns findTokens: ';', String crlf) do: [ :pattern | doBlock value: reference value: [ :basename| (pattern match: basename) ifTrue: [ files add: (self / basename) ]]]. ^files asOrderedCollection! ! Object subclass: #AbstractFont instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !AbstractFont commentStamp: '' prior: 0! AbstractFont defines the generic interface that all fonts need to implement.! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 14:36'! displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the strikeout if appropriate for the receiver"! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 13:51'! displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the underline if appropriate for the receiver"! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:16'! emphasisString "Answer a translated string that represents the receiver's emphasis." ^self emphasisStringFor: self emphasis! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:13'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." ^self class emphasisStringFor: emphasisCode! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:43'! hasDistinctGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString and no single glyph is shared by more than one character, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:25'! hasGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/6/2007 12:58'! isSubPixelPositioned "Answer true if the receiver is currently using subpixel positioned glyphs, false otherwise. This affects how padded space sizes are calculated when composing text. Currently, only FreeTypeFonts are subPixelPositioned, and only when not Hinted" ^false ! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:32'! isSymbolFont "Answer true if the receiver is a Symbol font, false otherwise. The default is to answer false, subclasses can reimplement" ^false! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/10/2007 13:08'! kerningLeft: leftChar right: rightChar ^0! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/31/2007 20:17'! linearWidthOf: aCharacter "This is the scaled, unrounded advance width." ^self widthOf: aCharacter! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/3/2007 16:47'! widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray "Set the first element of aTwoElementArray to the width of leftCharacter and the second element to the width of left character when kerned with rightCharacterOrNil. Answer aTwoElementArray" | w k | w := self widthOf: leftCharacter. rightCharacterOrNil isNil ifTrue:[ aTwoElementArray at: 1 put: w; at: 2 put: w] ifFalse:[ k := self kerningLeft: leftCharacter right: rightCharacterOrNil. aTwoElementArray at: 1 put: w; at: 2 put: w+k]. ^aTwoElementArray ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! ascent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! ascentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'! baseKern ^0! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! basicAscentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! basicDescentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:56'! characterToGlyphMap "Return the character to glyph mapping table. If the table is not provided the character scanner will query the font directly for the width of each individual character." ^nil! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'! derivativeFonts ^#()! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:15'! familyName "Answer the name to be used as a key in the TextConstants dictionary." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! height "Answer the height of the receiver, total of maximum extents of characters above and below the baseline." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'! isRegular ^false! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! lineGrid "Answer the relative space between lines" ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33'! pixelSize "Make sure that we don't return a Fraction" ^ TextStyle pointsToPixels: self pointSize! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'! pointSize self subclassResponsibility.! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'! textStyle ^ TextStyle actualTextStyles detect: [:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'! textStyleName "Answer the name to be used as a key in the TextConstants dictionary." ^self familyName! ! !AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:57'! xTable "Return the xTable for the font. The xTable defines the left x-value for each individual glyph in the receiver. If such a table is not provided, the character scanner will ask the font directly for the appropriate width of each individual character." ^nil! ! !AbstractFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:47'! releaseCachedState ! ! !AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:36'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor "Install the receiver on the given DisplayContext (either BitBlt or Canvas) for further drawing operations." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 5/28/2011 13:17'! approxWidthOfText: aText "Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item." | w | (aText isNil or: [ aText size = 0 ]) ifTrue: [ ^ 0 ]. w := self widthOfString: aText asString. "If the text has no emphasis, just return the string size. If it is empasized, just approximate the width by adding about 20% to the width" ((aText runLengthFor: 1) = aText size and: [ (aText emphasisAt: 1) = 0 ]) ifTrue: [ ^ w ] ifFalse: [ ^ w * 6 // 5 ]! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 14:58'! widthOf: aCharacter "Return the width of the given character" ^self subclassResponsibility! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 5/28/2011 13:17'! widthOfString: aString aString ifNil: [^0]. ^self widthOfString: aString from: 1 to: aString size. " TextStyle default defaultFont widthOfString: 'zort' 21 "! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 12/29/2009 22:42'! widthOfString: aString from: firstIndex to: lastIndex "Measure the length of the given string between start and stop index" | resultX | resultX := 0. firstIndex to: lastIndex do: [ :i | resultX := resultX + (self widthOf: (aString at: i)) ]. ^ resultX! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 5/28/2011 13:17'! widthOfStringOrText: aStringOrText aStringOrText ifNil: [^0]. ^aStringOrText isText ifTrue:[self approxWidthOfText: aStringOrText ] ifFalse:[self widthOfString: aStringOrText ] ! ! !AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'! pixelsPerInchChanged "The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! ! !AbstractFont methodsFor: 'testing' stamp: 'yo 2/12/2007 19:34'! isFontSet ^ false. ! ! !AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! isTTCFont ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractFont class instanceVariableNames: ''! !AbstractFont class methodsFor: '*system-settings-browser' stamp: 'alain.plantec 3/18/2009 14:49'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForFont! ! !AbstractFont class methodsFor: 'as yet unclassified' stamp: 'eem 6/11/2008 12:35'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." | emphases | emphasisCode = 0 ifTrue: [ ^'Normal' translated ]. emphases := (IdentityDictionary new) at: 1 put: 'Bold' translated; at: 2 put: 'Italic' translated; at: 4 put: 'Underlined' translated; at: 8 put: 'Narrow' translated; at: 16 put: 'StruckOut' translated; yourself. ^String streamContents: [ :s | | bit | bit := 1. [ bit < 32 ] whileTrue: [ | code | code := emphasisCode bitAnd: bit. code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ]. bit := bit bitShift: 1 ]. s position isZero ifFalse: [ s skip: -1 ]. ]! ! !AbstractFont class methodsFor: 'class initialization' stamp: 'PavelKrivanek 6/1/2011 12:47'! initialize TextStyle addDependent: self.! ! !AbstractFont class methodsFor: 'updating' stamp: 'StephaneDucasse 6/2/2011 20:24'! update: anAspect anAspect == #textDPIChanged ifTrue: [ AbstractFont allSubInstancesDo: [ :font | font pixelsPerInchChanged ]].! ! DialogWindow subclass: #AbstractFontSelectorDialogWindow instanceVariableNames: 'fontFamilies selectedFont textPreviewMorph fontFamilyIndex fontSizeIndex isBold isItalic isUnderlined isStruckOut previewText' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AbstractFontSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:04' prior: 0! Dialog based font chooser with preview.! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:40'! fontFamilies "Answer the set of available fonts families that are supported as Text objects in the font that they represent." ^fontFamilies ifNil: [ self fontFamilies: self defaultFontFamilies. fontFamilies]! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:02'! fontFamilies: anObject "Set the value of fontFamilies" fontFamilies := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontFamilyIndex "Answer the value of fontFamilyIndex" ^ fontFamilyIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontFamilyIndex: anObject "Set the value of fontFamilyIndex" fontFamilyIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontSizeIndex "Answer the value of fontSizeIndex" ^ fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontSizeIndex: anObject "Set the value of fontSizeIndex" fontSizeIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isBold "Answer the value of isBold" ^ isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isBold: anObject "Set the value of isBold" isBold := anObject. self changed: #isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isItalic "Answer the value of isItalic" ^ isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isItalic: anObject "Set the value of isItalic" isItalic := anObject. self changed: #isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isStruckOut "Answer the value of isStruckOut" ^ isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isStruckOut: anObject "Set the value of isStruckOut" isStruckOut := anObject. self changed: #isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isUnderlined "Answer the value of isUnderlined" ^ isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isUnderlined: anObject "Set the value of isUnderlined" isUnderlined := anObject. self changed: #isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:30'! previewText "Answer the value of previewText" ^previewText asText addAttribute: (TextEmphasis new emphasisCode: self textEmphasisCode)! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/18/2007 13:07'! previewText: anObject "Set the value of previewText" previewText := anObject. self changed: #previewText! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! selectedFont "Answer the value of selectedFont" ^ selectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/9/2007 14:19'! selectedFont: anObject "Set the value of selectedFont" selectedFont := anObject ifNil: [TextStyle defaultFont]. self updateFromSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph "Answer the value of textPreviewMorph" ^ textPreviewMorph! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph: anObject "Set the value of textPreviewMorph" textPreviewMorph := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:49'! defaultFontFamilies "Answer the set of available fonts families that are supported in the font that they represent." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:31'! defaultPreviewText "Answer the default text to use for the preview of the font." ^(33 to: 127) asByteArray asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:47'! familyName "Answer the selected family name or nil if none." (self fontFamilyIndex between: 1 and: self fontFamilies size) ifFalse: [^nil]. ^(self fontFamilies at: self fontFamilyIndex) asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:03'! fontSize "Answer the selected font size or nil if none." (self fontSizeIndex between: 1 and: self fontSizes size) ifFalse: [^nil]. ^self fontSizes at: self fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 14:31'! fontSizes "Answer the set of available fonts sizes that are supported." ^#(6 7 8 9 10 11 12 13 14 15 16 18 20 21 22 24 26 28 32 36 48)! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:22'! initialize "Initialize the receiver." self isBold: false; isItalic: false; isUnderlined: false; isStruckOut: false; previewText: self defaultPreviewText; fontFamilyIndex: 0; fontSizeIndex: 0. super initialize! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:35'! matchingFont "Answer the font that matches the selections." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newBoldButtonMorph "Answer a button for the boldness of the font." ^self newButtonFor: self getState: #isBold action: #toggleBold arguments: nil getEnabled: nil labelForm: self theme smallBoldIcon help: 'Toggle bold font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newContentMorph "Answer a new content morph." self textPreviewMorph: self newTextPreviewMorph. ^(self newColumn: { (self newRow: { self newGroupbox: 'Family' translated for: self newFontFamilyMorph. (self newColumn: { (self newGroupbox: 'Style' translated for: self newFontStyleButtonRowMorph) vResizing: #shrinkWrap. self newGroupbox: 'Point size' translated for: self newFontSizeMorph}) hResizing: #shrinkWrap}) vResizing: #spaceFill. (self newGroupbox: 'Preview' translated for: self textPreviewMorph) vResizing: #shrinkWrap}) minWidth: 350; minHeight: 400! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontFamilyMorph "Answer a list for the font family of the font." |highestFont| highestFont := self fontFamilies first fontAt: 1 withStyle: TextStyle default. self fontFamilies do: [:ff | |f| f := ff fontAt: 1 withStyle: TextStyle default. f height > highestFont height ifTrue: [highestFont := f]]. ^(self newListFor: self list: #fontFamilies selected: #fontFamilyIndex changeSelected: #fontFamilyIndex: help: nil) font: highestFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontSizeMorph "Answer a list for the font size of the font." ^self newListFor: self list: #fontSizes selected: #fontSizeIndex changeSelected: #fontSizeIndex: help: nil! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newFontStyleButtonRowMorph "Answer a new font style button row morph." ^self newRow: { self newBoldButtonMorph. self newItalicButtonMorph. self newUnderlinedButtonMorph. self newStruckOutButtonMorph}! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newItalicButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isItalic action: #toggleItalic arguments: nil getEnabled: nil labelForm: self theme smallItalicIcon help: 'Toggle italic font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newStruckOutButtonMorph "Answer a button for the struck out emphasis of the font." ^self newButtonFor: self getState: #isStruckOut action: #toggleStruckOut arguments: nil getEnabled: nil labelForm: self theme smallStrikeOutIcon help: 'Toggle struck-out font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:31'! newTextPreviewMorph "Answer a text entry morph for the preview of the font." ^(self newTextEditorFor: self getText: #previewText setText: nil getEnabled: nil) vResizing: #rigid; enabled: false; extent: 20@90! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newUnderlinedButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isUnderlined action: #toggleUnderlined arguments: nil getEnabled: nil labelForm: self theme smallUnderlineIcon help: 'Toggle underlined font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:33'! textEmphasisCode "Answer the current bitmask for the text emphasis." ^(((self isBold ifTrue: [1] ifFalse: [0]) bitOr: (self isItalic ifTrue: [2] ifFalse: [0])) bitOr: (self isUnderlined ifTrue: [4] ifFalse: [0])) bitOr: (self isStruckOut ifTrue: [16] ifFalse: [0])! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleBold "Toggle the font bold emphasis." self isBold: self isBold not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleItalic "Toggle the font italic emphasis." self isItalic: self isItalic not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleStruckOut "Toggle the font struck out emphasis." self isStruckOut: self isStruckOut not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleUnderlined "Toggle the font underlined emphasis." self isUnderlined: self isUnderlined not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:21'! updateFromSelectedFont "Update our state based on the selected font." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/4/2007 10:25'! updateSelectedFont "Update the selected font to reflect the choices." self selectedFont: self matchingFont! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractFontSelectorDialogWindow class instanceVariableNames: ''! !AbstractFontSelectorDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'AlainPlantec 10/19/2010 20:22'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallFontsIcon! ! Object subclass: #AbstractGroup instanceVariableNames: 'name readOnly removable sortBlock isFillable' classVariableNames: '' poolDictionaries: '' category: 'GroupManager'! !AbstractGroup commentStamp: '' prior: 0! AbstractGroup is an abstraction of what a group is.! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 17:14'! isFillable ^ isFillable ifNil: [ isFillable := false ]! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 17:07'! isFillable: aBoolean isFillable := aBoolean! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! classRemoved: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! methodModified: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! methodRemoved: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'BenjaminVanRyseghem 4/14/2012 12:38'! registerToAnnouncements self registerToClassAnnouncements; registerToMethodAnnouncements! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'EstebanLorenzano 8/3/2012 13:57'! registerToClassAnnouncements SystemAnnouncer uniqueInstance weak on: ClassRemoved send: #classRemoved: to: self! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'EstebanLorenzano 8/3/2012 13:57'! registerToMethodAnnouncements SystemAnnouncer uniqueInstance weak on: MethodModified send: #methodModified: to: self; on: MethodRemoved send: #methodRemoved: to: self.! ! !AbstractGroup methodsFor: 'polymorphism' stamp: 'BenjaminVanRyseghem 3/28/2011 13:50'! blocks ^ { [ self elements ] }! ! !AbstractGroup methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 3/29/2011 11:20'! printOn: aStream | className article | className := self class name. article := className first isVowel ifTrue: ['an'] ifFalse: ['a']. aStream nextPutAll: article; nextPut: Character space; nextPutAll: className; nextPutAll: ' ( '; nextPutAll: self name asString; nextPutAll: ' )'.! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:00'! beReadOnly readOnly := true! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:22'! elements ^ self subclassResponsibility! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2011 21:55'! isReadOnly ^ readOnly == true! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:03'! name ^ name! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:04'! name: aString self ifAllowed: [ name := aString ]! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/24/2011 13:41'! removable ^ removable ifNil: [ removable := true ]! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/24/2011 13:39'! removable: aBoolean removable := aBoolean! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/21/2011 15:32'! unregister GroupsManager unregister: self! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:28'! classes ^ self subclassResponsibility! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:26'! methods ^ self elements! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:38'! methodsFor: aClass ^ self methods select: [:e | e methodClass = aClass ].! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 16:57'! methodsFor: aClass categorised: aSymbol aSymbol ifNil: [ "all" ^ self methodsFor: aClass ]. ^ self methods select: [:e | e methodClass = aClass and: [ e category = aSymbol ]].! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:32'! protocolsFor: aClass ^ aClass protocols select: [:e | self methods anySatisfy: [:m | m category = e ]].! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/18/2011 16:57'! ifAllowed: aBlock ^ self ifAllowed: aBlock ifNot: []! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/18/2011 16:57'! ifAllowed: aBlock ifNot: anotherBlock ^ self isReadOnly ifTrue: anotherBlock ifFalse: aBlock! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/14/2012 12:17'! initialize super initialize. readOnly := false. self registerToAnnouncements.! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/24/2011 13:20'! sortBlock ^ sortBlock ifNil: [ sortBlock := [:a :b | a printString <= b printString ]]! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/24/2011 13:16'! sortBlock: aBlock sortBlock := aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractGroup class instanceVariableNames: ''! !AbstractGroup class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 3/18/2011 14:06'! named: aString ^ self new name: aString! ! !AbstractGroup class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 8/5/2012 15:56'! new | instance | instance := self basicNew initialize. GroupAnnouncer uniqueInstance announce: (AGroupHasBeenCreated group: instance). ^ instance! ! Announcement subclass: #AbstractGroupAnnouncement instanceVariableNames: 'group holder' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! group ^ group! ! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! group: anObject group := anObject! ! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! holder ^ holder! ! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! holder: anObject holder := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractGroupAnnouncement class instanceVariableNames: ''! !AbstractGroupAnnouncement class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 22:40'! group: aGroup ^ self new group: aGroup; yourself! ! !AbstractGroupAnnouncement class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 16:32'! group: aGroup from: anHolder ^ self new group: aGroup; holder: anHolder; yourself! ! Object subclass: #AbstractInstructionTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !AbstractInstructionTests commentStamp: 'BenjaminVanRyseghem 9/27/2011 14:04' prior: 0! Use for a test: ClosureCompilerTest>>#closureCases! !AbstractInstructionTests methodsFor: 'for test' stamp: 'BenjaminVanRyseghem 9/27/2011 14:07'! runBinaryConditionalJumps: anObject! ! AbstractNautilusPlugin subclass: #AbstractKeyPressedPlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractKeyPressedPlugin commentStamp: '' prior: 0! AbstractKeyPressedPlugin is an abstraction of plugin which react to key strokes ! !AbstractKeyPressedPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/4/2011 15:05'! keyPressed: anAnnouncement self subclassResponsibility! ! !AbstractKeyPressedPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 5/4/2011 15:12'! registerTo: aModel aModel announcer on: NautilusKeyPressed send: #keyPressed: to: self! ! TestCase subclass: #AbstractKeymappingTest instanceVariableNames: 'default' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character ^ self eventKey: character alt: false ctrl: false command: false shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character alt: aBoolean ^ self eventKey: character alt: aBoolean ctrl: false command: false shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character alt: useAlt ctrl: useCtrl command: useCommand shift: useShift | event modifier code | event := KeyboardEvent new. modifier := 0. useShift ifTrue: [ modifier := modifier + 8]. useCtrl ifTrue: [ modifier := modifier + 16]. useAlt ifTrue: [ modifier := modifier + 32]. useCommand ifTrue: [ modifier := modifier + 64]. code := character asInteger. event setType: #keystroke buttons: modifier position: 0@0 keyValue: code charCode: code hand: nil stamp: Time now. ^ event ! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:52'! eventKey: character command: aBoolean ^ self eventKey: character alt: false ctrl: false command: aBoolean shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character ctrl: aBoolean ^ self eventKey: character alt: false ctrl: aBoolean command: false shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:52'! eventKey: character shift: aBoolean ^ self eventKey: character alt: false ctrl: false command: false shift: aBoolean! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 2/19/2011 18:44'! setUp default := KMRepository default. KMRepository default: KMRepository new! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 2/19/2011 18:44'! tearDown KMRepository default: default! ! Object subclass: #AbstractMethodConverter instanceVariableNames: 'shouldShout method' classVariableNames: '' poolDictionaries: '' category: 'Tools-MethodConverters'! !AbstractMethodConverter commentStamp: '' prior: 0! An AbstractMessageConverter is a wrapper used to switch which information to retrieve from a method. This way, you can avoid switch case, you just have to use set the correct filter! !AbstractMethodConverter methodsFor: 'accessing'! method ^ method! ! !AbstractMethodConverter methodsFor: 'accessing'! method: aMessage method := aMessage! ! !AbstractMethodConverter methodsFor: 'initialization'! canCompile ^ false! ! !AbstractMethodConverter methodsFor: 'initialization'! handleStringSearch ^ true! ! !AbstractMethodConverter methodsFor: 'initialization'! shouldShout ^ false! ! !AbstractMethodConverter methodsFor: 'protocol'! getText method ifNil: [ ^ '' ]. ^ self internalGetText! ! !AbstractMethodConverter methodsFor: 'protocol'! getTextFor: aMethod method := aMethod. method ifNil: [ ^ '' ]. ^ self internalGetText! ! !AbstractMethodConverter methodsFor: 'private'! internalGetText ^ self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractMethodConverter class instanceVariableNames: ''! !AbstractMethodConverter class methodsFor: 'instance creation'! method: aMessage ^ self new method: aMessage; yourself! ! Object subclass: #AbstractMethodIconAction instanceVariableNames: 'method browser icon' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractMethodIconAction commentStamp: '' prior: 0! AbstractMethodIconAction is the common super class for all the method icon actions. A method icon action is used to retrieve the correct icon the method in nautilus lists! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:33'! browser ^ browser! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:33'! browser: aBrowser browser := aBrowser! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:34'! method ^ method! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:16'! method: aMethod method := aMethod! ! !AbstractMethodIconAction methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 1/2/2013 12:18'! iconClass ^ NautilusIcons! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:50'! actionIcon "Return the icon for this action" ^ icon := self privateActionIcon! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:24'! actionOrder "Return the priority of this action" ^ self subclassResponsibility! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:53'! actionStateToCache "Return the state of the icon for caching purpose" ^ IconicButtonStateHolder forNautilus: icon! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled "Return true if the provided method fits this action requirement" ^ self subclassResponsibility! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:50'! privateActionIcon ^ self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractMethodIconAction class instanceVariableNames: ''! !AbstractMethodIconAction class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/2/2013 12:34'! for: aMethod in: aBrowser ^ self new method: aMethod; browser: aBrowser; yourself! ! AbstractMethodConverter subclass: #AbstractMethodReferenceConverter instanceVariableNames: 'referencesList' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-MessageWrappers'! !AbstractMethodReferenceConverter methodsFor: 'accessing'! referencesList: aListOfReferences referencesList := aListOfReferences! ! !AbstractMethodReferenceConverter methodsFor: 'initialization'! initialize "Initialization code for VersionMessageConverter" super initialize. referencesList := #()! ! !AbstractMethodReferenceConverter methodsFor: 'private'! priorVersionOfAMethod: aMethodReference | tempList | tempList := referencesList select:[:each | (each className = aMethodReference className) & (each name = aMethodReference name)]. ^ tempList detect: [:each | (self versionOfAMethod: each) = ((self versionOfAMethod: aMethodReference) -1)] ifNone: [aMethodReference].! ! !AbstractMethodReferenceConverter methodsFor: 'private'! versionOfAMethod: aMethodReference | tempList | tempList := referencesList select: [:each | (each className = aMethodReference className) & (each name = aMethodReference name)]. tempList := tempList sort: [:m1 :m2 | m1 timeStamp < m2 timeStamp]. ^ tempList identityIndexOf: aMethodReference ifAbsent: [0]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractMethodReferenceConverter class instanceVariableNames: ''! !AbstractMethodReferenceConverter class methodsFor: 'as yet unclassified'! methodReference: aMessage referencesList: aListOfReferences ^ (super method: aMessage) referencesList: aListOfReferences; yourself! ! AbstractWidget subclass: #AbstractMethodWidget instanceVariableNames: '' classVariableNames: 'MethodsIconsCache' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractMethodWidget commentStamp: '' prior: 0! AbstractMethodWidget is an abstraction describing a widget used to manage methods! !AbstractMethodWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:33'! dragPassengersFor: item inMorph: dragSource | transferType object | (dragSource isKindOf: PluggableListMorph) ifFalse: [^ nil ]. transferType := self dragTransferTypeForMorph: dragSource. transferType == #getMethodItem: ifFalse: [ ^ nil ]. object := item originalObject. ^ self selectedMethods ifEmpty: [ (self getMethods includes: object) ifTrue: [ { object } ] ifFalse: [ "to test" self halt. ] ]! ! !AbstractMethodWidget methodsFor: 'icon'! buildUpAndDownArrowIcon: aMethod | container up down | container := Morph new. container extent: 12@12; color: Color transparent. up := IconicButton new target: self model; actionSelector: #arrowUp:; arguments: { aMethod }; labelGraphic: (self iconClass iconNamed: #arrowDoubleUp); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriden message'; borderWidth: 0. down := IconicButton new target: self model; actionSelector: #arrowDown:; arguments: { aMethod }; labelGraphic: (self iconClass iconNamed: #arrowDoubleDown); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriding messages'; borderWidth: 0. ^ (container changeTableLayout; listDirection: #topToBottom; addMorph: down; addMorph: up; yourself) -> {up. down}.! ! !AbstractMethodWidget methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 1/2/2013 13:10'! methodIconFor: aMethod | actions result button action | button := nil. MethodsIconsCache at: aMethod ifPresent: [:icon | icon isArray ifTrue: [ ^ self rebuildUpAndDownArrowIconFrom: icon]. icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIconTargetting: self model ]. actions := AbstractMethodIconAction allSubclasses collect: [:class | class for: aMethod in: self model ]. actions sort: [:a :b | a actionOrder < b actionOrder ]. action := actions detect: [:each | each isActionHandled ] ifNone: [ self flag: 'should never happend' ]. "actionIcon need to be invoked before actionStateToCache" button := action actionIcon. MethodsIconsCache at: aMethod put: action actionStateToCache. ^ button! ! !AbstractMethodWidget methodsFor: 'icon'! methodsIconsCache ^ MethodsIconsCache! ! !AbstractMethodWidget methodsFor: 'icon'! rebuildIconicButtonFrom: icon ^ IconicButton new target: self model; actionSelector: icon actionSelector; arguments: icon arguments; labelGraphic: icon labelGraphic; color: icon color; helpText: icon helpText; extent: icon extent; borderWidth: icon borderWidth! ! !AbstractMethodWidget methodsFor: 'icon'! rebuildUpAndDownArrowIconFrom: array | container up down | container := Morph new. container extent: 12@12; color: Color transparent. up := array first asIconTargetting: self model. down := array second asIconTargetting: self model. ^ container changeTableLayout; listDirection: #topToBottom; addMorph: down; addMorph: up; yourself! ! !AbstractMethodWidget methodsFor: 'initialize-release'! initialize super initialize. MethodsIconsCache ifNil: [ MethodsIconsCache := WeakIdentityKeyDictionary new ]! ! !AbstractMethodWidget methodsFor: 'items creation'! buildMethodsList ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 11:56'! deselectMethod: aMethod self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! elementsMenu: aMenuMorph shifted: aBoolean ^ self model elementsMenu: aMenuMorph shifted: aBoolean ! ! !AbstractMethodWidget methodsFor: 'protocol'! getMethods ^ self model getMethods! ! !AbstractMethodWidget methodsFor: 'protocol'! keyPressedOnElement: anEvent ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! label: aString ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! methodsSelection ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/17/2012 17:13'! okToChange ^ self model okToChange. ! ! !AbstractMethodWidget methodsFor: 'protocol'! removeAllFromMethodsIconsCache: aMethod ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 11:57'! selectMethod: aMethod self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! selectedMethod ^ self model selectedMethod! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 19:41'! selectedMethod: aMethod "I check if it's ok here to work better with the drag/drop mechanism" self model selectedMethod: aMethod! ! !AbstractMethodWidget methodsFor: 'protocol'! selectedMethods ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/4/2012 16:05'! setIcon: icon for: method MethodsIconsCache at: method put: icon! ! !AbstractMethodWidget methodsFor: 'protocol'! showInstance ^ self model showInstance! ! !AbstractMethodWidget methodsFor: 'protocol'! takeKeyboardFocus ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! vScrollValue ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! vScrollValue: aNumber ^ self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractMethodWidget class instanceVariableNames: ''! !AbstractMethodWidget class methodsFor: 'icon'! resetMethodsIconsCache MethodsIconsCache removeAll! ! Object subclass: #AbstractNautilusPlugin instanceVariableNames: 'model position' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractNautilusPlugin commentStamp: '' prior: 0! AbstractNautilusPlugin is an abstraction of what a plugin for Nautilus is. Mainly, it defines the protocol! !AbstractNautilusPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:43'! model ^ model! ! !AbstractNautilusPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:44'! model: anObject model := anObject. self registerTo: anObject! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/10/2011 16:13'! display " should answer a morphic object ready to be integrated into a NautilusWindow " ^ nil! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/2/2012 13:18'! name ^ self class name! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/25/2011 10:03'! position ^ position ifNil: [ position := self class defaultPosition ]! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/25/2011 09:49'! position: aPosition position := aPosition! ! !AbstractNautilusPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 5/4/2011 14:45'! registerTo: aModel self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractNautilusPlugin class instanceVariableNames: ''! !AbstractNautilusPlugin class methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/25/2011 14:18'! pluginName ^ self name! ! !AbstractNautilusPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:26'! description ^ 'No description available'! ! !AbstractNautilusPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 8/25/2011 09:39'! possiblePositions ^ { #top. #middle. #bottom. #none. }! ! !AbstractNautilusPlugin class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/4/2011 14:43'! model: aModel ^ self new model: aModel! ! !AbstractNautilusPlugin class methodsFor: 'position' stamp: 'SeanDeNigris 2/6/2013 12:04'! defaultPosition "Tells where in the Nautilus UI this plugin will appear. Pick an answer from #possiblePositions" ^ #none! ! AbstractTool subclass: #AbstractNautilusUI instanceVariableNames: 'model window hierarchyClass cachedHierarchy sourceTextArea firstColumn secondColumn groupsSelection packagesSelection classesSelection list list2 sourceCodePanel commentTextArea currentDisplayChoice sourceTextAreaLimit sourceCodeContainer list2Elements listElements shouldUpdateTitle testSemaphore sourceTextAreas multipleMethodsEditor contentSelection' classVariableNames: 'ClassesIconsCache GroupsIconsCache Icon NextFocusKey PackagesIconsCache PreviousFocusKey' poolDictionaries: '' category: 'Nautilus'! !AbstractNautilusUI commentStamp: '' prior: 0! An AbstractNautilusUI is an abstraction of the UI handling packages and classes. Instance Variables cachedHierarchy: classesSelection: commentButton: commentTextArea: currentDisplayChoice: firstColumn: groupsSelection: hierarchyClass: list: list2: model: packagesSelection: secondColumn: sourceCodeContainer: sourceCodePanel: sourceTextArea: sourceTextAreaLimit: window: ! !AbstractNautilusUI methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! guessTypeForName: aString ^ nil! ! !AbstractNautilusUI methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! receiverClass ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! selectedClassOrMetaClass ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'Shout'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ aPluggableShoutMorphOrView == sourceTextArea! ! !AbstractNautilusUI methodsFor: 'SmalltalkEditor compatibility'! selectedBehavior ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'accessing'! currentDisplayChoice ^ currentDisplayChoice ifNil: [ currentDisplayChoice := self sourceCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! currentDisplayChoice: aSymbol currentDisplayChoice := aSymbol. self changed: #showSource. self changed: #showByteCode. self changed: #showDecompile. self changed: #sourceCodeFrom:. self announce: (NautilusTextDisplayerChanged displayerSymbol: aSymbol)! ! !AbstractNautilusUI methodsFor: 'accessing'! groupsManager ^ self model groupsManager! ! !AbstractNautilusUI methodsFor: 'accessing'! hierarchyClass ^ hierarchyClass! ! !AbstractNautilusUI methodsFor: 'accessing'! hierarchyClass: aClass hierarchyClass := aClass. self setCachedHierarchyClass: aClass! ! !AbstractNautilusUI methodsFor: 'accessing'! model ^ model! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/20/2012 15:04'! model: anObject model := anObject. self registerToAnnouncements. model when: #historyChanged send: #historyChanged to: self. anObject selectedPackage ifNotNil: [:e | packagesSelection at: e put: true ]. anObject selectedGroup ifNotNil: [:p | groupsSelection at: p put: true ]. anObject selectedClass ifNotNil: [:p | classesSelection at: p put: true ].! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/23/2012 19:59'! selected | item | item := self ifGroups: [ self selectedGroup ] ifNot: [ self selectedPackage ]. ^self getList indexOf: item.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/23/2012 19:59'! selected2 | item | item := self selectedClass. self showInstance ifFalse: [ item ifNotNil: [item := item theNonMetaClass]]. ^self getList2 indexOf: item.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'CamilloBruni 10/4/2012 10:50'! selected2: anInteger | selection | selection := self getList2 at: anInteger ifAbsent: [nil]. self showInstance ifFalse: [selection ifNotNil: [selection := selection theMetaClass]]. self selectedClassWithoutChangingSelection: selection. self changed: #selected2. self changed: #currentHistoryIndex.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'CamilloBruni 10/4/2012 10:50'! selected: anInteger | selection | list2Elements := nil. selection := self getList at: anInteger ifAbsent: [nil]. self ifGroups: [ self selectedGroupWithoutChangingSelection: selection ] ifNot: [ self selectedPackageWithoutChangingSelection: selection ]. self changed: #selected. self changed: #currentHistoryIndex.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/18/2012 09:43'! selectedClass | class | class := self model selectedClass. (self model selectedCategory isNil and: [ self model selectedMethod isNil ]) ifTrue: [ self setStylerClass: nil ] ifFalse: [ self setStylerClass: class ]. ^ class! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/18/2012 09:28'! selectedClass: aClass self okToChangeBoth ifTrue: [ classesSelection removeAll. aClass ifNotNil: [ self giveFocusTo: list2 ]. self selectedClassWithoutChangingSelection: aClass. ]! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedClassWithoutChangingSelection: aClass ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedGroup ^ self model selectedGroup! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedGroup: anObject self okToChange ifTrue: [ groupsSelection removeAll. anObject ifNotNil: [ self giveFocusTo: list ]. groupsSelection at: anObject put: true. self selectedGroupWithoutChangingSelection: anObject ]! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedGroupWithoutChangingSelection: anObject self okToChange ifTrue: [ anObject ifNil: [ groupsSelection removeAll ]. self model selectedGroup: anObject. groupsSelection at: anObject put: true. self selectedClass: nil. self updateClassView ]! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedPackage ^ self model selectedPackage! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/23/2012 20:01'! selectedPackage: aPackage " Force package selection, not used by the lists " self okToChange ifTrue: [ packagesSelection removeAll. packagesSelection at: aPackage put: true. aPackage ifNotNil: [ self giveFocusTo: list ]. self selectedPackageWithoutChangingSelection: aPackage]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedPackageWithoutChangingSelection: aPackage self okToChange ifTrue: [| class | class := self selectedClass. (self showPackages and: [class notNil and: [class package ~= aPackage]]) ifTrue: [ self selectedClass: nil ]. self model package: aPackage class: self selectedClass category: nil method: nil. packagesSelection at: aPackage put: true. self updateClassView. self update. self changed: #getComments. self changed: #sourceCodeFrom:]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedPackageWithoutChangingSelectionInternally: aPackage self okToChange ifTrue: [| class | class := self selectedClass. (self showPackages and: [class notNil and: [class package ~= aPackage]]) ifTrue: [ self selectedClass: nil ]. packagesSelection at: aPackage put: true. aPackage ifNotNil: [ self giveFocusTo: list ]. self updateClassView. self update. self changed: #getComments. self changed: #sourceCodeFrom:]! ! !AbstractNautilusUI methodsFor: 'accessing'! showComment ^ self model showComment! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:48'! showComment: aBoolean self okToChangeComment ifFalse: [ ^ self ]. self model showComment: aBoolean. self updateCodePanel! ! !AbstractNautilusUI methodsFor: 'accessing'! showGroups ^ self model showGroups! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/6/2013 17:43'! showGroups: aBoolean self okToChange ifFalse: [ ^ self ]. self setShortcuts: #NautilusClassShortcuts to: list2. aBoolean ifTrue: [ list enabled: true. self removeShortcuts: #NautilusPackageShortcuts from: list. self setShortcuts: #NautilusGroupShortcuts to: list ] ifFalse: [ self removeShortcuts: #NautilusGroupShortcuts from: list. self setShortcuts: #NautilusPackageShortcuts to: list ]. listElements := nil. self showPackages ifFalse: [ self showPackagesSilently: true ]. self selectedGroup ifNil: [ self selectedClass: nil ] ifNotNil: [:group | (group elements includes: self selectedClass) ifFalse: [ list2Elements := nil. self selectedClass: nil ]. aBoolean ifTrue: [ groupsSelection at: group put: true ] ifFalse: [ packagesSelection at: self selectedPackage put: true ]]. self model showGroups: aBoolean. self changed: #groupsButtonLabel. self changed: #toggleButtonLabel. self changedLabels. self updateBothView! ! !AbstractNautilusUI methodsFor: 'accessing'! showGroupsSilently: aBoolean self model showGroups: aBoolean! ! !AbstractNautilusUI methodsFor: 'accessing'! showHierarchy ^ self model showHierarchy! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 16:42'! showHierarchy: aBoolean self model showHierarchy: aBoolean. listElements := nil. list2Elements := nil. aBoolean ifTrue: [ self hierarchyClass: self selectedClass ]. self updateBothView! ! !AbstractNautilusUI methodsFor: 'accessing'! showInstance ^ self model showInstance! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/5/2013 14:27'! showInstance: aBoolean self okToChange ifTrue:[ self model showInstance: aBoolean. classesSelection removeAll. self selectedClass ifNotNil: [:class | aBoolean ifTrue: [self selectedClass: class theNonMetaClass ] ifFalse: [self selectedClass: class theMetaClass ]]. self update. self changed: #instanceButtonState. self changed: #instanceButtonLabel ]! ! !AbstractNautilusUI methodsFor: 'accessing'! showPackages ^ self model showPackages! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 17:32'! showPackages: aBoolean self okToChange ifTrue: [ listElements := nil. list2Elements := nil. list enabled: aBoolean. aBoolean ifFalse: [| class | class := self selectedClass theNonMetaClass. classesSelection at: class put: true. self hierarchyClass: class . listElements := nil. list2Elements := nil. self showGroups ifTrue: [self showGroupsSilently: false]]. listElements := nil. list2Elements := nil. self model showPackages: aBoolean. self changed: #groupsButtonLabel. self updateBothView. self changed: #toggleButtonState. self changed: #toggleButtonLabel. self changedLabels ]! ! !AbstractNautilusUI methodsFor: 'accessing'! showPackagesSilently: aBoolean self model showPackages: aBoolean.! ! !AbstractNautilusUI methodsFor: 'accessing'! sourceCodeContainer ^ sourceCodeContainer! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/14/2012 17:33'! sourceCodePanel ^ sourceCodePanel! ! !AbstractNautilusUI methodsFor: 'accessing'! sourceTextArea ^ sourceTextArea! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/1/2012 19:46'! toggleShowComment self showComment: self showComment not. self changed: #commentButtonState! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'StephaneDucasse 12/19/2012 16:04'! toggleShowFullComment self showComment ifFalse: [ ^ self ]. sourceCodePanel removeAllMorphs. sourceCodePanel addMorph: self commentTextArea fullFrame: LayoutFrame identity! ! !AbstractNautilusUI methodsFor: 'accessing'! toggleShowGroups self showGroups: self showGroups not.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 16:42'! toggleShowHierarchy self showHierarchy: self showHierarchy not. ! ! !AbstractNautilusUI methodsFor: 'accessing'! toggleShowInstance ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'accessing'! toggleShowPackages self showPackages: self showPackages not.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:48'! updateCodePanel commentTextArea ifNil: [ self buildCommentPane ]. sourceCodePanel removeAllMorphs. self model showComment ifTrue: [ self buildCodePanelWithComment ] ifFalse: [ self buildCodePanelWithoutComment ]! ! !AbstractNautilusUI methodsFor: 'accessing'! window ^ window! ! !AbstractNautilusUI methodsFor: 'accessing'! window: anObject window := anObject! ! !AbstractNautilusUI methodsFor: 'annotation pane'! annotationSeparator "Answer the separator to be used between annotations" ^ ' · '! ! !AbstractNautilusUI methodsFor: 'annotation pane'! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! !AbstractNautilusUI methodsFor: 'announcement registration'! announce: anAnnouncement ^ self model announce: anAnnouncement! ! !AbstractNautilusUI methodsFor: 'announcement registration'! announcer ^ self model announcer! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:19'! registerToAnnouncements self registerToSystemAnnouncements. (Smalltalk at: #TestAnnouncer ifPresent: [ self registerToTestAnnouncements ]). self registerToMCAnnouncements. self registerToGroupAnnouncements. ! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:19'! registerToGroupAnnouncements GroupAnnouncer uniqueInstance weak on: AGroupHasBeenRegistered send: #aGroupHasBeenRegistered: to: self; on: AGroupHasBeenUnregistered send: #aGroupHasBeenUnregistered to: self; on: AGroupHasBeenAdded send: #aGroupHasBeenAdded: to: self; on: AGroupHasBeenRemoved send: #aGroupHasBeenRemoved: to: self; on: AGroupHasBeenRenamed send: #aGroupHasBeenRenamed: to: self! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:19'! registerToMCAnnouncements SystemAnnouncer uniqueInstance weak on: MCVersionCreated send: #newMCVersion: to: self; on: MCPackageModified send: #mcPackageModified: to: self; on: MCWorkingCopyCreated send: #mcWorkingCopyCreated: to: self; on: MCWorkingCopyDeleted send: #mcWorkingCopyDeleted: to: self. ! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'BenjaminVanRyseghem 12/20/2012 15:05'! registerToSystemAnnouncements self browsedEnvironment packageOrganizer announcer weak on: RPackageCreated send: #packageCreated: to: self; on: RPackageUnregistered send: #packageUnregistred: to: self; on: RPackageRenamed send: #packageRenamed: to: self. SystemAnnouncer uniqueInstance weak on: ClassAdded send: #classAdded: to: self; on: ClassCommented send: #classCommented: to: self; on: ClassRecategorized send: #classRecategorized: to: self; on: ClassModifiedClassDefinition send: #classDefinitionModified: to: self; on: ClassRemoved send: #classRemoved: to: self; on: ClassRenamed send: #classRenamed: to: self; on: ClassReorganized send: #classReorganized: to: self; on: MethodAdded send: #methodAdded: to: self; on: MethodModified send: #methodModified: to: self; on: MethodRecategorized send: #methodRecategorized: to: self; on: MethodRemoved send: #methodRemoved: to: self; on: ProtocolAdded send: #classRecategorized: to: self; on: ProtocolRemoved send: #classRecategorized: to: self. ! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:20'! registerToTestAnnouncements "Since Test classes can be absent (in production, for instance, I use non-global references)" (Smalltalk at: #TestAnnouncer) uniqueInstance weak on: (Smalltalk at: #TestCaseStarted) send: #testCaseStarted: to: self; on: (Smalltalk at: #TestSuiteEnded) send: #testRunned: to: self.! ! !AbstractNautilusUI methodsFor: 'announcement registration'! unregisterAPlugin: aPlugin self announcer unsubscribe: aPlugin! ! !AbstractNautilusUI methodsFor: 'announcement registration'! unregisterAllPlugins self announcer subscriptions reset! ! !AbstractNautilusUI methodsFor: 'browser compatibility'! codeTextMorph ^ sourceTextArea! ! !AbstractNautilusUI methodsFor: 'browser compatibility'! sourceCode: aText self okToChange ifTrue: [ sourceTextArea setText: aText. sourceTextArea takeKeyboardFocus ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! commentButtonAction self toggleShowComment.! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! commentButtonLabel ^ self commentLabel! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! commentButtonState ^ self showComment! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! groupsButtonAction self toggleShowGroups! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! groupsButtonLabel ^ self showGroups ifTrue: [ self packageLabel ] ifFalse: [ self groupsLabel ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! groupsButtonState ^ false! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! instanceButtonAction self toggleShowInstance! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'EstebanLorenzano 1/25/2013 18:22'! instanceButtonLabel | hasMethods label | hasMethods := false. self selectedClass ifNotNil: [:class | hasMethods := class theMetaClass methodDict notEmpty ]. label := 'Class side' asMorph. hasMethods ifTrue: [ label emphasis: 1 ] ifFalse: [ label emphasis: 2 ]. ^ label! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 12/20/2012 12:40'! instanceButtonState ^ "false" self showInstance not! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! showDecompile ^ self currentDisplayChoice = self decompileSymbol! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! switchToByteCodeButton self okToChange ifTrue: [ self currentDisplayChoice: self byteCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! switchToDecompileButton self okToChange ifTrue: [ self currentDisplayChoice: self decompileSymbol ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! switchToSourceCodeButton self okToChange ifTrue: [ self currentDisplayChoice: self sourceCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonAction self toggleButtonEnabled ifTrue: [ self toggleShowPackages. self changed: #toggleButtonEnabled. ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonEnabled ^ (self selectedClass ~~ nil or: [ self showPackages not ])! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonLabel ^ self showPackages ifTrue: [ 'Hierarchy' ] ifFalse: [ 'Flat' ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonState ^ self showPackages not! ! !AbstractNautilusUI methodsFor: 'code panel'! buildCodePanelWithComment self model commentPosition == #right ifTrue: [ self buildCodePanelWithCommentOnRight ]. self model commentPosition == #bottom ifTrue: [ self buildCodePanelWithCommentOnBottom ]. self model commentPosition == #left ifTrue: [ self buildCodePanelWithCommentOnLeft ]. self model commentPosition == #top ifTrue: [ self buildCodePanelWithCommentOnTop ].! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:47'! buildCodePanelWithCommentOnBottom | splitter delta | splitter := ProportionalSplitterMorph new beSplitsTopAndBottom. delta := 2. splitter addLeftOrTop: multipleMethodsEditor. splitter addRightOrBottom: commentTextArea. sourceCodePanel addMorph: multipleMethodsEditor fullFrame: ( (0@0 corner: 1@0.5) asLayoutFrame bottomOffset: delta negated). sourceCodePanel addMorph: splitter fullFrame: ( (0@0.5 corner: 1@0.5) asLayoutFrame topLeftOffset: 0@(delta negated) ; bottomRightOffset: 0@delta). sourceCodePanel addMorph: commentTextArea fullFrame: ( (0@0.5 corner: 1@1) asLayoutFrame topLeftOffset: (0@delta)).! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:49'! buildCodePanelWithCommentOnLeft | splitter delta | splitter := ProportionalSplitterMorph new. delta := 2. splitter addLeftOrTop: commentTextArea. splitter addRightOrBottom: multipleMethodsEditor. sourceCodePanel addMorph: commentTextArea fullFrame: ( (0@0 corner: 0.5@1) asLayoutFrame bottomRightOffset: (delta negated)@0). sourceCodePanel addMorph: splitter fullFrame: ((0.5@0 corner: 0.5@1) asLayoutFrame topLeftOffset: (delta negated)@0; bottomRightOffset: delta@0). sourceCodePanel addMorph: multipleMethodsEditor fullFrame: ( (0.5@0 corner: 1@1) asLayoutFrame topLeftOffset: (delta@0)).! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:53'! buildCodePanelWithCommentOnRight | splitter delta | splitter := ProportionalSplitterMorph new. delta := 2. splitter addLeftOrTop: multipleMethodsEditor. splitter addRightOrBottom: commentTextArea. sourceCodePanel addMorph: multipleMethodsEditor fullFrame: ( (0@0 corner: 0.5@1) asLayoutFrame bottomRightOffset: (delta negated)@0). sourceCodePanel addMorph: splitter fullFrame: ( (0.5@0 corner: 0.5@1) asLayoutFrame topLeftOffset: (delta negated)@0 ; bottomRightOffset: delta@0). sourceCodePanel addMorph: commentTextArea fullFrame: ( (0.5@0 corner: 1@1) asLayoutFrame topLeftOffset: delta@0 ; bottomRightOffset: 0@0).! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:54'! buildCodePanelWithCommentOnTop | splitter delta | splitter := ProportionalSplitterMorph new beSplitsTopAndBottom. delta := 2. splitter addLeftOrTop: commentTextArea. splitter addRightOrBottom: multipleMethodsEditor. sourceCodePanel addMorph: commentTextArea fullFrame: ( (0@0 corner: 1@0.5) asLayoutFrame bottomRightOffset: 0@(delta negated)). sourceCodePanel addMorph: splitter fullFrame: ( (0@0.5 corner: 1@0.5) asLayoutFrame topLeftOffset: 0@(delta negated) ; bottomRightOffset: 0@delta). sourceCodePanel addMorph: multipleMethodsEditor fullFrame: ((0@0.5 corner: 1@1) asLayoutFrame topLeftOffset: (0@delta )).! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:56'! buildCodePanelWithoutComment sourceCodePanel addMorph: multipleMethodsEditor fullFrame: LayoutFrame identity! ! !AbstractNautilusUI methodsFor: 'dispatch' stamp: 'CamilloBruni 10/7/2012 23:27'! basicRenameClass: aClass self renameClass: aClass! ! !AbstractNautilusUI methodsFor: 'displaying'! addAll: aWindow self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'EstebanLorenzano 2/6/2013 17:34'! buildFirstColumn: aWindow | buttons | buttons := PanelMorph new. self setShortcuts: #NautilusPackageShortcuts to: buttons. buttons changeProportionalLayout; addMorph: self buildGroupsButton fullFrame: ( ( 0@0 corner: 0.5@0 ) asLayoutFrame bottomRightOffset: (-2)@25 ); addMorph: self buildToggleButton fullFrame: (( 0.5@0 corner: 1@0 ) asLayoutFrame topLeftOffset: 2@0 ; bottomRightOffset: 0@25 ); hResizing: #spaceFill; vResizing: #rigid; height: 25; yourself. ^ firstColumn := PanelMorph new changeProportionalLayout; addMorph: self buildList fullFrame: ( LayoutFrame identity bottomOffset: -25); addMorph: buttons fullFrame: ( (0@1 corner: 1@1 ) asLayoutFrame topOffset: -25); hResizing: #spaceFill; vResizing: #spaceFill; yourself.! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'StephaneDucasse 12/19/2012 16:04'! buildSecondColumn: aWindow | buttons | buttons := PanelMorph new. buttons changeProportionalLayout; addMorph: self buildInstanceButton fullFrame: ( (0@0 corner: 0.5@0 ) asLayoutFrame bottomRightOffset: -2@25 ); addMorph: self buildCommentButton fullFrame: (( 0.5@0 corner: 1@0 ) asLayoutFrame topLeftOffset: 2@0 ; bottomRightOffset: 0@25 ); hResizing: #spaceFill; vResizing: #rigid; height: 25; yourself. ^ secondColumn := PanelMorph new changeProportionalLayout; addMorph: self buildList2 fullFrame: (LayoutFrame identity bottomOffset: -25); addMorph: buttons fullFrame: ( (0@1 corner: 1@1 ) asLayoutFrame topOffset: -25); hResizing: #spaceFill; vResizing: #spaceFill; yourself.! ! !AbstractNautilusUI methodsFor: 'displaying'! buildTextAreaButtonsColumn: aWindow | column | column := PanelMorph new. column changeTableLayout; listDirection: #topToBottom. { self buildSwitchToSourceCodeButton. self buildSwitchToByteCodeButton. self buildSwitchToDecompileButton. self buildSeparator. self buildBrowseInstVarsButton. self buildBrowseClassVarsButton} reverse do: [:each | column addMorph: each ]. column vResizing: #spaceFill; width: 24; hResizing: #rigid. ^ column! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'CamilloBruni 9/21/2012 13:47'! close window close! ! !AbstractNautilusUI methodsFor: 'displaying'! newGroupBoxMorph | morph | morph := GroupboxMorph new. morph contentMorph layoutInset: (0@0 corner: 0@0); cellInset: 0. ^ morph! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! open window := NautilusWindow new model: self. self addAll: window. window openInWorld. self changed:#sourceCodeFrom:. self setWindowTitle.! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 8/3/2012 16:18'! setWindowTitle | title | shouldUpdateTitle ifFalse: [ ^ self ]. title := self selectedClass ifNil: [ self selectedPackage ifNil: [ self title ] ifNotNil: [: p | p name ]] ifNotNil: [:class | self selectedMethod ifNil: [ class name asString ] ifNotNil: [:method | String streamContents: [:s | s << method methodClass name asString<< '>>#'<< method selector ]]]. self browsedEnvironment isSystem ifFalse: [ title := String streamContents: [:s | s << '--- ' << title << ' ---']]. window title: title.! ! !AbstractNautilusUI methodsFor: 'displaying'! taskbarIcon ^ self class icon! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 7/13/2012 14:32'! dragPassengersFor: item inMorph: dragSource | transferType object | object := item originalObject. (dragSource isKindOf: PluggableListMorph) ifFalse: [^ nil ]. transferType := self dragTransferTypeForMorph: dragSource. transferType == #getCategoryItem: ifTrue: [ ^ self selectedCategories ifEmpty: [ { object } ] ]. transferType == #listElement2: ifTrue: [ self showGroups ifTrue: [ self selectedGroup ifNil: [ ^ nil ] ifNotNil: [:g | g isFillable ifFalse: [ ^ nil ]]]. ^ self selectedClasses ifEmpty: [ { object } ]]. transferType == #getMethodItem: ifFalse: [ ^ nil ]. ^ self selectedMethods ifEmpty: [ (self getMethods includes: object) ifTrue: [{ object }] ifFalse: [ nil ]]! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:28'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [ dragSource getListElementSelector ]! ! !AbstractNautilusUI methodsFor: 'drag and drop'! dropInAClass: aCollection into: aClass aCollection do: [:anObject | (anObject isBehavior) ifFalse: [ (anObject isString or: [ anObject isSymbol ]) ifTrue: ["category" ActiveHand shiftPressed ifTrue: [ self copyCategory: anObject toTheClass: aClass ] ifFalse: [ self moveCategory: anObject toTheClass: aClass ]] ifFalse: [ "a method" ActiveHand shiftPressed ifTrue: [ self copyMethod: anObject toTheClass: aClass ] ifFalse: [ self moveMethod: anObject toTheClass: aClass autoRemove: false ]]]]! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 7/13/2012 14:38'! dropInAPackage: aCollection into: receiver aCollection do:[:aClass | self showGroups ifTrue: [ receiver addClasses: { aClass }. ActiveHand shiftPressed ifFalse: [ self selectedGroup removeClass: aClass. self updateClassView ]] ifFalse: [ aClass theNonMetaClass category: receiver name. ActiveHand shiftPressed ifTrue: [ self selectedClass: nil. self updateClassView ] ifFalse:[ self selectedPackage: receiver. self selectedClass: aClass. self updateBothView ]]]! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 4/14/2012 13:31'! dropInList2: aCollection inARow: aRow | receiver | receiver := self getList2 at: aRow. self showInstance not ifTrue: [ receiver := receiver theMetaClass ] ifFalse: [ receiver := receiver theNonMetaClass ]. self dropInAClass: aCollection into: receiver! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 3/23/2012 19:55'! dropInList: aCollection inARow: aRow | receiver | (aRow = 0) ifTrue: [ ^ self ]. receiver := self getList at: aRow. ( receiver isKindOf: Class ) ifTrue: [ self selectedClass isMeta ifTrue: [ receiver := receiver theMetaClass ] ifFalse: [ receiver := receiver theNonMetaClass ]]. self dropInAPackage: aCollection into: receiver! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:33'! wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM "We are only interested in TransferMorphs as wrappers for informations. If their content is really interesting for us, will determined later in >>acceptDroppingMorph:event:." | srcType dstType | "only want drops on lists (not, for example, on pluggable texts)" (destinationLM isKindOf: PluggableListMorph) ifFalse: [^ false]. srcType := transferMorph dragTransferType. dstType := self dragTransferTypeForMorph: destinationLM. srcType == #getMethodItem: ifTrue: [ ^ (dstType == #getCategoryItem: or: [ dstType == #listElement2: ])]. srcType == #getCategoryItem: ifTrue: [ ^ dstType == #listElement2: ]. (srcType == #listElement2: and: [ dstType = #listElement: ]) ifTrue: [ (destinationLM potentialDropItem isKindOf: PluggableListMorph) ifTrue: [ ^ true ]. self showGroups ifTrue: [ | receiver | receiver := destinationLM potentialDropItem originalObject. ^ receiver isFillable ] ifFalse: [ ^ true ]] ifFalse:[ ^ false ]. ^ false! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 3/23/2012 19:20'! doubleClick self ifGroups: [ self doubleClickOnGroup ] ifNot: [ self doubleClickOnPackage ]! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 3/23/2012 19:21'! doubleClick2 self doubleClickOnClass! ! !AbstractNautilusUI methodsFor: 'events handling'! doubleClickOnClass self selectedClass ifNil: [ ^ self ] ifNotNil: [:class | self showGroups ifTrue: [ self model class openOnClass: class onGroup: self selectedGroup ] ifFalse: [ self model class openOnClass: class ]]! ! !AbstractNautilusUI methodsFor: 'events handling'! doubleClickOnGroup self selectedGroup ifNil: [ ^self ] ifNotNil:[:group | self model class openOnGroup: group ]! ! !AbstractNautilusUI methodsFor: 'events handling'! doubleClickOnPackage self selectedPackage ifNil: [ ^ self ] ifNotNil:[:package | self model class openOnPackage: package ]! ! !AbstractNautilusUI methodsFor: 'events handling'! keyPressedOnElement: anEvent ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2013 18:59'! listMouseDown: anEvent self showPackages ifFalse: [ self showPackages: true. list mouseDown: anEvent ]. ! ! !AbstractNautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 17:57'! giveFocusToPackage self giveFocusTo: list! ! !AbstractNautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 18:01'! giveFocusToSourceCode self giveFocusTo: sourceTextArea ! ! !AbstractNautilusUI methodsFor: 'group'! addClassesInGroup self selectedClasses ifNotNil: [:classes | self addClassesInGroup: classes ].! ! !AbstractNautilusUI methodsFor: 'group'! addClassesInGroup: aCollection (DialogGroupAdder new groups: self groupsManager; elementsToAdd: ((aCollection collect: #theNonMetaClass) asSet asArray sort: [:a :b | a name < b name])) open! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 18:19'! addMatchingPackagesInGroups self selectedPackage ifNotNil: [:package || separatorIndex firstPartOfTheName packages | separatorIndex := package name indexOf: $- ifAbsent: [ package name size + 1]. firstPartOfTheName := package name copyFrom: 1 to: (separatorIndex - 1) . packages := self model packages select: [:each | each name beginsWith: firstPartOfTheName ]. [ ^ self addPackagesAsGroups: packages ] on: GroupsAlreadyExists do: [:ex | self alertGroupExisting: ex groupName. ^ nil ]]. ^ nil! ! !AbstractNautilusUI methodsFor: 'group'! addMatchingPackagesInGroupsAndBrowse ( self addMatchingPackagesInGroups ) ifNotNil: [:group | self selectedGroup: group. self showGroups: true]! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 21:03'! addNewGroup [ self groupsManager createAnEmptyStaticGroup ] on: GroupAlreadyExists do:[ :ex | self alertGroupExisting: ex ]! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 18:06'! addPackageAsGroup ^ [ self addPackagesAsGroup: self selectedPackages ] on: GroupAlreadyExists do: [:ex | self alertGroupExisting: ex groupName. ^ nil ]! ! !AbstractNautilusUI methodsFor: 'group'! addPackageAsGroupAndBrowse self addPackageAsGroup ifNotNil: [:group | self selectedGroup: group. self showGroups: true] ifNil: [ | group | group := self model class groupsManager groups detect: [:each | each name = self selectedPackage name] ifNone: [ nil ]. group ifNotNil: [ self selectedGroup: group. self showGroups: true ]]! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 18:17'! addPackagesAsGroups [ self addPackagesAsGroups: self selectedPackages ] on: GroupAlreadyExists do: [:ex | self alertGroupExisting: ex groupName ]! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/6/2012 16:45'! addPackagesAsGroupsAndBrowse (self addPackagesAsGroups: self selectedPackages) ifNotNil: [:group | self selectedGroup: group. self showGroups: true]! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/6/2012 16:45'! addPackagesInGroup self addPackagesInGroup: self selectedPackages! ! !AbstractNautilusUI methodsFor: 'group'! addPackagesInGroup: aCollection aCollection ifNotEmpty: [:packages || classes | classes := packages gather: [:package | package classes ]. (DialogGroupAdder new groups: self groupsManager; elementsToAdd: (self model classes intersection: classes)) open]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenAdded: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenRegistered: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenRemoved: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. (self groupsManager = anAnnouncement holder) ifTrue: [ self selectedGroup = anAnnouncement group ifTrue: [ self selectedGroup: nil ]. self updateGroupView. self update ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenRenamed: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenUnregistered: anAnnouncement | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 2/16/2013 00:29'! classIconFor: aClass ClassesIconsCache at: aClass ifPresent: [:icon | icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIconTargetting: self ]. ((aClass includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ])) and: [ aClass isAbstract not ]) ifTrue: [ | icon button | icon := self iconClass iconNamed: #testNotRun. aClass hasPassedTest ifTrue: [ icon := self iconClass iconNamed: #testGreen ]. aClass hasFailedTest ifTrue: [ icon := self iconClass iconNamed: #testYellow ]. aClass hasErrorTest ifTrue: [ icon := self iconClass iconNamed: #testRed ]. button := IconicButton new target: self; actionSelector: #runTestsOfClass:notifying:; arguments: { aClass. true }; labelGraphic: icon ; color: Color transparent; extent: 12 @ 12; helpText: 'Run the tests'; borderWidth: 0. ClassesIconsCache at: aClass put: (IconicButtonStateHolder forNautilus: button). ^ button ] ifFalse: [ (aClass organization classComment isEmpty and: [ Nautilus emptyCommentWarning ]) ifTrue: [| button | button := IconicButton new target: self; actionSelector: #openCommentEditor:; arguments: { aClass }; labelGraphic: (self iconClass iconNamed: #uncommentedClass) ; color: Color transparent; extent: 12 @ 12; helpText:'Edit the comment'; borderWidth: 0. ClassesIconsCache at: aClass put: (IconicButtonStateHolder forNautilus: button). ^ button ]]. ^ ClassesIconsCache at: aClass put: (aClass nautilusIcon)! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'CamilloBruni 10/7/2012 22:04'! groupIconFor: aGroup | icon | GroupsIconsCache at: aGroup ifPresent: [:ic | ic class == IconicButtonStateHolder ifFalse: [ ^ ic ]. ^ ic asIconTargetting: self ]. icon := IconicButton new target: self; actionSelector: #restrictedBrowseGroups:; arguments: {{aGroup}}; labelGraphic: (self iconClass iconNamed: #groupIcon); color: Color transparent; extent: 15 @ 16; helpText: 'Browse restricted environment'; borderWidth: 0. GroupsIconsCache at: aGroup put: (IconicButtonStateHolder forNautilus: icon). ^ icon! ! !AbstractNautilusUI methodsFor: 'icon'! iconClass ^ self class iconClass! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 3/23/2012 19:17'! listIcon2: anItem ^ self classIconFor: anItem " ^ self ifPackages: [ self classIconFor: anItem ] ifClasses: [ self packageIconFor: anItem ]"! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 3/23/2012 19:16'! listIcon: anItem " I return the icon corresponding to anItem in the leftmost list " ^ self showGroups ifTrue: [ self groupIconFor: anItem ] ifFalse: [ " if I do not show groups, I have to know if I show packages or classes " self packageIconFor: anItem" self ifPackages: [ self packageIconFor: anItem ] ifClasses: [ self classIconFor: anItem ]"]! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 2/8/2013 16:43'! packageIconFor: aPackage | mcpackage | PackagesIconsCache at: aPackage ifPresent: [:icon | icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIconTargetting: self ]. aPackage classes isEmpty ifTrue: [^ PackagesIconsCache at: aPackage put: (self iconClass iconNamed: #emptyPackageIcon) ]. mcpackage := (NautilusMCBindings default mcPackageFor: aPackage). (mcpackage notNil and: [ mcpackage isDirty ]) ifTrue: [ | icon | icon := IconicButton new target: self; actionSelector: #saveDirtyPackages:; arguments: {{ aPackage }}; labelGraphic: (aPackage definedClasses ifEmpty: [ (self iconClass iconNamed: #dirtyMonticelloPackageIcon) ] ifNotEmpty: [ (self iconClass iconNamed: #dirtyPackageIcon) ]); color: Color transparent; extent: 15 @ 16; helpText: 'Save the package'; borderWidth: 0. PackagesIconsCache at: aPackage put: (IconicButtonStateHolder forNautilus: icon). ^ icon ]. (mcpackage notNil and: [(mcpackage name = aPackage name ) and: [ aPackage definedClasses isEmpty]]) ifTrue: [ ^ PackagesIconsCache at: aPackage put: (self iconClass iconNamed: #monticelloPackage) ]. ^ PackagesIconsCache at: aPackage put: (self iconClass iconNamed: #packageIcon)! ! !AbstractNautilusUI methodsFor: 'icon'! rebuildIconicButtonFrom: icon ^ IconicButton new target: self; actionSelector: icon actionSelector; arguments: icon arguments; labelGraphic: icon labelGraphic; color: icon color; helpText: icon helpText; extent: icon extent; borderWidth: icon borderWidth! ! !AbstractNautilusUI methodsFor: 'icon caches'! methodsIconsCache ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeClassFromMethodsIconsCache: aClass self methodsIconsCache keys do: [:method | " for overrides " method methodClass = aClass ifTrue: [ self removeFromClassesIconsCache: aClass. self methodsIconsCache removeKey: method ifAbsent: [ ]]].! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeFromClassesIconsCache: aClass " not used since the class's icons are always the same " ClassesIconsCache removeKey: aClass ifAbsent: []. self updateClassView.! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeFromGroupsIconsCache: aClass " not used since the groups's icons are always the same " GroupsIconsCache removeKey: aClass ifAbsent: [].! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeFromMethodsIconsCache: aMethod " if a test method has changed, we should reset the correspondng method " | corresponding | corresponding := aMethod correspondingMethods. corresponding do: [:each | self methodsIconsCache removeKey: each ifAbsent: []]. self removeFromClassesIconsCache: aMethod methodClass. self methodsIconsCache removeKey: aMethod ifAbsent: [ ].! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeFromPackagesIconsCache: aPackage PackagesIconsCache removeKey: aPackage ifAbsent: [].! ! !AbstractNautilusUI methodsFor: 'icons behavior'! arrowDown: aMethod | methods methodsNames index | methods := aMethod methodClass allSubclasses gather: [:each | each methodDict values ]. methods := methods select: [:each | each selector = aMethod selector ]. methods size = 1 ifTrue: [ ^ self model class openOnMethod: methods first ]. methodsNames := methods collect: [:each | each methodClass name, '>>#', each selector ]. index := UIManager default chooseFrom: methodsNames. index = 0 ifTrue: [ ^ self ]. ^ self model class openOnMethod: (methods at: index) ! ! !AbstractNautilusUI methodsFor: 'icons behavior'! arrowUp: aMethod | newMethod | newMethod := aMethod methodClass superclass lookupSelector: aMethod selector. self model class openOnMethod: newMethod! ! !AbstractNautilusUI methodsFor: 'icons behavior'! openCommentEditor: aClass | newComment | newComment :=UITheme current textEditorIn: window text: 'Enter a comment for the class ', aClass theNonMetaClass name,':' title: 'Comment Editor' entryText: aClass theNonMetaClass comment entryHeight: 300. newComment ifNotNil: [ aClass theNonMetaClass comment: newComment asString ]! ! !AbstractNautilusUI methodsFor: 'icons behavior'! runClassTests self runClassTests: self selectedClasses notifying: true! ! !AbstractNautilusUI methodsFor: 'icons behavior'! runTestForAMethod: aMethod notifying: anObject ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'icons behavior'! saveDirtyPackages: aCollection aCollection isEmptyOrNil ifTrue: [ ^ self ]. aCollection do: [:package || workCopy browser wrap index | workCopy := MCWorkingCopy forPackage: (MCPackage named: package name). browser :=MCWorkingCopyBrowser new. browser show; workingCopy: workCopy. "wrap := MCDependentsWrapper with: workCopy model: browser. self halt. index := browser workingCopySelectionWrapper: wrap. browser workingCopyTreeMorph selectionIndex: index"] ! ! !AbstractNautilusUI methodsFor: 'items creation'! buildBrowseClassVarsButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: #browseClassVars; stateSelector: #isAClassSelected ; onImage: (self iconClass iconNamed: #classVarsSelectedIcon); offImage: (self iconClass iconNamed: #classVarsUnselectedIcon); pressedImage: (self iconClass iconNamed: #classVarsPressedIcon); extent: 24@24; helpText: 'Show class variables'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation'! buildBrowseInstVarsButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: #browseInstVars; stateSelector: #isAClassSelected ; onImage: (self iconClass iconNamed: #instVarsSelectedIcon); offImage: (self iconClass iconNamed: #instVarsUnselectedIcon); pressedImage: (self iconClass iconNamed: #instVarsPressedIcon); extent: 24@24; helpText: 'Show instance variables'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/6/2012 00:52'! buildCodePane "The following method fills up sourceTextArea variable" self buildNewSourceTextArea. multipleMethodsEditor := MultipleMethodsEditor new. multipleMethodsEditor hResizing: #spaceFill; vResizing: #spaceFill; addEditor: sourceTextArea. ^ multipleMethodsEditor! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'EstebanLorenzano 1/30/2013 14:40'! buildCommentButton | button | button := (PluggableButtonMorph on: self getState: #commentButtonState action: #commentButtonAction label: #commentButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap. self setShortcuts: #NautilusCommentShortcuts to: button. button submorphs first on: #doubleClick send: #toggleShowFullComment to: self; on: #mouseDown send: #mouseDown: to: button; on: #mouseMove send: #mouseMove: to: button; on: #mouseEnter send: #mouseEnter: to: button; on: #mouseLeave send: #mouseLeave: to: button; on: #mouseUp send: #mouseUp: to: button. ^ button! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/1/2012 19:13'! buildCommentPane commentTextArea := PluggableTextMorph on: self text: #getComments accept: #addComment:notifying: readSelection: nil menu: #codePaneMenu:shifted:. commentTextArea color: Color white. commentTextArea askBeforeDiscardingEdits: true; vResizing: #spaceFill; hResizing: #spaceFill. self setCommentShorcutsTo: commentTextArea. commentTextArea spaceFillWeight: 1. ^ commentTextArea! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'EstebanLorenzano 1/30/2013 14:43'! buildGroupsButton | button | button := (PluggableButtonMorph on: self getState: #groupsButtonState action: #groupsButtonAction label: #groupsButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap. self setShortcuts: #NautilusGroupShortcuts to: button. ^ button! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 12/20/2012 12:27'! buildInstanceButton ^ (CheckboxMorph on: self selected: #instanceButtonState changeSelected: #instanceButtonAction) getLabelSelector: #instanceButtonLabel; labelClickable: true; hResizing: #spaceFill; vResizing: #shrinkWrap; yourself "^ (PluggableButtonMorph on: self getState: #instanceButtonState action: #instanceButtonAction label: #instanceButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap"! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 2/26/2013 18:46'! buildList list := PluggableIconListMorph new basicWrapSelector: #listWrapper:; keystrokeSelector: #keyPressedOnList:shifted:; getIconSelector: #listIcon:; getListSizeSelector: #listSize; resetListSelector: #resetListSelection; autoDeselect: true; dropEnabled: true; doubleClickSelector: #doubleClick; dropItemSelector: #dropInList:inARow:; dragEnabled: true; hResizing: #spaceFill; vResizing: #spaceFill; model: self; getIndexSelector: #selected; setIndexSelector: #selected:; getSelectionListSelector: #listSelectionAt:; setSelectionListSelector: #listSelectionAt:put:; getMenuSelector: #menu:shifted:; beMultipleSelection; basicGetListElementSelector: #listElement:. self setShortcuts: #NautilusPackageShortcuts to: list. list on: #mouseDown send: #listMouseDown: to: self. list hResizing: #spaceFill; vResizing: #spaceFill. ^ list! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'EstebanLorenzano 1/30/2013 14:45'! buildList2 list2 := PluggableIconListMorph new basicWrapSelector: #listWrapper2:; keystrokeSelector: #keyPressedOnList2:shifted:; getIconSelector: #listIcon2:; getListSizeSelector: #listSize2; resetListSelector: #resetListSelection2; autoDeselect: true; dropEnabled: true; dropItemSelector: #dropInList2:inARow:; doubleClickSelector: #doubleClick2; dragEnabled: true; hResizing: #spaceFill; vResizing: #spaceFill; model: self; getIndexSelector: #selected2; setIndexSelector: #selected2:; getSelectionListSelector: #listSelection2At:; setSelectionListSelector: #listSelection2At:put:; getMenuSelector: #menu2:shifted:; beMultipleSelection; getListElementSelector: #listElement2:. self setShortcuts: #NautilusClassShortcuts to: list2. ^ list2! ! !AbstractNautilusUI methodsFor: 'items creation'! buildSeparator ^ Morph new height: 2; width: 0; color: Color transparent. " ^ ImageMorph new newForm: (self iconClass iconNamed: #separatorIcon) "! ! !AbstractNautilusUI methodsFor: 'items creation'! buildSwitchToByteCodeButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToByteCodeButton; stateSelector: #showByteCode ; onImage: (self iconClass iconNamed: #byteCodeSelectedIcon); offImage: (self iconClass iconNamed: #byteCodeUnselectedIcon); pressedImage: (self iconClass iconNamed: #byteCodePressedIcon); extent: 24@24; helpText: 'Show byteCode'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation'! buildSwitchToDecompileButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToDecompileButton; stateSelector: #showDecompile ; onImage: (self iconClass iconNamed: #decompileSelectedIcon); offImage: (self iconClass iconNamed: #decompileUnselectedIcon); pressedImage: (self iconClass iconNamed: #decompilePressedIcon); extent: 24@24; helpText: 'Show decompiled method'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation'! buildSwitchToSourceCodeButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToSourceCodeButton; stateSelector: #showSource ; onImage: (self iconClass iconNamed: #sourceSelectedIcon); offImage: (self iconClass iconNamed: #sourceUnselectedIcon); pressedImage: (self iconClass iconNamed: #sourcePressedIcon); extent: 24@24; state: #on; helpText: 'Show source code'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 3/23/2012 18:45'! buildToggleButton ^ (PluggableButtonMorph on: self getState: #toggleButtonState action: #toggleButtonAction label: #toggleButtonLabel) getEnabledSelector: #toggleButtonEnabled; hResizing: #spaceFill; vResizing: #shrinkWrap; enabled: (self model selectedClass notNil); yourself! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listSelection ^ self showGroups ifTrue: [ groupsSelection ] ifFalse: [ packagesSelection ]! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listSelection2 ^ classesSelection! ! !AbstractNautilusUI methodsFor: 'list selections'! listSelection2At: anIndex | elt | elt := self getList2 at: anIndex ifAbsent: [ ^false ]. ^ self listSelection2 at: elt ifAbsent: [ false ]! ! !AbstractNautilusUI methodsFor: 'list selections'! listSelection2At: anIndex put: aBoolean | elt | aBoolean ifNil: [ ^ self ]. elt := self getList2 at: anIndex ifAbsent: [ ^ self ]. self listSelection2 at: elt put: aBoolean. self changed: #hasSelectedSelections! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: 'BenjaminVanRyseghem 4/17/2012 16:44'! listSelectionAt: anIndex | elt | elt := self getList at: anIndex ifAbsent: [ ^ false ]. ^ (self listSelection at: elt ifAbsent: [ false ]) == true! ! !AbstractNautilusUI methodsFor: 'list selections'! listSelectionAt: anIndex put: aBoolean | elt | elt := self getList at: anIndex ifAbsent: [ ^ self ]. self listSelection at: elt put: aBoolean. self changed: #hasSelectedSelections! ! !AbstractNautilusUI methodsFor: 'menu builder'! categoryMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self commonPragma. self categoryPragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder'! classMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self classFixPragma. self classPragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! classesMenu: aMenu shifted: aBoolean ^ aMenu addAllFrom: self classMenuBuilder menu.! ! !AbstractNautilusUI methodsFor: 'menu builder'! groupMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self groupFixPragma. self groupPragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! groupsMenu: aMenu shifted: aBoolean " Morphic's menus are filled up when pragma's one are returned from a method, so I have to substitute the morphic menu by the pragma one " ^ aMenu addAllFrom: (self groupMenuBuilder menu)! ! !AbstractNautilusUI methodsFor: 'menu builder'! methodMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self commonPragma. self methodPragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder'! packageMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self packageFixPragma. self packagePragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! packagesMenu: aMenu shifted: aBoolean ^ aMenu addAllFrom: (self packageMenuBuilder menu)! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! sourceCodeMenu: aMenu shifted: shifted " Morphic's menus are filled up when pragma's one are returned from a method, so I have to substitute the morphic menu by the pragma one " ^ aMenu addAllFrom: (self sourceCodeMenuBuilder menu)! ! !AbstractNautilusUI methodsFor: 'menu builder'! sourceCodeMenuBuilder ^ PragmaMenuBuilder pragmaKeyword: self sourceCodePragma model: self! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! categoryPragma ^'nautilusGlobalProtocolMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! classFixPragma ^'nautilusGlobalClassFixMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! classPragma ^'nautilusGlobalClassMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! commonPragma ^'nautilusGlobalCommonMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! groupFixPragma ^'nautilusGlobalGroupFixMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! groupPragma ^'nautilusGlobalGroupMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! methodPragma ^'nautilusGlobalMethodMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:23'! packageFixPragma ^ 'nautilusGlobalPackageFixMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:24'! packagePragma ^ 'nautilusGlobalPackageMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! sourceCodePragma ^ 'nautilusGlobalSourceCodeMenu'! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 4/6/2012 17:32'! addModelItemsToWindowMenu: aMenu "Add model-related items to the window menu" "super addModelItemsToWindowMenu: aMenu." SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self model. aMenu addLine; add: 'Nautilus Plugins Manager' target: NautilusPluginManager new action: #openInWorld. aMenu add: 'Shortcuts description' target: self action: #openShortcutDescription.! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 3/23/2012 19:58'! menu2: aMenu shifted: aBoolean self classesMenu: aMenu shifted: aBoolean. ^ aMenu! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 3/23/2012 19:58'! menu: aMenu shifted: aBoolean self showGroups ifTrue: [self groupsMenu: aMenu shifted: aBoolean] ifFalse: [self packagesMenu: aMenu shifted: aBoolean]. ^ aMenu! ! !AbstractNautilusUI methodsFor: 'menus behavior'! addCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/14/2012 12:05'! addClass self selectedPackage ifNotNil: [:package | self addClassIn: package ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! addPackage | package | package := self addPackageBasedOn: self selectedPackage. package ifNotNil: [ self selectedPackage: package. self updatePackageViewAndMove ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! addTrait self selectedPackage ifNotNil: [:package | self addTraitIn: package ] " No need of update, announcements will do the job "! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseClassRefs self browseClassRefsOf: self selectedClass.! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseClassVarRefs self browseClassVarRefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseInstVarDefs self browseInstVarDefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseInstVarRefs self browseInstVarRefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseMessages self browseMessagesFrom: self selectedMethod selector! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:52'! browseSendersOfMessages "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." self selectedMethod ifNotNil: [:met | self browseSendersOfMessagesFrom: met selector ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseUnusedMethods self browseUnusedMethodsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseVersions "Create and schedule a Versions Browser, showing all versions of the currently selected message. Answer the browser or nil." self browseVersionsFrom: self selectedMethod! ! !AbstractNautilusUI methodsFor: 'menus behavior'! buildInitializeCodeFor: aClass ^ String streamContents: [:str | str << 'initialize';cr. str tab << '"Initialization code for '<> selector ]. MethodClassifier classifyAll: methods ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! categorizeMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/6/2012 16:33'! copyClasses | association | self okToChange ifFalse: [^ self]. association := self copyClasses: (self selectedClasses collect: [:e | e theNonMetaClass ]). association key ifTrue: [ self selectedClass: association value. self updateClassView]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! createInitializerWithInstVars "Create a default initializer on the class side for a chosen list of instance variables" self createInitializerWithInstVarsOf: (self showInstance ifTrue: [ self selectedClass theNonMetaClass ] ifFalse: [ self selectedClass theMetaClass ])! ! !AbstractNautilusUI methodsFor: 'menus behavior'! createInstVarAccessors self createInstVarAccessorsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! enableSingleClassSelection ^ self selectedClasses size <= 1! ! !AbstractNautilusUI methodsFor: 'menus behavior'! enableSingleMenuItems ^ self selectedItems size <= 1! ! !AbstractNautilusUI methodsFor: 'menus behavior'! fileOutClass "Print a description of the selected class onto a file whose name is the category name followed by .st." self fileOutClasses: self selectedClasses! ! !AbstractNautilusUI methodsFor: 'menus behavior'! fileOutMethods ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior'! fileOutPackage self fileOutPackages: self selectedPackages! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 02:13'! findClass "Search for a class from a pattern or from the recent list" self findClass: (SearchFacade classSearchInEnvironment: self browsedEnvironment).! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:35'! findClass: aSearchInstance "select the class returned by the search block" | aClass recentList | self okToChange ifFalse: [^ self flashPackage ]. aClass := aSearchInstance chooseFromOwner: self window. aClass ifNil: [^ self flashPackage]. self showGroups: false. self selectedPackage: aClass package. self selectedClass: aClass. self updateBothView! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:49'! findClassInHierarchy "Search for a subclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self findClass: (SearchFacade hierarchySearchFor: class theNonMetaClass)].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/27/2012 00:30'! findPackage "Search for a package from a pattern or from the recent list" | foundPackage packagesList | self okToChange ifFalse: [^ self ]. "packagesList := (self model recentClasses elements collect: [:each | each package name]) asSet asArray sort. foundPackage := self findPackageIn: packagesList. foundPackage ifNil: [ ^ self ]. self selectedPackage = foundPackage ifTrue: [ ^ self ]." foundPackage := SearchFacade rPackageSearch chooseFromOwner: self window. self selectedPackage: foundPackage. self updatePackageViewAndMove. ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:49'! findSubclass "Search for a subclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self findClass: (SearchFacade subclassSearchFor: class theNonMetaClass)].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:48'! findSuperclass "Search for a superclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self findClass: (SearchFacade superclassSearchFor: class theNonMetaClass)].! ! !AbstractNautilusUI methodsFor: 'menus behavior'! forceGenerateInitialize self selectedClass ifNotNil: [:class || code index | (class isMeta not and: [class inheritsFrom: TestCase]) ifTrue: [ index := 34. code := self buildSetUpCodeFor: class. class compile: code classified: 'initialization'. code := self buildTearDownCodeFor: class. class compile: code classified: 'initialization'. self selectedMethod: (class>>#setUp) ] ifFalse: [ index := 62. code := self buildInitializeCodeFor: class. class compile: code classified: 'initialization' . self selectedMethod: (class>>#initialize) ]. self update. self giveFocusTo: sourceTextArea. sourceTextArea selectFrom: index+class name size to: index-1+class name size ].! ! !AbstractNautilusUI methodsFor: 'menus behavior'! fullBrowse ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'MarcusDenker 9/17/2012 15:37'! generateInitialize self selectedClass ifNotNil: [:class || code index category | category := 'initialize'. (class isMeta not and: [class inheritsFrom: TestCase]) ifTrue: [ index := 34. (class includesSelector: #setUp) ifFalse: [ code := self buildSetUpCodeFor: class. class compile: code classified: category ]. (class includesSelector: #tearDown) ifFalse: [ code := self buildTearDownCodeFor: class. class compile: code classified: category ]. self selectedMethod: (class>>#setUp) ] ifFalse: [ index := 62. (class includesSelector: #initialize) ifFalse: [ code := self buildInitializeCodeFor: class. class compile: code classified: category ]. self selectedMethod: (class>>#initialize) ]. self update. self giveFocusTo: sourceTextArea. sourceTextArea selectFrom: index+class name size to: index-1+class name size ].! ! !AbstractNautilusUI methodsFor: 'menus behavior'! mergeGroups | group | group := self mergeGroups: self selectedGroups. group ifNotNil: [ self groupsManager addAGroup: group. self selectedGroup: group. self updateBothView] ! ! !AbstractNautilusUI methodsFor: 'menus behavior'! methodHierarchy "Create and schedule a method browser on the hierarchy of implementors." self methodHierarchyFrom: self selectedMethod! ! !AbstractNautilusUI methodsFor: 'menus behavior'! moveInNewPackage "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | item | self okToChange ifFalse: [^ self]. item := self moveInNewPackage: (self selectedClasses collect: [:e | e theNonMetaClass ]). item ifNotNil: [ self selectedPackage: item ]. self updateBothView! ! !AbstractNautilusUI methodsFor: 'menus behavior'! moveMethodToPackage ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior'! removeClassFromGroup self selectedClasses do: [:class | [ self groupsManager removeClass: class theNonMetaClass from: self selectedGroup. self updateClassView ] fork ]. self selectedClass: nil; updateClassView.! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 3/23/2012 19:59'! removeClasses "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | result scroll | self okToChange ifFalse: [^ false]. scroll := list2 scrollValue y. result := self removeClasses: (self selectedClasses collect: #theNonMetaClass). result ifTrue: [ classesSelection removeAll. self selectedClass: nil ]. list2 vScrollValue: scroll. ^ result! ! !AbstractNautilusUI methodsFor: 'menus behavior'! removeEmptyCategories self okToChange ifFalse: [^ self]. (self methodsForCategory: self selectedCategory) ifEmpty: [ self selectedCategory: nil ]. self removeEmptyCategoriesFrom: self selectedClass. self update.! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/6/2012 16:02'! removeGroups self okToChange ifFalse: [ ^ self ]. self selectedGroups ifNotEmpty:[:groups | groupsSelection removeAll. groups do: [:group | self groupsManager removeAGroupSilently: group ]. self selectedGroup: nil]. ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/22/2012 14:07'! removePackages | names | self selectedPackages ifNotEmpty: [:packages | names := packages collect: [:package | package name ]. names := names joinUsing: String cr. (UIManager default confirm: ('Are you sure you want to delete the package(s) named ', String cr, names, ' and their classes ?')) ifTrue: [| scroll | packages do: [:package | package definedClasses do:[: classToRemove | classToRemove subclasses size > 0 ifTrue: [ | message | message := 'Are you certain that you want to REMOVE the class ', classToRemove name, ' from the system?'. (self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem ]. self browsedEnvironment packageOrganizer unregisterPackage: package ]. scroll := list scrollValue y . self selectedPackage: nil. self updatePackageView. list vScrollValue: scroll ]]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! renameCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 1/15/2013 17:07'! renameClass self okToChange ifFalse: [ ^ self ]. self selectedClass ifNil: [ ^ self ]. self basicRenameClass: self selectedClass theNonMetaClass. self changed: #sourceCodeFrom:.! ! !AbstractNautilusUI methodsFor: 'menus behavior'! renameGroup | group newName | group := self selectedGroup. group ifNil: [ ^ self ]. self groupsManager renameAGroup: group. self updateBothView! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'SeanDeNigris 2/5/2013 10:12'! renamePackage self renamePackages: self selectedPackages. cachedHierarchy := self buildPackageHierarchyFor: self selectedPackage. self updatePackageView. ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/28/2012 14:45'! restrictedBrowse self showGroups ifTrue: [ ^ self restrictedBrowseGroup ]. self selectedClass ifNil: [ self restrictedBrowsePackage ] ifNotNil: [ self restrictedBrowseClass ].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'MarcusDenker 1/17/2013 11:04'! restrictedBrowseClass self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: {class} ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseClasses: classes | newEnvironment | newEnvironment := self browsedEnvironment forClasses: classes. self model class openOnClass:self selectedClass inEnvironment: newEnvironment ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:04'! restrictedBrowseGroup self restrictedBrowseGroups: self selectedGroups! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:03'! restrictedBrowseGroups: aCollection aCollection ifNotEmpty: [:groups || elements newEnvironment | elements := groups gather: [:group | group elements]. newEnvironment := self browsedEnvironment forClasses: (elements collect: #theNonMetaClass). self model class openOnGroup: groups first inEnvironment: newEnvironment ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:03'! restrictedBrowseHierarchy self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: (class withAllSuperclasses, class allSubclasses) ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:00'! restrictedBrowsePackage self selectedPackages ifEmpty: [ ^ self ] ifNotEmpty: [:packages | ^ self restrictedBrowsePackages: packages ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:30'! restrictedBrowsePackageRegex | regex | regex := self selectedPackages ifEmpty: [ '' ] ifNotEmpty: [ :packages | '^',(packages first name splitOn: $-) first , '-.*$']. regex := UIManager default request: 'Browse restricted on Packages matching:' regex: regex . regex ifNil: [ ^ self ]. self restrictedBrowsePackages: (self browsedEnvironment packages select: [ :package| regex matches: package name ] )! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:00'! restrictedBrowsePackages: packages | newEnvironment | newEnvironment := self browsedEnvironment forPackages: packages. self model class openOnPackage: self selectedPackage inEnvironment: newEnvironment! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseSubclasses self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: class withAllSubclasses]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseSuperclasses self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: class withAllSuperclasses ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! runTestsOfGroups: aCollection notifying: aBoolean | classes label | label := 'Group: '. aCollection size >1 ifTrue: [ label := 'Groups: ']. classes := aCollection gather:[:each | each elements ]. classes := classes select: [:class | class inheritsFrom: TestCase ]. self runClassTests: classes notifying: false. aBoolean ifFalse: [ self notifyTitle: 'Test Finished' contents: label,((aCollection collect: #name) joinUsing: ', ') ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! showUnreferencedClassVars "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" self showUnreferencedClassVarsOf: self selectedClass.! ! !AbstractNautilusUI methodsFor: 'menus behavior'! showUnreferencedInstVars "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" self showUnreferencedInstVarsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'monticello announcements'! mcPackageModified: anAnnouncement " handled when a package become dirty " | rpackages | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. rpackages := (NautilusMCBindings default rPackagesFor: anAnnouncement package). (self model packages includesAnyOf: rpackages ) ifTrue: [ rpackages do: [:rpackage | PackagesIconsCache removeKey: rpackage ifAbsent: []]. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'monticello announcements' stamp: 'MarcusDenker 7/6/2012 23:11'! mcWorkingCopyCreated: anAnnouncement | package rpackage mcPackage | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. package := anAnnouncement package. package ifNil: [ ^ self ]. rpackage := RPackageOrganizer default packageNamed: package name. (self model packages includes: rpackage) ifTrue: [ PackagesIconsCache removeKey: rpackage ifAbsent: []. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'monticello announcements' stamp: 'EstebanLorenzano 5/21/2012 17:10'! mcWorkingCopyDeleted: anAnnouncement | package rpackages | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. package := anAnnouncement package. package ifNil: [ ^ self ]. rpackages := NautilusMCBindings default rPackagesFor: package. rpackages ifNil: [ ^ self ]. rpackages do: [:rpackage | PackagesIconsCache removeKey: rpackage ifAbsent: []]. self updatePackageView! ! !AbstractNautilusUI methodsFor: 'monticello announcements'! newMCVersion: anAnnouncement | rpackage | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. rpackage := anAnnouncement version package correspondingRPackage. rpackage ifNil: [ ^ self ]. ( self model packages includes: rpackage ) ifTrue: [ self removeFromPackagesIconsCache: rpackage. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'plugins announcements'! aKeyHasBeenPressed: aKey self announcer announce: (NautilusKeyPressed key: aKey )! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:36'! browseClass: aClass self showGroups: false. self selectedPackage: aClass package. self selectedClass: aClass. self updateBothView! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:35'! browseSuperclass self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self browseSuperclassOf: class ]! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:35'! browseSuperclassOf: class ^ self browseClass: class superclass! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/16/2013 00:24'! openClass self openClass: self selectedClass! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 14:12'! openClass: aClass aClass ifNil: [ ^ self ]. self open browseClass: aClass! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 14:13'! openSubclass "Search for a superclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| | search | search := SearchFacade subclassSearchFor: class theNonMetaClass. self openClass: (search chooseFromOwner: self window) ].! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 14:07'! openSuperclass "Search for a superclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self openClass: class superclass ].! ! !AbstractNautilusUI methodsFor: 'plugins display'! buildBottomPlugins ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'plugins display'! buildLeftPlugins | left | left := self model plugins select: [:each | each position = #left ].! ! !AbstractNautilusUI methodsFor: 'plugins display'! buildRightPlugins | right | right := self model plugins select: [:each | each position = #right ].! ! !AbstractNautilusUI methodsFor: 'plugins display'! buildTopPlugins ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'protocol'! forceSelection: anObject! ! !AbstractNautilusUI methodsFor: 'protocol'! resetSelections! ! !AbstractNautilusUI methodsFor: 'protocol'! title: aString shouldUpdateTitle := false. window title: aString! ! !AbstractNautilusUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/18/2012 18:57'! update self subclassResponsibility ! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 15:18'! openShortcutDescription KMDescription new categories: #(NautilusGlobalShortcuts "NautilusClassShortcuts NautilusSourceCodeShortcuts NautilusPackageShortcuts NautilusProtocolShortcuts NautilusMethodShortcuts") sort; openWithSpec! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 2/19/2013 14:43'! removeShortcuts: groupSymbol from: aMorph Nautilus useOldStyleKeys ifFalse: [ ^self ]. (aMorph kmDispatcher includesKeymapCategory: groupSymbol) ifTrue: [ aMorph detachKeymapCategory: groupSymbol targetting: self ] ! ! !AbstractNautilusUI methodsFor: 'shortcuts'! setClassShorcutsTo: aList aList attachKeymapCategory: #NautilusClassShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 8/1/2012 19:13'! setCommentShorcutsTo: aList aList attachKeymapCategory: #NautilusCommentShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 2/6/2013 14:00'! setGroupShorcutsTo: aList aList attachKeymapCategory: #NautilusGroupShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 2/6/2013 17:30'! setShortcuts: groupSymbol to: aMorph aMorph attachKeymapCategory: ( Nautilus useOldStyleKeys ifTrue: [ groupSymbol ] ifFalse: [ #NautilusGlobalShortcuts ]) targetting: self ! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 1/30/2013 14:37'! setSourceCodeShorcutsTo: aList aList attachKeymapCategory: #NautilusSourceCodeShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'source code area'! addComment: aText notifying: aController self selectedClass ifNil: [ self selectedPackage ifNotNil: [:package | "commentTextArea update: #clearUserEdits. package comment: aText"]] ifNotNil: [:class | commentTextArea update: #clearUserEdits. class comment: aText ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:23'! buildNewSourceTextArea sourceTextArea := self textMorphClass on: self text: #sourceCodeFrom: accept: #compileSource:notifying: readSelection: #contentsSelectionFrom: menu: #sourceCodeMenu:shifted:. sourceTextArea askBeforeDiscardingEdits: true; color: Color white; lockSelector: #lockTextArea:from:; canLockChangeSelector: #canChangeLockFor:; vResizing: #spaceFill; hResizing: #spaceFill; font: StandardFonts codeFont; spaceFillWeight: 3; on: #keyStroke send: #keyStroke:fromSourceCodeMorph: to: self; warningLimit: self warningLimit. self setSourceCodeShorcutsTo: sourceTextArea. sourceTextAreaLimit := sourceTextArea warningLimit. sourceTextArea warningLimit: -1. sourceTextAreas addFirst: (sourceTextArea -> nil). ^ sourceTextArea ! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 01:23'! canChangeLockFor: source ^ source locked or: [ self selectedMethod isNil not ]! ! !AbstractNautilusUI methodsFor: 'source code area'! clearUserEditFlag self changed: #clearUserEdits! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'EstebanLorenzano 1/31/2013 19:24'! codePaneMenu: aMenu shifted: shifted "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items in a text pane" | donorMenu | donorMenu := shifted ifTrue: [SmalltalkEditor shiftedYellowButtonMenu] ifFalse: [SmalltalkEditor yellowButtonMenu]. ^ aMenu addAllFrom: donorMenu! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/1/2012 19:10'! commentTextArea ^ commentTextArea! ! !AbstractNautilusUI methodsFor: 'source code area'! compileAClassFrom: aString notifying: aController sourceTextArea update: #clearUserEdits. ( self compileANewClassFrom: aString notifying: aController startingFrom: self selectedClass ) ifNil: [^ sourceTextArea hasUnacceptedEdits: true. ] ifNotNil: [:class | self selectedPackage: class package. self selectedClass: class. self showHierarchy ifTrue: [ self hierarchyClass: class ]. self showGroups ifTrue: [ self updateClassView ] ifFalse: [ self updateBothView ]]! ! !AbstractNautilusUI methodsFor: 'source code area'! compileAMethodFromCategory: aCategory withSource: aString notifying: aController ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'source code area'! compileSource: aText notifying: aController ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:22'! contentSelectionFor: aTextMorph aTextMorph ifLocked: [ ^ (1 to: 0) ]. self selectedClass isNil ifFalse:[ self selectedMethod isNil ifTrue: [ self selectedCategory notNil ifTrue: [^ (1 to: self defaultMethodSource size) ]]]. ^ (1 to: 0) ! ! !AbstractNautilusUI methodsFor: 'source code area'! defaultClassDescriptor | string | string := 'Object subclass: #NameOfSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: '''. ^ self selectedPackage ifNil: [string, '''' ] ifNotNil: [:package | string, package name, '''' ]! ! !AbstractNautilusUI methodsFor: 'source code area'! defaultMethodSource ^ 'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! ! !AbstractNautilusUI methodsFor: 'source code area'! doItContext ^ nil! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'CamilloBruni 10/4/2012 10:45'! doItReceiver ^ self selectedClass ifNotNil: [:class | class theNonMetaClass ]! ! !AbstractNautilusUI methodsFor: 'source code area'! getComments ^ self selectedClass ifNil: [ self selectedPackage ifNil: [ '' ] ifNotNil: [:package | '' "package comment" ]] ifNotNil: [:class | class comment ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:35'! highlight: autoSelectString | first | first := sourceTextArea getText findString: autoSelectString. contentSelection := first to: first+autoSelectString size-1. self changed: #sourceCodeFrom:! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 3/23/2012 19:17'! listWrapper: anElement anElement = 0 ifTrue: [^'']. ^ self ifGroups: [ anElement name ] ifNot: [ anElement name "self ifPackages: [ anElement name ] ifClasses: [ self buildTabbedNameOf: anElement ]"]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 01:31'! lockTextArea self selectedMethod isNil ifTrue: [ ^ self ]. sourceTextArea lockFrom: self selectedMethod. self buildNewSourceTextArea. multipleMethodsEditor addEditor: sourceTextArea. self changed: #sourceCodeFrom:.! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 00:49'! lockTextArea: aBoolean from: source aBoolean ifTrue: [ self lockTextArea ] ifFalse: [ self unlockTextArea: source ].! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 4/17/2012 17:24'! okToChange sourceTextArea text asString trimBoth = sourceTextArea getText asString trimBoth ifTrue: [ ^ true ]. sourceTextArea canDiscardEdits ifTrue: [^ true]. sourceTextArea update: #wantToChange. "Solicit cancel from view" ^ sourceTextArea canDiscardEdits ! ! !AbstractNautilusUI methodsFor: 'source code area'! okToChangeBoth self canDiscardEdits ifTrue: [^ true]. self changed: #wantToChange. "Solicit cancel from view" ^ self canDiscardEdits ! ! !AbstractNautilusUI methodsFor: 'source code area'! okToChangeComment commentTextArea canDiscardEdits ifTrue: [^ true]. commentTextArea update: #wantToChange. "Solicit cancel from view" ^ commentTextArea canDiscardEdits ! ! !AbstractNautilusUI methodsFor: 'source code area'! putSourceTextAreaLimit sourceTextArea ifNotNil: [ sourceTextArea warningLimit: sourceTextAreaLimit ]! ! !AbstractNautilusUI methodsFor: 'source code area'! removeSourceTextAreaLimit sourceTextArea ifNotNil: [ sourceTextArea warningLimit: -1 ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/3/2012 18:16'! removeTextArea: anArea self shouldBeImplemented! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:22'! resetContentsSelectionFrom: aTextMorph contentSelection at: aTextMorph put: (self contentSelectionFor: aTextMorph)! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedClassComments ^ self selectedClass ifNil: [''] ifNotNil: [:class| class comment]! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedClassDescription ^ self selectedClass definition! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedMethodComments ^ self selectedMethod comment! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedMethodSource self selectedMethod ifNil: [ ^ '' ] ifNotNil: [:method | self showSource ifTrue: [ ^ method sourceCode ]. self showByteCode ifTrue: [ ^ method symbolic asText]. self showDecompile ifTrue: [ ^ method decompileWithTemps decompileString asText makeSelectorBoldIn: method methodClass ]. ^ 'error'] ! ! !AbstractNautilusUI methodsFor: 'source code area'! setStylerClass: aClass sourceTextArea ifNotNil: [ sourceTextArea classOrMetaClass: aClass ]! ! !AbstractNautilusUI methodsFor: 'source code area'! sourceCode self removeSourceTextAreaLimit. ^self selectedClass isNil ifTrue: [ self defaultClassDescriptor] ifFalse:[ self selectedMethod isNil ifTrue: [ self selectedCategory notNil ifTrue: [ self putSourceTextAreaLimit. self defaultMethodSource] ifFalse: [ self selectedClassDescription]] ifFalse: [ self putSourceTextAreaLimit. self selectedMethodSource]]. ! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/4/2012 01:07'! sourceCodeFrom: aTextMorph aTextMorph ifLocked: [ ^ aTextMorph textMorph text ]. ^ self sourceCode! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 00:53'! unlockTextArea: source multipleMethodsEditor removeEditor: source! ! !AbstractNautilusUI methodsFor: 'source text events'! keyStroke: anEvent fromSourceCodeMorph: aMorph ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:21'! classAdded: anAnnouncement | class | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement classAdded. ((self showGroups and: [ self selectedGroup ifNil: [ ^ self ] ifNotNil: [:gp | gp elements includes: class ]]) or: [ self selectedPackage = class package]) ifTrue: [ self updateClassView. self removeFromPackagesIconsCache: class package ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:21'! classCommented: anAnnouncement " announcement handled when a class has been commented " | aClass | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. aClass := anAnnouncement classCommented. (self getList2 includes: aClass) ifTrue: [ self removeFromClassesIconsCache: aClass ]. ((self selectedClass = aClass) and: [ self showComment ]) ifTrue: [ self changed: #getComments ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 8/6/2012 19:55'! classDefinitionModified: anAnnouncement | class | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement newClassDefinition. ((self showGroups and: [ self selectedGroup notNil and: [ self selectedGroup elements includes: class ]]) or: [ self getList2 includes: class ]) ifTrue: [ self updateClassView. self removeFromPackagesIconsCache: class package. sourceTextArea hasUnacceptedEdits ifFalse: [ self changed: #sourceCodeFrom: ]].! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'EstebanLorenzano 1/15/2013 16:32'! classRecategorized: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. self selectedClass = anAnnouncement classRecategorized ifTrue: [ self updateBothView ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 2/16/2013 15:18'! classRemoved: anAnnouncement | class oldPackage | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement classRemoved. ((self showGroups and: [ self selectedGroup ifNil: [ ^self ] ifNotNil: [:gp | gp elements includes: class ]]) or: [ self getList2 includes: class ]) ifTrue: [ self selectedClass = class ifTrue: [ self selectedClass: nil ]. window isDisplayed ifFalse: [ ^ self ]. oldPackage := RPackageOrganizer default packageNamed: (anAnnouncement categoryName). self removeFromPackagesIconsCache: oldPackage. self updateBothView ]. ! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:22'! classRenamed: anAnnouncement | class | class := anAnnouncement classRenamed. window ifNil: [ ^ self]. window isDisplayed ifFalse: [ ^ self ]. ((self showGroups and: [ self selectedGroup elements includes: class ]) or: [ self getList2 includes: class ]) ifTrue: [ self updateClassView ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:22'! classReorganized: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. anAnnouncement classReorganized = self selectedClass ifTrue: [ self update ].! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodAdded: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodModified: anAnnouncement ^ self subclassResponsibility ! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodRecategorized: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodRemoved: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements'! packageChanged: anAnnouncement window isDisplayed ifFalse: [ ^ self ]. self showGroups not ifTrue: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 12/20/2012 15:06'! packageCreated: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. self showGroups not ifTrue: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements'! packageRenamed: anAnnouncement window isDisplayed ifFalse: [ ^ self ]. self showGroups not ifTrue: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements'! packageUnregistred: anAnnouncement self showGroups not ifTrue: [ | package | package := anAnnouncement package. self selectedPackage = package ifTrue: [ self selectedPackage: nil ]. packagesSelection at: package put: false. window isDisplayed ifFalse: [ ^ self ]. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 5/14/2012 12:17'! testCaseStarted: anAnnouncement | class selector | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement testCase class. selector := anAnnouncement testSelector. self selectedClass = class ifTrue: [| method correspondingClass icon | icon := self iconClass iconNamed: #testNotRun. method := class methodNamed: selector. correspondingClass := class correspondingClass. self methodWidget setIcon: icon for: method; updateList ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 2/16/2013 15:27'! testRunned: anAnnouncement | collection class correspondingClass | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement testResult. correspondingClass := anAnnouncement testResult correspondingClass. collection := self getList2. (collection includesAnyOf: {class. correspondingClass}) ifTrue: [ self removeClassFromMethodsIconsCache: class. self removeClassFromMethodsIconsCache: correspondingClass. self updateClassView. self update ].! ! !AbstractNautilusUI methodsFor: 'test creation'! buildTestClassDefinitionFrom: aClass ^ 'TestCase subclass: ', (self buildTestClassNameFrom: aClass) printString, ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''',(self buildTestPackageNameFrom:aClass),''''! ! !AbstractNautilusUI methodsFor: 'test creation'! buildTestClassNameFrom: aClass ^ (aClass name asString,'Test') asSymbol! ! !AbstractNautilusUI methodsFor: 'test creation'! buildTestPackageNameFrom:aClass ^ aClass package name asString, '-Tests' ! ! !AbstractNautilusUI methodsFor: 'test creation'! createTestForClass: aClass | definition testClass className | aClass ifNil: [ ^ nil ]. (aClass inheritsFrom: TestCase) ifTrue: [ ^ nil ]. aClass isMeta ifTrue: [ ^ nil ]. className := self buildTestClassNameFrom: aClass. testClass := self class environment at: className ifPresent: [:class | class ] ifAbsent: [ definition := self buildTestClassDefinitionFrom: aClass. testClass := self compileANewClassFrom: definition notifying: nil startingFrom: self selectedClass. self class environment at: className. testClass comment: (self generateCommentForTestClass: testClass from: aClass)]. self showGroups: false. self selectedPackage: testClass package. self selectedClass: testClass. self updateBothView. ^ testClass! ! !AbstractNautilusUI methodsFor: 'test creation'! createTestForSelectedClass self createTestForClass: self selectedClass! ! !AbstractNautilusUI methodsFor: 'test creation'! generateCommentForTestClass: testClass from: aClass ^ String streamContents: [:stream || name | name := testClass name. name first isVowel ifTrue: [ stream << 'An '] ifFalse:[ stream <<'A ']. stream << name << ' is a test class for testing the behavior of '<< aClass name ]! ! !AbstractNautilusUI methodsFor: 'widget - class'! classWidget ^ list2! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! forceSelectedMethod: aMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedCategory: anObject ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedMethod: aMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private'! addSubclassesOf: aClass in: result withIndex: index | classes | classes := aClass subclasses "self selectedPackage ifNil: [ {} ] ifNotNil: [:p | aClass subclasses intersection: p classes ]". classes do: [:each | result at: each put: index. self addSubclassesOf: each theNonMetaClass in: result withIndex: index + 1 ]! ! !AbstractNautilusUI methodsFor: 'private'! addSubclassesOf: aClass in: result withIndex: index fromRestrictedCollection: aCollection | classes intersection | classes := aClass subclasses" intersection: self shownClasses". classes := classes intersection: aCollection. (classes sort: [:a :b| a name <= b name]) do: [:each | result at: each put: index. self addSubclassesOf: each in: result withIndex: index + 1 fromRestrictedCollection: aCollection ]! ! !AbstractNautilusUI methodsFor: 'private'! asYetUnclassifiedString ^ ClassOrganizer default! ! !AbstractNautilusUI methodsFor: 'private'! browseClassVars | cls | self selectedClass ifNil: [ self changed: #isAClassSelected. ^ self ]. cls := self selectedClass theNonMetaClass. (cls notNil and: [cls isTrait not]) ifTrue: [ self systemNavigation browseClassVarRefs: cls ]. ! ! !AbstractNautilusUI methodsFor: 'private'! browseInstVars | cls | cls := self selectedClass. (cls notNil and: [cls isTrait not]) ifTrue: [ self systemNavigation browseInstVarRefs: cls ]. self changed: #isAClassSelected! ! !AbstractNautilusUI methodsFor: 'private'! browsedEnvironment ^ self model browsedEnvironment! ! !AbstractNautilusUI methodsFor: 'private'! buildGetterFor: aString ^ aString withFirstCharacterDownshifted,' ^ ', aString! ! !AbstractNautilusUI methodsFor: 'private'! buildGroupHierarchyFor: aGroup | coll1 | aGroup ifNil: [ ^ IdentityDictionary new ]. self browsedEnvironment isSystem ifTrue: [ coll1 := aGroup classes ] ifFalse:[ coll1 := aGroup classes intersection: self model classes ]. ^ self buildHierarchyForClasses: coll1! ! !AbstractNautilusUI methodsFor: 'private'! buildHierarchyFor: aClass ^ self buildHierarchyForClasses: aClass withAllSuperclasses, aClass allSubclasses! ! !AbstractNautilusUI methodsFor: 'private'! buildHierarchyForClasses: aCollection | result classes | result := IdentityDictionary new. classes := (aCollection collect: #theNonMetaClass) asSet. classes do: [:class || level | level := OrderedCollection with: class. class allSuperclassesDo: [:superClass | (classes includes: superClass) ifTrue: [ level add: superClass beforeIndex: 1 ]]. level addFirst: 'whatever you want here'. result at: class put: level ]. ^ result! ! !AbstractNautilusUI methodsFor: 'private'! buildHierarchyForClasses: aCollection fromPackage: aPackage | result classes | result := IdentityDictionary new. classes := aCollection asSet. classes do: [:class || level | level := OrderedCollection with: class. class allSuperclassesDo: [:superClass | (classes includes: superClass) ifTrue: [ level add: superClass beforeIndex: 1 ]]. (aPackage definedClasses includes: class) ifTrue: [ level addFirst: ' '] ifFalse: [ level addFirst: '']. result at: class put: level ]. ^ result! ! !AbstractNautilusUI methodsFor: 'private'! buildInitializerFor: aVariableList ^ String streamContents: [ :stream| aVariableList do: [ :varName| stream << varName << ': ' << varName] separatedBy: [ stream << ' ' ]. stream cr cr tab << '^ self new'; cr. aVariableList do: [ :varName| stream tab tab << varName << ': ' << varName << ';'; cr]. stream tab tab << 'yourself']! ! !AbstractNautilusUI methodsFor: 'private'! buildPackageHierarchyFor: aPackage | classes | classes := aPackage classes collect: #theNonMetaClass. self browsedEnvironment isSystem ifFalse: [ classes := classes intersection: self browsedEnvironment classes ]. ^ self buildHierarchyForClasses: classes fromPackage: aPackage! ! !AbstractNautilusUI methodsFor: 'private'! buildSetterFor: aString ^ aString withFirstCharacterDownshifted, ': anObject ', aString, ' := anObject'! ! !AbstractNautilusUI methodsFor: 'private'! buildTabbedNameOf: anElement | tab result size | tab := ' '. size := cachedHierarchy at: anElement ifPresent: [:p | p size - 2 ] ifAbsent: [ 0 ]. result := String new: (size * (tab size)) streamContents: [ :s| 1 to: size do: [:i | s nextPutAll: tab ]]. ^ self selectedPackage ifNil: [result, anElement name] ifNotNil: [:package | ( anElement package = package) ifTrue: [ (result, anElement name) asStringMorph ] ifFalse: [ (result , anElement name",' (', anElement package name,')'")asStringMorph color: self extensionColor;yourself]]! ! !AbstractNautilusUI methodsFor: 'private'! byteCodeSymbol ^ #ByteCode! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/13/2012 21:36'! changed: aSymbol super changed: aSymbol. self announce: (NautilusChanged symbol: aSymbol)! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 18:57'! changedLabels "firstColumn label: self labelText." "secondColumn label: self labelText2."! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/6/2013 16:02'! classLabel ^'Class' asText allBold asMorph lock! ! !AbstractNautilusUI methodsFor: 'private'! commentLabel ^ 'Comments'! ! !AbstractNautilusUI methodsFor: 'private'! copyCategory: anObject toTheClass: aClass | originClass methods | originClass := self selectedClass. methods := originClass methodsInProtocol: anObject. methods do: [:meth | self copyMethod: meth toTheClass: aClass ].! ! !AbstractNautilusUI methodsFor: 'private'! copyMethod: aMethod toTheClass: aClass | newMethod shouldBeInstall | aMethod realClass = aClass ifTrue: [ ^ self ]. shouldBeInstall := aClass methodDict at: aMethod selector ifPresent: [:sel | " here I have to fork to release the drag & drop " [ (self openDialogWouldYouInstall: sel into: aClass) ifTrue: [ newMethod := aClass compile: aMethod sourceCode classified: aMethod category ]] fork. ] ifAbsent: [ newMethod := aClass compile: aMethod sourceCode classified: aMethod category]! ! !AbstractNautilusUI methodsFor: 'private'! decompileSymbol ^ #Decompile! ! !AbstractNautilusUI methodsFor: 'private'! extensionColor ^ Color gray darker! ! !AbstractNautilusUI methodsFor: 'private'! flashPackage ^ nil! ! !AbstractNautilusUI methodsFor: 'private'! getClassHierarchy self hierarchyClass ifNil: [^self getClassesList]. ^ cachedHierarchy keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b].! ! !AbstractNautilusUI methodsFor: 'private'! getClassHierarchy2 ^ self selectedPackage ifNil: [{}] ifNotNil:[:package | cachedHierarchy := self buildPackageHierarchyFor: package. cachedHierarchy keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b]]! ! !AbstractNautilusUI methodsFor: 'private'! getClassesList ^ self model classes! ! !AbstractNautilusUI methodsFor: 'private'! getClassesList2 ^ self model packagesUsedByTheSelectedClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'CamilloBruni 10/4/2012 10:46'! getGroupHierarchy ^ self selectedGroup ifNil: [ {} ] ifNotNil: [:group | cachedHierarchy := self buildGroupHierarchyFor: group. cachedHierarchy keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b]]! ! !AbstractNautilusUI methodsFor: 'private'! getGroupsKeyList | env | env := self browsedEnvironment. ^ env isSystem ifTrue: [ self groupsManager groups ] ifFalse: [ self groupsManager groups select: [:g | (g classes intersection: self model classes) isEmpty not ]]! ! !AbstractNautilusUI methodsFor: 'private'! getGroupsValuesList ^ self selectedGroup ifNil: [{}] ifNotNil: [:group | group classes ]! ! !AbstractNautilusUI methodsFor: 'private'! getList ^ listElements ifNil: [ listElements := self loadList ].! ! !AbstractNautilusUI methodsFor: 'private'! getList2 ^ list2Elements ifNil: [ list2Elements := self loadList2 ].! ! !AbstractNautilusUI methodsFor: 'private'! getPackagesList ^ self model packages sort: [:a :b | a name <= b name ]! ! !AbstractNautilusUI methodsFor: 'private'! getPackagesList2 ^ self model classesInTheSelectedPackage! ! !AbstractNautilusUI methodsFor: 'private'! giveFocusTo: aMorph self hasFocus ifTrue: [aMorph takeKeyboardFocus]! ! !AbstractNautilusUI methodsFor: 'private'! groupsLabel ^ 'Groups'! ! !AbstractNautilusUI methodsFor: 'private'! ifGroups: aBlock ifNot: anotherBlock ^self showGroups ifTrue: aBlock ifFalse: anotherBlock! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2013 16:30'! initialize super initialize. cachedHierarchy := IdentityDictionary new. groupsSelection := Dictionary new. packagesSelection := Dictionary new. classesSelection := Dictionary new. shouldUpdateTitle := true. testSemaphore := Semaphore new. sourceTextAreas := OrderedCollection new. contentSelection := nil.! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/25/2012 18:00'! instanceLabel ^'Instance' asMorph! ! !AbstractNautilusUI methodsFor: 'private'! isAClassSelected ^ self selectedClass notNil! ! !AbstractNautilusUI methodsFor: 'private'! listElement2: anIndex ^ self getList2 at: anIndex! ! !AbstractNautilusUI methodsFor: 'private'! listElement: anIndex ^ self getList at: anIndex! ! !AbstractNautilusUI methodsFor: 'private'! listSize ^ self getList size.! ! !AbstractNautilusUI methodsFor: 'private'! listSize2 ^ self getList2 size.! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listWrapper2: anElement "anElement is a Class" ^ self showHierarchy ifTrue: [ self buildTabbedNameOf: anElement ] ifFalse: [ self selectedPackage ifNil: [anElement name] ifNotNil: [:package | ( anElement package = package) ifTrue: [ anElement name asStringMorph ] ifFalse: [ anElement name asStringMorph color: self extensionColor;yourself]]]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 19:23'! loadList ^ self ifGroups: [ self getGroupsKeyList ] ifNot:[ self getPackagesList ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 19:23'! loadList2 ^ self ifGroups: [ self showHierarchy ifTrue: [ self getGroupHierarchy ] ifFalse: [ self getGroupsValuesList ]] ifNot: [ self showPackages ifTrue: [ self showHierarchy ifTrue: [ self getClassHierarchy2 ] ifFalse: [ self getPackagesList2 ]] ifFalse: [ cachedHierarchy ifNil: [ self getClassHierarchy ] ifNotNil: [:col | col keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b ]]]]! ! !AbstractNautilusUI methodsFor: 'private'! methodsForCategories: aCollection ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private'! methodsForCategory: aCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private'! moveCategory: anObject toTheClass: aClass | originClass methods | originClass := self selectedClass. methods := originClass methodsInProtocol: anObject. methods do: [:meth | self moveMethod: meth toTheClass: aClass autoRemove: true ]. (originClass methodsInProtocol: anObject) ifEmpty: [ originClass removeCategory: anObject. self selectedCategory: nil ].! ! !AbstractNautilusUI methodsFor: 'private'! moveMethod: aMethod toTheClass: aClass autoRemove: autoRemove | newMethod shouldBeInstall | aMethod realClass = aClass ifTrue: [ ^ self ]. shouldBeInstall := aClass methodDict at: aMethod selector ifPresent: [:sel | " here I have to fork to release the drag & drop " [ (self openDialogWouldYouInstall: sel into: aClass) ifTrue: [ | originClass oldCategory | oldCategory := aMethod category. originClass := aMethod realClass. newMethod := aClass compile: aMethod sourceCode classified: oldCategory. self selectedMethod: nil. originClass removeSelector: aMethod selector. autoRemove ifTrue: [ ( originClass methodsInProtocol:oldCategory ) ifEmpty: [ originClass removeCategory: oldCategory ]]]] fork] ifAbsent: [ | originClass oldCategory | oldCategory := aMethod category. originClass := aMethod realClass. newMethod := aClass compile: aMethod sourceCode classified: oldCategory. self selectedMethod: nil. originClass removeSelector: aMethod selector. autoRemove ifTrue: [ ( originClass methodsInProtocol: oldCategory ) ifEmpty: [ originClass removeCategory: oldCategory ]]]! ! !AbstractNautilusUI methodsFor: 'private'! noMethodsString ^ ClassOrganizer nullCategory! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/17/2012 15:44'! openDialogWouldYouInstall: aMethod into: aClass "open a dialog to ask user if he wants to override the existing method or not" ^ UIManager default confirm: 'Are you sure you want to override the method ', aMethod selector, ' in ', aClass name label: 'Override' ! ! !AbstractNautilusUI methodsFor: 'private'! packageLabel ^'Packages'! ! !AbstractNautilusUI methodsFor: 'private'! popUpTestsResult: aClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'SeanDeNigris 2/5/2013 10:51'! renamePackage: anRPackage | isCurrent | isCurrent := anRPackage = self selectedPackage. super renamePackage: anRPackage. isCurrent ifTrue: [ self selectedPackage: anRPackage ]. packagesSelection at: anRPackage put: true.! ! !AbstractNautilusUI methodsFor: 'private'! resetListSelection self listSelection removeAll.! ! !AbstractNautilusUI methodsFor: 'private'! resetListSelection2 self listSelection2 removeAll.! ! !AbstractNautilusUI methodsFor: 'private'! rootsOf: aPackage | tmpList | tmpList := aPackage definedClasses. self browsedEnvironment isSystem ifFalse: [ tmpList := self model classes intersection: tmpList ]. ^ tmpList select: [:each | (tmpList includes: (each superclass)) not]! ! !AbstractNautilusUI methodsFor: 'private'! rootsOfGroup: aGroup | classes | self browsedEnvironment isSystem ifTrue: [ classes := aGroup elements ] ifFalse: [ classes := aGroup elements intersection: self model classes ]. ^ classes select: [:each | (classes includes: each superclass) not]! ! !AbstractNautilusUI methodsFor: 'private'! runClassTests: aCollection notifying: aBoolean (aCollection allSatisfy: [:each | each inheritsFrom: TestCase ]) ifFalse: [ ^ self ]. aCollection ifNotEmpty:[:classes | classes do: [:class | self runTestsOfClass: class notifying: aBoolean ]]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/20/2012 00:31'! runPackagesTestsNotifying: aBoolean self selectedPackages ifNotNil: [:packages || classes label | packages size > 1 ifTrue: [ label := 'Packages: ' ] ifFalse: [ label := 'Package: ' ]. classes := packages gather: [:package | package definedClasses ]. classes := classes select: [:class | class inheritsFrom: TestCase ]. self runClassTests: classes notifying: false. aBoolean ifTrue: [ | color | (classes anySatisfy:[:e | e hasPassedTest ]) ifTrue: [ color := Color green ]. (classes anySatisfy:[:e | e hasFailedTest ]) ifTrue: [ color := Color yellow ]. (classes anySatisfy:[:e | e hasErrorTest ]) ifTrue: [ color := Color red ]. self notifyTitle: 'Test Finished' contents: label,((packages collect: #name) joinUsing: ', ') color: color ]].! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/20/2012 00:03'! runTestForMethods: aCollection notifying: aBoolean aCollection do: [ :each | each isTestMethod ifTrue: [ self runTestForAMethod: each notifying: aBoolean ]]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/16/2013 14:36'! runTestsOfClass: aClass notifying: aBoolean | methods blockToEvaluate | methods := aClass methodDict values select: [ :method | method isTestMethod ] thenCollect: [:e | e selector ]. blockToEvaluate := [ |result | result := (aClass addToSuite: TestSuite new fromMethods: methods) run. result updateResultsInHistory. ClassesIconsCache removeKey: aClass ifAbsent: []. testSemaphore signal. ]. aBoolean ifTrue: [ blockToEvaluate forkAt: Processor userBackgroundPriority ] ifFalse: [ blockToEvaluate value ]. testSemaphore wait. aBoolean ifTrue: [ | color | aClass hasPassedTest ifTrue: [ color := Color green ]. aClass hasFailedTest ifTrue: [ color := Color yellow ]. aClass hasErrorTest ifTrue: [ color := Color red ]. self notifyTitle: 'Test Finished' contents: 'Class: ', aClass name color: color ]! ! !AbstractNautilusUI methodsFor: 'private'! selectedClasses | associations | associations := classesSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'private'! selectedGroups | associations | associations := groupsSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'private'! selectedItems | associations | associations := self listSelection associations select: [:assoc | assoc value ]. ^ associations collect: [:assoc | assoc key ].! ! !AbstractNautilusUI methodsFor: 'private'! selectedPackages | associations | associations := packagesSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'private'! setCachedHierarchyClass: aClass cachedHierarchy := self buildHierarchyFor: aClass.! ! !AbstractNautilusUI methodsFor: 'private'! showByteCode ^ self currentDisplayChoice = self byteCodeSymbol! ! !AbstractNautilusUI methodsFor: 'private'! showSource ^ self currentDisplayChoice = self sourceCodeSymbol! ! !AbstractNautilusUI methodsFor: 'private'! sortClassesInCachedHierarchy: a b: b "Bullshitty name, Thanks Camillo" | index aa bb minSize| aa := cachedHierarchy at: a. bb := cachedHierarchy at: b. minSize := aa size min: bb size. 1 to: minSize do: [ :i | |compare| compare := (aa at: i) name compare: (bb at: i) name. compare ~~ 2 ifTrue: [ ^ compare == 1 ]]. ^ aa size < bb size! ! !AbstractNautilusUI methodsFor: 'private'! sourceCodeSymbol ^ #SourceCode! ! !AbstractNautilusUI methodsFor: 'private'! systemNavigation ^ SystemNavigation new browsedEnvironment: self browsedEnvironment; yourself! ! !AbstractNautilusUI methodsFor: 'private'! textMorphClass ^ PluggableTextMorphWithLimits! ! !AbstractNautilusUI methodsFor: 'private'! title ^'Nautilus'! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateBothView listElements := nil. list2Elements := nil. self changed: #listElement:. self changed: #listElement2:! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateClassView list2Elements := nil. self changed: #listElement2: ! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateGroupView listElements := nil. self changed: #listElement:! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updatePackageView | scroll | listElements := nil. scroll := list scrollValue y. self changed: #listElement:. list vScrollValue: scroll! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updatePackageViewAndMove listElements := nil. self changed: #listElement:! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updatePackageViewContent | vScrollValue | vScrollValue := list scrollValue y. listElements := nil. self changed: #listElement:. list vScrollValue: vScrollValue! ! !AbstractNautilusUI methodsFor: 'private'! warningLimit ^ self model ifNil: [ 350 ] ifNotNil: [:mod | model warningLimit ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractNautilusUI class instanceVariableNames: ''! !AbstractNautilusUI class methodsFor: 'accessing'! classesIconsCache: anObject ClassesIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing'! groupsIconsCache ^ GroupsIconsCache! ! !AbstractNautilusUI class methodsFor: 'accessing'! groupsIconsCache: anObject GroupsIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing'! icon ^ Icon! ! !AbstractNautilusUI class methodsFor: 'accessing'! icon: anObject Icon := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/24/2012 17:55'! nextFocusKey ^ NextFocusKey! ! !AbstractNautilusUI class methodsFor: 'accessing'! packagesIconsCache ^ PackagesIconsCache! ! !AbstractNautilusUI class methodsFor: 'accessing'! packagesIconsCache: anObject PackagesIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/25/2012 11:08'! previousFocusKey ^ PreviousFocusKey! ! !AbstractNautilusUI class methodsFor: 'icon'! buildIcon | bitmap | bitmap := (Bitmap new: 256) copyFromByteArray: #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 255 249 235 15 254 248 233 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 183 102 33 13 162 147 126 14 199 176 153 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 143 187 142 101 94 197 140 89 0 0 0 0 208 181 135 93 108 190 134 85 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 144 159 121 84 174 168 127 90 119 181 140 104 194 182 128 81 24 207 148 99 4 252 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 159 170 119 70 255 200 124 58 253 189 122 63 60 148 118 91 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 199 157 91 59 255 222 129 64 255 201 118 48 178 152 100 49 73 138 112 54 106 168 135 62 167 206 169 100 193 191 158 105 115 172 143 97 0 0 0 0 5 155 136 98 55 204 190 157 10 236 223 187 0 0 0 0 21 105 87 68 91 162 123 78 240 187 126 60 255 212 131 43 253 227 148 48 255 218 157 63 255 233 175 78 255 235 176 64 255 224 167 68 255 232 171 81 255 216 168 74 109 181 145 85 21 154 136 98 245 194 174 137 33 211 209 190 81 172 145 107 241 194 152 81 255 207 158 80 255 243 176 64 254 246 176 67 254 208 141 49 255 221 156 81 255 200 123 54 255 209 137 56 255 187 124 56 254 204 128 48 255 248 183 62 230 171 125 65 0 0 0 0 198 196 161 122 135 198 161 130 238 191 139 90 255 227 158 63 254 234 165 51 254 244 172 65 255 227 160 65 254 170 105 26 255 209 144 65 254 185 117 40 253 213 143 55 252 221 143 58 248 238 144 58 255 223 134 39 250 163 97 51 20 231 255 255 185 186 137 106 255 181 122 80 255 162 85 36 255 221 124 53 255 234 154 50 255 234 170 61 255 232 168 69 255 220 149 53 255 238 159 56 255 241 163 59 255 231 158 59 255 226 151 64 255 198 120 54 215 166 91 43 57 133 68 38 13 210 220 210 83 199 158 129 209 203 160 125 129 184 139 102 235 161 83 47 255 190 102 41 255 203 112 40 255 208 117 47 253 213 121 50 251 208 122 55 222 185 106 44 175 159 100 50 139 141 103 65 53 156 105 65 9 99 69 79 0 0 0 0 0 0 0 0 0 0 0 0 143 155 129 114 0 0 0 0 10 138 135 170 65 108 49 22 87 138 77 48 93 129 70 41 45 93 34 6 26 68 32 26 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 197 179 174 0 0 0 0 93 197 180 176 4 202 182 170 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 180 88 18 2 146 92 49 1 128 100 73 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]. ^ Form extent: 16@16 depth: 32 bits: bitmap! ! !AbstractNautilusUI class methodsFor: 'icon'! iconClass ^ NautilusIcons! ! !AbstractNautilusUI class methodsFor: 'icon' stamp: 'EstebanLorenzano 2/4/2013 17:54'! resetClassesIconsCache ClassesIconsCache removeAll. ! ! !AbstractNautilusUI class methodsFor: 'icon'! resetIcon Icon := nil! ! !AbstractNautilusUI class methodsFor: 'icon'! resetIconCaches ClassesIconsCache removeAll. GroupsIconsCache removeAll. PackagesIconsCache removeAll.! ! !AbstractNautilusUI class methodsFor: 'instance creation'! on: aNautilus ^ self new model: aNautilus! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 16:33'! buildAnalyzeSubMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. (aBuilder item: #'Inst var references...') action: [target browseInstVarRefs]; parent: #Analyze; order: 0. (aBuilder item: #'Inst var assignments...') action: [target browseInstVarDefs]; parent: #Analyze; order: 100. (aBuilder item: #'Create inst var accessors') action: [target createInstVarAccessors]; parent: #Analyze; enabledBlock: [ target selectedClass instVarNames isEmpty not ]; order: 200; withSeparatorAfter. (aBuilder item: #'Create initializer with inst vars...') action: [ target createInitializerWithInstVars ]; parent: #Analyze; order: 300; enabledBlock: [ target showInstance ]. (aBuilder item: #'Generate initialize method') keyText: 'h, i' if: Nautilus useOldStyleKeys not; keyText: 'I' if: Nautilus useOldStyleKeys; action: [ target generateInitialize ]; parent: #Analyze; order: 350. (aBuilder item: #'Force the generaton of the initialize method') keyText: 'h, k' if: Nautilus useOldStyleKeys not; keyText: 'K' if: Nautilus useOldStyleKeys; action: [ target forceGenerateInitialize ]; parent: #Analyze; order: 375; enabledBlock: [ target showInstance ]; withSeparatorAfter. (aBuilder item: #'Class var refs...') action: [target browseClassVarRefs]; parent: #Analyze; order: 400. (aBuilder item: #'Class refs...') keyText: 'b, N' if: Nautilus useOldStyleKeys not; keyText: 'N' if: Nautilus useOldStyleKeys; action: [target browseClassRefs]; parent: #Analyze; order: 500. (aBuilder item: #'Browse comment versions...') action: [ target browseCommentVersionsOf: target selectedClass theNonMetaClass ]; parent: #Analyze; order: 600; withSeparatorAfter. (target selectedClass inheritsFrom: SharedPool ) ifTrue: [ (aBuilder item: #'Shared Pool Users') action: [ target systemNavigation browseSharedPoolUsersOf: target selectedClass ]; parent: #Analyze; enabledBlock: [ target enableSingleClassSelection ]; order: 700]. (aBuilder item: #'Unsent methods...') action: [target browseUnusedMethods.]; parent: #Analyze; order: 800. (aBuilder item: #'Unreferenced inst vars...') action: [target showUnreferencedInstVars.]; parent: #Analyze; order: 900. (aBuilder item: #'Unreferenced class vars...') action: [target showUnreferencedClassVars.]; parent: #Analyze; order: 1000.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 15:01'! classesFixMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Method...') keyText: 'f, m' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [target findMethod]; order: 100; help: 'Search for a method by selector'. (aBuilder item: #'Find Class...') keyText: 'f, c' if: Nautilus useOldStyleKeys not; keyText: 'F' if: Nautilus useOldStyleKeys; action: [ target findClass ]; order: 200; help: 'Search for a method by selector'. (aBuilder item: #'Add Class...') keyText: 'n, c' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [ target addClass ]; order: 400; help: 'Create a new class'. (aBuilder item: #'Add Trait...') action: [ target addTrait ]; order: 500; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [target fullBrowse]; order: 999; help: 'Open the same browser'.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 16:31'! classesMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. (aBuilder item: #'Rename...') keyText: 'r,c' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ target renameClass ]; enabledBlock: [ target selectedClasses size <= 1 ]; order: -99; withSeparatorAfter. (aBuilder item: #'Browse scoped') keyText: 'b, s' if: Nautilus useOldStyleKeys not; keyText: 'B' if: Nautilus useOldStyleKeys; action: [target restrictedBrowseClass]; order: 1000; help: 'Open a browser on a restricted view'. (aBuilder item: #'Add in Group...') keyText: 'n, e, c' if: Nautilus useOldStyleKeys not; keyText: 'e' if: Nautilus useOldStyleKeys; action: [ target addClassesInGroup ]; order: 1100; withSeparatorAfter. (target selectedClasses allSatisfy: [:each | each inheritsFrom: TestCase ]) ifTrue:[ (aBuilder item:#'Run tests') keyText: 'j, c' if: Nautilus useOldStyleKeys not; keyText: 't' if: Nautilus useOldStyleKeys; action: [ target runClassTests ]; order: 1200]. (aBuilder item: #Analyze) enabledBlock: [ target selectedClasses size <= 1 ]; order: 0; withSeparatorAfter. (aBuilder item: #'Jump to test class') keyText: 'g, j' if: Nautilus useOldStyleKeys not; keyText: 'j' if: Nautilus useOldStyleKeys; action: [ target createTestForSelectedClass ]; enabledBlock: [ target selectedClasses size <= 1 ]; order: 300; withSeparatorAfter. (aBuilder item: #'Move to package...') keyText: 'm, c' if: Nautilus useOldStyleKeys not; action: [ target moveInNewPackage ]; order: 1400. (aBuilder item: #'Copy...') keyText: 'c, c' if: Nautilus useOldStyleKeys not; keyText: 'c' if: Nautilus useOldStyleKeys; action: [ target copyClasses ]; order: 1600. (aBuilder item: #'Remove...') keyText: 'x, c' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; action: [ target removeClasses ]; icon: (target iconClass iconNamed: #removeIcon); order: 1700; withSeparatorAfter. (aBuilder item: #'File Out') action: [ target fileOutClass ]; withSeparatorAfter; order: 1800. target showGroups ifTrue: [ target selectedGroup isReadOnly ifFalse: [ (aBuilder item: #'Remove from Group') keyText: 'X' if: Nautilus useOldStyleKeys not; action: [ target removeClassFromGroup ]; order: 1900] ].! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:46'! debugMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #DebugMenu) order: 9999; label: 'DEBUG'; help: 'Open a browser on a restricted view'. (aBuilder item: #'Reset icons caches') order: 0; action: [ AbstractNautilusUI resetIconCaches. AbstractMethodWidget resetMethodsIconsCache ]; parent: #DebugMenu; help: 'Open a browser on a restricted view'. (aBuilder item: #'Inspect me') order: 100; action: [ target inspect ]; parent: #DebugMenu; help: 'Open a browser on a restricted view'. (aBuilder item: #'Inspect my model ') order: 200; action: [ target model inspect]; parent: #DebugMenu; help: 'Open a browser on a restricted view'.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 14:48'! groupsFixMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Class...') keyText: 'f, c' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [target findClass]; order: 0; help: 'Search for a class by name'. (aBuilder item: #'New group...') keyText: 'n, g' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [target addNewGroup]; order: 100; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [target fullBrowse]; order: 999.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 14:53'! groupsMenu: aBuilder | target | target := aBuilder model. target selectedGroup ifNil: [ ^ target ]. (aBuilder item: #'Browse scoped') keyText: 'b, s' if: Nautilus useOldStyleKeys not; action: [ target restrictedBrowseGroups: target selectedGroups ]; order: 1000; withSeparatorAfter. (aBuilder item: #'Run tests') keyText: 'j, g' if: Nautilus useOldStyleKeys not; keyText: 't' if: Nautilus useOldStyleKeys; action: [ target runTestsOfGroups: target selectedGroups notifying: true ]; order: 1100. (aBuilder item: #'Merge groups') action: [target mergeGroups]; enabledBlock: [ target selectedGroups size > 1]; order: 1200. target selectedGroup isNil ifFalse: [ target selectedGroup isReadOnly ifFalse: [ (aBuilder item: #'Rename...') keyText: 'r, g' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ target renameGroup ]; enabledBlock: [ target selectedGroups size <= 1]; order: 1300 ]. target selectedGroup removable ifTrue: [ (aBuilder item: #'Remove groups') keyText: 'x, g' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; icon: (target iconClass iconNamed: #removeIcon); action: [target removeGroups]; order: 1400 ] ]! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 14:39'! packagesFixMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Class...') keyText: 'f, c' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [target findClass]; order: 0; help: 'Search for a class by name'. (aBuilder item: #'Find Package...') keyText: 'f, p' if: Nautilus useOldStyleKeys not; keyText: 'F' if: Nautilus useOldStyleKeys; action: [ target findPackage ]; order: 100; help: 'Search for a package by name'; withSeparatorAfter. (aBuilder item: #'Add package...') keyText: 'n, p' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [target addPackage]; order: 200; help: 'Add a package'; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [target fullBrowse]; order: 999; help: 'Open the same browser'.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 16:20'! packagesMenu: aBuilder | package target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. (aBuilder item: #'Browse scoped') keyText: 'b, s' if: Nautilus useOldStyleKeys not; action: [ target restrictedBrowsePackage ]; order: 1000; help: 'Open a browser on a restricted view'; withSeparatorAfter. (aBuilder item: #'Rename...') keyText: 'r, p' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [target renamePackage]; order: 1100; help: 'Rename a package'; enabledBlock: [ target selectedPackages size < 2 ]. (aBuilder item: #'Remove...') keyText: 'x, p' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; action: [target removePackages ]; order: 1200; help: 'Remove a package'; icon: (target iconClass iconNamed: #removeIcon). (aBuilder item: #'Run tests...') keyText: 'j, p' if: Nautilus useOldStyleKeys not; keyText: 't' if: Nautilus useOldStyleKeys; action: [target runPackagesTestsNotifying: true ]; enabled: (package classes anySatisfy: [:e | e inheritsFrom: TestCase ]); order: 1250; help: 'Run tests'; withSeparatorAfter. (aBuilder item: #'File Out') action: [target fileOutPackage]; order: 1300; help: 'File out a package'; withSeparatorAfter. target selectedPackages size > 1 ifTrue: [ (aBuilder item: #'Add as Groups & Browse') keyText: 'n, g' if: Nautilus useOldStyleKeys not; action: [ target addPackagesAsGroupsAndBrowse ]; order: 1400; help: 'Create a group based on the current package and browse it'. (aBuilder item: #'Add as Groups') keyText: 'n, G' if: Nautilus useOldStyleKeys not; action: [ target addPackagesAsGroups ]; order: 1600; help: 'Create a group based on the current package'. (aBuilder item: #'Add as Group') action: [target addPackageAsGroup]; order: 1700; help: 'Create a group based on the current package'. ] ifFalse: [ (aBuilder item: #'Add as Group & Browse') keyText: 'n, g' if: Nautilus useOldStyleKeys not; keyText: 'G' if: Nautilus useOldStyleKeys; action: [ target addPackageAsGroupAndBrowse ]; order: 1500; help: 'Create a group based on the current package and browse it'. (aBuilder item: #'Add as Group') keyText: 'n, G' if: Nautilus useOldStyleKeys not; action: [target addPackageAsGroup]; order: 1700; help: 'Create a group based on the current package' ]. (aBuilder item: #'Add Matching Packages as Groups and Browse') keyText: 'n, m' if: Nautilus useOldStyleKeys not; keyText: 'M' if: Nautilus useOldStyleKeys; action: [ target addMatchingPackagesInGroupsAndBrowse ]; order: 1800. (aBuilder item: #'Add in Group...') keyText: 'n, e, p' if: Nautilus useOldStyleKeys not; action: [target addPackagesInGroup]; order: 1900; help: 'Add current package in a group'; withSeparatorAfter.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/1/2013 10:59'! shiftedSourceCodeMenu: aBuilder | donorMenu items | items := OrderedCollection new. donorMenu := SmalltalkEditor shiftedYellowButtonMenu. donorMenu submorphs doWithIndex: [:each :index | (each isKindOf: MenuLineMorph) ifTrue: [ items last withSeparatorAfter ] ifFalse: [ items add: ((aBuilder item: each contents asSymbol) keyText: each keyText; selector: each selector; target: each target; parent: #'Extended search...'; arguments: each arguments; order: (index*100)). each icon ifNotNil: [:ic | items last icon: ic ]]]. (items last: 2) doWithIndex: [:e :i | e order: (9998 + i) ]! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'MarcusDenker 2/15/2013 14:03'! sourceCodeMenu: aBuilder | donorMenu items | items := OrderedCollection new. donorMenu := SmalltalkEditor yellowButtonMenu. donorMenu submorphs doWithIndex: [:each :index | (each isKindOf: MenuLineMorph) ifTrue: [ items last withSeparatorAfter ] ifFalse: [ items add: ((aBuilder item: each contents asSymbol) keyText: each keyText; selector: each selector; target: each target; arguments: each arguments; order: (index*100)). each icon ifNotNil: [:ic | items last icon: ic ]]]. (items last: 2) doWithIndex: [:e :i | e order: (9998 + i) ]. (aBuilder item: #'Lock this text area') selector: #lockTextArea; target: aBuilder model; order: 0.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 15:20'! sourceCodeMenuExtra: aBuilder | target method | target := aBuilder model. target selectedClass ifNil: [ ^ self ]. method := target selectedMethod. ((target selectedClass inheritsFrom: TestCase) and: [ method notNil and: [ method selector beginsWith: 'test' ]]) ifTrue: [ (aBuilder item: #'Run Test') order: 1; keyText: 'j, m' if: Nautilus useOldStyleKeys not; action: #runTestForAMethod:notifying:; arguments: { target selectedMethod. true }; enabledBlock: [ target sourceTextArea hasUnacceptedEdits not ]; withSeparatorAfter ].! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'BenjaminVanRyseghem 4/6/2012 16:43'! buildClassShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusClassShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the selection'. (aBuilder shortcut: #restrictedBrowseClass) category: #NautilusClassShortcuts default: $b command shift do: [ :target | target restrictedBrowseClass ] description: 'Open a restricted browser'. (aBuilder shortcut: #copyClasses) category: #NautilusClassShortcuts default: $c command do: [ :target | target copyClasses ] description: 'Copy the selected classes'. (aBuilder shortcut: #addClassesInGroup) category: #NautilusClassShortcuts default: $e command do: [ :target | target addClassesInGroup ] description: 'Add the selected classes in a group'. (aBuilder shortcut: #findMethod) category: #NautilusClassShortcuts default: $f command do: [ :target | target findMethod ] description: 'Find a method'. (aBuilder shortcut: #findClass) category: #NautilusClassShortcuts default: $f command shift do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #generateInitialize) category: #NautilusClassShortcuts default: $i command shift do: [ :target | target generateInitialize ] description: 'Generate the initialize method'. (aBuilder shortcut: #createTestForSelectedClass) category: #NautilusClassShortcuts default: $j command do: [ :target | target enableSingleClassSelection ifTrue: [ target createTestForSelectedClass ]] description: 'Generate a test class for the selected class'. (aBuilder shortcut: #forceGenerateInitialize) category: #NautilusClassShortcuts default: $k command shift do: [ :target | target forceGenerateInitialize ] description: 'Regenerate the initialize method'. (aBuilder shortcut: #browseClassRefs) category: #NautilusClassShortcuts default: $n command shift do: [ :target | target browseClassRefs ] description: 'Browse class references'. (aBuilder shortcut: #addClass) category: #NautilusClassShortcuts default: $n command do: [ :target | target addClass ] description: 'Add a class'. (aBuilder shortcut: #renameClass) category: #NautilusClassShortcuts default: $r command do: [ :target | target enableSingleClassSelection ifTrue: [ target renameClass ]] description: 'Rename the selected class'. (aBuilder shortcut: #runClassTests) category: #NautilusClassShortcuts default: $t command do: [ :target | target runClassTests ] description: 'Run the tests for the selected class'. (aBuilder shortcut: #removeClasses) category: #NautilusClassShortcuts default: $x command do: [ :target | target removeClasses ] description: 'Remove the selected classes'. (aBuilder shortcut: #removeClassesFromGroup) category: #NautilusClassShortcuts default: $x command shift do: [ :target | (target showGroups and: [ target selectedGroup isReadOnly not ]) ifTrue: [ target removeClassFromGroup ]] description: 'Remove the selected classes from the selected group'! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'EstebanLorenzano 2/6/2013 16:41'! buildCommentShortcutsOn: aBuilder self buildEditorCommentKeymappingsOldOn: aBuilder. (aBuilder shortcut: #runTest) category: #NautilusCommentShortcuts default: $t command do: [:target | (target selectedMethod isTestMethod and: [ target commentTextArea hasUnacceptedEdits not ]) ifTrue: [ target runTestForAMethod: target selectedMethod notifying: true ]] description: 'Run the current test method'.! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'EstebanLorenzano 2/6/2013 16:41'! buildEditorCommentKeymappingsOldOn: aBuilder (aBuilder shortcut: #selectAll) category: #NautilusCommentShortcuts default: $a command do: [ :target | target commentTextArea handleEdit: [ target commentTextArea selectAll ] ]. (aBuilder shortcut: #copySelection) category: #NautilusCommentShortcuts default: $c command do: [ :target | target commentTextArea copySelection ]. (aBuilder shortcut: #find) category: #NautilusCommentShortcuts default: $f command do: [ :target | target commentTextArea find ]. (aBuilder shortcut: #findAgain) category: #NautilusCommentShortcuts default: $g command do: [ :target | target commentTextArea findAgain ]. (aBuilder shortcut: #setSearchString) category: #NautilusCommentShortcuts default: $h command do: [ :target | target commentTextArea setSearchString ]. (aBuilder shortcut: #cancel) category: #NautilusCommentShortcuts default: $l command do: [ :target | target commentTextArea cancel ]. (aBuilder shortcut: #paste) category: #NautilusCommentShortcuts default: $v command do: [ :target | target commentTextArea paste ]. (aBuilder shortcut: #cut) category: #NautilusCommentShortcuts default: $x command do: [ :target | target commentTextArea cut ]. (aBuilder shortcut: #undo) category: #NautilusCommentShortcuts default: $z command do: [ :target | target commentTextArea undo ]. (aBuilder shortcut: #redo) category: #NautilusCommentShortcuts default: $z command shift do: [ :target | target commentTextArea redo ]. (aBuilder shortcut: #cursorHome) category: #NautilusCommentShortcuts default: Character home command do: [ :target :morph :event | target commentTextArea cursorHome: event ]. (aBuilder shortcut: #cursorEnd) category: #NautilusCommentShortcuts default: Character end command do: [ :target :morph :event | target commentTextArea cursorEnd: event ]. (aBuilder shortcut: #browseIt) category: #NautilusCommentShortcuts default: $b command do: [ :target | target commentTextArea browseIt ]. (aBuilder shortcut: #doIt) category: #NautilusCommentShortcuts default: $d command do: [ :target | target commentTextArea doIt ]. (aBuilder shortcut: #inspectIt) category: #NautilusCommentShortcuts default: $i command do: [ :target | target commentTextArea inspectIt ]. (aBuilder shortcut: #implementorsOfIt) category: #NautilusCommentShortcuts default: $m command do: [ :target | target commentTextArea implementorsOfIt ]. (aBuilder shortcut: #sendersOfIt) category: #NautilusCommentShortcuts default: $n command do: [ :target | target commentTextArea sendersOfIt ]. (aBuilder shortcut: #printIt) category: #NautilusCommentShortcuts default: $p command do: [ :target | target commentTextArea printIt ].! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'CamilloBruni 10/7/2012 22:04'! buildGroupShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusGroupShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the current selection'. (aBuilder shortcut: #restrictedBrowseGroup) category: #NautilusGroupShortcuts default: $b command shift do: [ :target | target restrictedBrowseGroups: target selectedGroups ] description: 'Open a browser on a restricted view'. (aBuilder shortcut: #findClass) category: #NautilusGroupShortcuts default: $f command do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #addNewGroup) category: #NautilusGroupShortcuts default: $n command do: [ :target | target addNewGroup ] description: 'Create a new group'. (aBuilder shortcut: #renameGroup) category: #NautilusGroupShortcuts default: $r command do: [ :target | target enableSingleMenuItems ifTrue:[ target renameGroup ]] description: 'Rename the selected group'. (aBuilder shortcut: #runTestsOfGroups) category: #NautilusGroupShortcuts default: $t command do: [ :target | target runTestsOfGroups: target selectedGroups notifying: true ] description: 'Run the tests of the selected groups'. (aBuilder shortcut: #removeGroups) category: #NautilusGroupShortcuts default: $x command do: [ :target | target removeGroups ] description: 'Remove the selected groups'.! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'EstebanLorenzano 2/6/2013 17:58'! buildPackageShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusPackageShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the selection'. (aBuilder shortcut: #addPackagesInGroup) category: #NautilusPackageShortcuts default: $e command do: [ :target | target addPackagesInGroup ] description: 'Add the selected package in a group'. (aBuilder shortcut: #findClass) category: #NautilusPackageShortcuts default: $f command do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #findPackage) category: #NautilusPackageShortcuts default: $f command shift do: [ :target | target findPackage ] description: 'Find a package'. (aBuilder shortcut: #addPackagesAsGroupsAndBrowse) category: #NautilusPackageShortcuts default: $g command do: [ :target | target addPackagesAsGroupsAndBrowse ] description: 'Add the selected packages as groups and browse'. (aBuilder shortcut: #addPackagesAsGroups) category: #NautilusPackageShortcuts default: $g command shift do: [ :target | target addPackageAsGroupAndBrowse ] description: 'Add the selected packages as groups'. (aBuilder shortcut: #addMatchingPackagesInGroupsAndBrowse) category: #NautilusPackageShortcuts default: $m command shift do: [ :target | target addMatchingPackagesInGroupsAndBrowse ] description: 'Add packages matching the selected package as groups and browse'. (aBuilder shortcut: #addMatchingPackagesInGroups) category: #NautilusPackageShortcuts default: $m command do: [ :target | target addMatchingPackagesInGroups ] description: 'Add packages matching the selected package as groups'. (aBuilder shortcut: #addPackage) category: #NautilusPackageShortcuts default: $n command do: [ :target | target addPackage ] description: 'Add a new package'. (aBuilder shortcut: #renamePackage) category: #NautilusPackageShortcuts default: $r command do: [ :target | target enableSingleMenuItems ifTrue: [ target renamePackage ]] description: 'Rename the selected package'. (aBuilder shortcut: #runPackagesTests) category: #NautilusPackageShortcuts default: $t command do: [ :target | target runPackagesTestsNotifying: true ] description: 'Run the tests for the selected packages'. (aBuilder shortcut: #removePackages) category: #NautilusPackageShortcuts default: $x command do: [ :target | target removePackages ] description: 'Remove the selected packages'.! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'EstebanLorenzano 2/6/2013 15:19'! buildSourceCodeShortcutsOn: aBuilder self buildEditorKeymappingsOn: aBuilder. (aBuilder shortcut: #runTest) category: #NautilusSourceCodeShortcuts default: $j command, $m command do: [:target | (target selectedMethod isTestMethod and: [ target sourceTextArea hasUnacceptedEdits not ]) ifTrue: [ target runTestForAMethod: target selectedMethod notifying: true ]] description: 'Run the current test method'. "This is not working anyway" "(aBuilder shortcut: #findClass) category: #NautilusSourceCodeShortcuts default: $f command, $c command do: [:target | target findClass ] description: 'Find class'."! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 1/30/2013 14:22'! buildAddGroupsShortcutsOn: aBuilder (aBuilder shortcut: #newGroupAndBrowseForPackage) category: #NautilusGlobalShortcuts default: $n command ,$g command do: [ :target | target addPackagesAsGroupsAndBrowse ] description: 'Create a new group and browse'. (aBuilder shortcut: #newGroupForPackage) category: #NautilusGlobalShortcuts default: $n command , $g shift command do: [ :target | target addPackagesAsGroups ] description: 'Create a new group'. (aBuilder shortcut: #addInGroupPackage) category: #NautilusGlobalShortcuts default: $n command , $e command, $p command do: [ :target | target addPackagesInGroup ] description: 'Add the selected packages in a group'. (aBuilder shortcut: #addInGroupMethod) category: #NautilusGlobalShortcuts default: $n command , $e command, $m command do: [ :target | target addMethodsInGroup ] description: 'Add the selected methods in a group'. (aBuilder shortcut: #addInGroupClass) category: #NautilusGlobalShortcuts default: $n command , $e command, $c command do: [ :target | target addClassesInGroup ] description: 'Add the selected classes in a group'. (aBuilder shortcut: #addMatchingAndBrowse) category: #NautilusGlobalShortcuts default: $n command , $m command do: [ :target | target addMatchingPackagesInGroupsAndBrowse ] description: 'Add packages matching the selected package as groups and browse'. (aBuilder shortcut: #addInGroupMethod) category: #NautilusGlobalShortcuts default: $n command , $m command shift do: [ :target | target addMatchingPackagesInGroups ] description: 'Add packages matching the selected package as groups'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 14:52'! buildAddShortcutsOn: aBuilder (aBuilder shortcut: #newClass) category: #NautilusGlobalShortcuts default: $n command ,$c command do: [ :target | target addClass ] description: 'Create a new class'. (aBuilder shortcut: #newPackage) category: #NautilusGlobalShortcuts default: $n command , $p command do: [ :target | target addPackage ] description: 'Create a new package'. (aBuilder shortcut: #newProtocol) category: #NautilusGlobalShortcuts default: $n command , $t command do: [ :target | target addCategory ] description: 'Create a new protocol'. (aBuilder shortcut: #newGroup) category: #NautilusGlobalShortcuts default: $n command , $g command do: [ :target | target addNewGroup ] description: 'Create a new group'. " (aBuilder shortcut: #newMethod) category: #NautilusGlobalShortcuts default: $n command , $m command do: [ :target | target addMethod ] description: 'Create a new method'."! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 1/30/2013 14:23'! buildBrowseShortcutsOn: aBuilder (aBuilder shortcut: #browseSenders) category: #NautilusGlobalShortcuts default: $b command , $n command do: [:target | target browseSendersOfMessages ] description: 'Browse senders of the selected method'. (aBuilder shortcut: #browseClassRefs) category: #NautilusGlobalShortcuts default: $b command, $n command shift do: [ :target | target browseClassRefs ] description: 'Browse class references'. (aBuilder shortcut: #browseImplementors) category: #NautilusGlobalShortcuts default: $b command , $m command do: [:target | target browseMessages ] description: 'Browse implementors of the selected method'. "(aBuilder shortcut: #browseRestricted) category: #NautilusGlobalShortcuts default: $b command , $s command do: [:target | target restrictedBrowse ] description: 'Open a restricted browser'." (aBuilder shortcut: #browseRestrictedClass) category: #NautilusGlobalShortcuts default: $b command , $r command , $c command do: [:target | target restrictedBrowseClass ] description: 'Open a restricted browser on the selected class'. (aBuilder shortcut: #browseSuperclass) category: #NautilusGlobalShortcuts default: $b command , $s command shift do: [:target | target browseSuperclass ] description: 'Open a browser on the superclass of the selected class'. (aBuilder shortcut: #browseRestrictedPackage) category: #NautilusGlobalShortcuts default: $b command , $r command , $p command do: [:target | target restrictedBrowsePackage ] description: 'Open a restricted browser on the selected package'. (aBuilder shortcut: #browseRestrictedRegex) category: #NautilusGlobalShortcuts default: $b command , $r command , $r command do: [:target | target restrictedBrowsePackageRegex ] description: 'Open a restricted browser on a package regex'. (aBuilder shortcut: #browseRestrictedSuperclasses) category: #NautilusGlobalShortcuts default: $b command , $r command , $S shift command do: [:target | target restrictedBrowseSuperclasses ] description: 'Open a restricted browser the superclasses'. (aBuilder shortcut: #browseRestrictedSubclasses) category: #NautilusGlobalShortcuts default: $b command , $r command , $s command do: [:target | target restrictedBrowseSubclasses ] description: 'Open a restricted browser the subclasses'. (aBuilder shortcut: #browseInheritance) category: #NautilusGlobalShortcuts default: $b command , $i command do: [:target | target methodHierarchy ] description: 'Open a restricted browser'. (aBuilder shortcut: #browseFull) category: #NautilusGlobalShortcuts default: $b command , $f command do: [:target | target fullBrowse ] description: 'Open the same browser'. (aBuilder shortcut: #browseVersion) category: #NautilusGlobalShortcuts default: $b command , $v command do: [:target | target browseVersions ] description: 'Browse senders of the selected method'. ! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 9/14/2012 01:28'! buildButtonsShortcutsOn: aBuilder (aBuilder shortcut: #showPackage) category: #NautilusGlobalShortcuts default: $t command ,$p command do: [ :target | target showGroups: false ] description: 'Find a class'. (aBuilder shortcut: #showGroup) category: #NautilusGlobalShortcuts default: $t command , $g command do: [ :target | target showGroups: true ] description: 'Find a package'. (aBuilder shortcut: #showInstanceSide) category: #NautilusGlobalShortcuts default: $t command ,$i command do: [ :target | target showInstance: true ] description: 'Show instance side'. (aBuilder shortcut: #showClassSide) category: #NautilusGlobalShortcuts default: $t command ,$c command do: [ :target | target showInstance: false ] description: 'Show class side'. (aBuilder shortcut: #showHierarchy) category: #NautilusGlobalShortcuts default: $t command ,$h command do: [ :target | target showPackages: false ] description: 'Show Hierarchy'. (aBuilder shortcut: #showFlat) category: #NautilusGlobalShortcuts default: $t command ,$f command do: [ :target | target showPackages: true ] description: 'Show normal view'. ! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 19:06'! buildCopyShortcutsOn: aBuilder (aBuilder shortcut: #copyClass) category: #NautilusGlobalShortcuts default: $c command , $c command do: [ :target | target copyClasses ] description: 'Copy the selected classes'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 8/1/2012 19:13'! buildEditorCommentKeymappingsOn: aBuilder (aBuilder shortcut: #selectAll) category: #NautilusCommentShortcuts default: $a command do: [ :target | target commentTextArea handleEdit: [ target commentTextArea selectAll ] ]. (aBuilder shortcut: #copySelection) category: #NautilusCommentShortcuts default: $c command do: [ :target | target commentTextArea copySelection ]. (aBuilder shortcut: #find) category: #NautilusCommentShortcuts default: $f command, $f command do: [ :target | target commentTextArea find ]. (aBuilder shortcut: #findAgain) category: #NautilusCommentShortcuts default: $f command, $g command do: [ :target | target commentTextArea findAgain ]. (aBuilder shortcut: #setSearchString) category: #NautilusCommentShortcuts default: $h command do: [ :target | target commentTextArea setSearchString ]. (aBuilder shortcut: #cancel) category: #NautilusCommentShortcuts default: $l command do: [ :target | target commentTextArea cancel ]. (aBuilder shortcut: #paste) category: #NautilusCommentShortcuts default: $v command do: [ :target | target commentTextArea paste ]. (aBuilder shortcut: #cut) category: #NautilusCommentShortcuts default: $x command do: [ :target | target commentTextArea cut ]. (aBuilder shortcut: #undo) category: #NautilusCommentShortcuts default: $z command do: [ :target | target commentTextArea undo ]. (aBuilder shortcut: #redo) category: #NautilusCommentShortcuts default: $z command shift do: [ :target | target commentTextArea redo ]. (aBuilder shortcut: #cursorHome) category: #NautilusCommentShortcuts default: Character home command do: [ :target :morph :event | target commentTextArea cursorHome: event ]. (aBuilder shortcut: #cursorEnd) category: #NautilusCommentShortcuts default: Character end command do: [ :target :morph :event | target commentTextArea cursorEnd: event ]. (aBuilder shortcut: #browseIt) category: #NautilusCommentShortcuts default: $b command do: [ :target | target commentTextArea browseIt ]. (aBuilder shortcut: #doIt) category: #NautilusCommentShortcuts default: $d command do: [ :target | target commentTextArea doIt ]. (aBuilder shortcut: #inspectIt) category: #NautilusCommentShortcuts default: $i command do: [ :target | target commentTextArea inspectIt ]. (aBuilder shortcut: #implementorsOfIt) category: #NautilusCommentShortcuts default: $m command do: [ :target | target commentTextArea implementorsOfIt ]. (aBuilder shortcut: #sendersOfIt) category: #NautilusCommentShortcuts default: $n command do: [ :target | target commentTextArea sendersOfIt ]. (aBuilder shortcut: #printIt) category: #NautilusCommentShortcuts default: $p command do: [ :target | target commentTextArea printIt ].! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 19:10'! buildEditorKeymappingsOn: aBuilder (aBuilder shortcut: #selectAll) category: #NautilusSourceCodeShortcuts default: $a command do: [ :target | target sourceTextArea handleEdit: [ target sourceTextArea selectAll ] ]. (aBuilder shortcut: #copySelection) category: #NautilusSourceCodeShortcuts default: $c command do: [ :target | target sourceTextArea copySelection ]. (aBuilder shortcut: #find) category: #NautilusSourceCodeShortcuts default: $f command, $f command do: [ :target | target sourceTextArea find ]. (aBuilder shortcut: #findAgain) category: #NautilusSourceCodeShortcuts default: $f command, $g command do: [ :target | target sourceTextArea findAgain ]. (aBuilder shortcut: #setSearchString) category: #NautilusSourceCodeShortcuts default: $h command do: [ :target | target sourceTextArea setSearchString ]. (aBuilder shortcut: #cancel) category: #NautilusSourceCodeShortcuts default: $l command do: [ :target | target sourceTextArea cancel ]. (aBuilder shortcut: #paste) category: #NautilusSourceCodeShortcuts default: $v command do: [ :target | target sourceTextArea paste ]. (aBuilder shortcut: #cut) category: #NautilusSourceCodeShortcuts default: $x command do: [ :target | target sourceTextArea cut ]. (aBuilder shortcut: #undo) category: #NautilusSourceCodeShortcuts default: $z command do: [ :target | target sourceTextArea undo ]. (aBuilder shortcut: #redo) category: #NautilusSourceCodeShortcuts default: $z command shift do: [ :target | target sourceTextArea redo ]. (aBuilder shortcut: #cursorHome) category: #NautilusSourceCodeShortcuts default: Character home command do: [ :target :morph :event | target sourceTextArea cursorHome: event ]. (aBuilder shortcut: #cursorEnd) category: #NautilusSourceCodeShortcuts default: Character end command do: [ :target :morph :event | target sourceTextArea cursorEnd: event ]. (aBuilder shortcut: #browseIt) category: #NautilusSourceCodeShortcuts default: $b command do: [ :target | target sourceTextArea browseIt ]. (aBuilder shortcut: #doIt) category: #NautilusSourceCodeShortcuts default: $d command do: [ :target | target sourceTextArea doIt ]. (aBuilder shortcut: #inspectIt) category: #NautilusSourceCodeShortcuts default: $i command do: [ :target | target sourceTextArea inspectIt ]. (aBuilder shortcut: #implementorsOfIt) category: #NautilusSourceCodeShortcuts default: $m command do: [ :target | target sourceTextArea implementorsOfIt ]. (aBuilder shortcut: #sendersOfIt) category: #NautilusSourceCodeShortcuts default: $n command do: [ :target | target sourceTextArea sendersOfIt ]. (aBuilder shortcut: #printIt) category: #NautilusSourceCodeShortcuts default: $p command do: [ :target | target sourceTextArea printIt ].! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 1/11/2013 14:07'! buildExtraShortcutsOn: aBuilder (aBuilder shortcut: #openBrowser) category: #NautilusGlobalShortcuts default: $o command, $o command do: [:target| target fullBrowse ] description: 'Open a new browser'. (aBuilder shortcut: #openBrowserOnSubclass) category: #NautilusGlobalShortcuts default: $o command, $s command do: [:target| target openSubclass ] description: 'Open a new browser on a subclass'. (aBuilder shortcut: #openBrowserOnSuperclass) category: #NautilusGlobalShortcuts default: $o command, $s command shift do: [:target| target openSuperclass ] description: 'Open a new browser on a superclass'. (aBuilder shortcut: #openBrowserOnClass) category: #NautilusGlobalShortcuts default: $o command, $c command do: [:target| target openClass ] description: 'Open a new browser on a class'. ! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 9/14/2012 01:31'! buildFindShortcutsOn: aBuilder (aBuilder shortcut: #findClass) category: #NautilusGlobalShortcuts default: $f command , $c command do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #findClassInHierarchy) category: #NautilusGlobalShortcuts default: $f command , $h command do: [ :target | target findClassInHierarchy ] description: 'Find a class in the hierarchy'. (aBuilder shortcut: #findSuperclass) category: #NautilusGlobalShortcuts default: $f command , $S shift command do: [ :target | target findSuperclass] description: 'Find a superclass'. (aBuilder shortcut: #findSubclass) category: #NautilusGlobalShortcuts default: $f command , $s command do: [ :target | target findSubclass] description: 'Find a subclass'. (aBuilder shortcut: #findPackage) category: #NautilusGlobalShortcuts default: $f command , $p command do: [ :target | target findPackage ] description: 'Find a package'. (aBuilder shortcut: #findProtocol) category: #NautilusGlobalShortcuts default: $f command , $t command do: [ :target | target findProtocol ] description: 'Find a protocol'. (aBuilder shortcut: #findMethod) category: #NautilusGlobalShortcuts default: $f command , $m command do: [ :target | target findMethod ] description: 'Find a method'. (aBuilder shortcut: #findRespondingMethod) category: #NautilusGlobalShortcuts default: $f command, $M shift command do: [ :target | target findAllMethod ] description: 'Find methods instances of this class may respond to'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 10/4/2012 10:39'! buildGotoNavigationShortcutsOn: aBuilder (aBuilder shortcut: #jumpToClass) category: #NautilusGlobalShortcuts default: $g command , $c command do: [ :target | target giveFocusToClass ] description: 'Jump to the selected class'. (aBuilder shortcut: #jumpToPackage) category: #NautilusGlobalShortcuts default: $g command, $p command do: [ :target | target giveFocusToPackage ] description: 'Jump to the selected package'. (aBuilder shortcut: #jumpToProtocol) category: #NautilusGlobalShortcuts default: $g command , $t command do: [ :target | target giveFocusToProtocol ] description: 'Jump to the selected protocol'. (aBuilder shortcut: #jumpToMethod) category: #NautilusGlobalShortcuts default: $g command , $m command do: [ :target | target giveFocusToMethod ] description: 'Jump to the selected method'. (aBuilder shortcut: #jumpToSourceCode) category: #NautilusGlobalShortcuts default: $g command , $s command do: [ :target | target giveFocusToSourceCode ] description: 'Jump to the selected method'. (aBuilder shortcut: #jumpToTestClass) category: #NautilusGlobalShortcuts default: $g command , $j command , $c command do: [ :target | target createTestForSelectedClass ] description: 'Jump to test class'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 19:02'! buildRecategorizeShortcutsOn: aBuilder (aBuilder shortcut: #recategorizeMethod) category: #NautilusGlobalShortcuts default: $m command , $m command do: [ :target | target categorizeMethod ] description: 'Categorize the selected method'. (aBuilder shortcut: #recategorizeClass) category: #NautilusGlobalShortcuts default: $m command , $c command do: [ :target | target moveInNewPackage ] description: 'Categorize the selected class'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 15:16'! buildRefactoringShortcutsOn: aBuilder (aBuilder shortcut: #generateInitialize) category: #NautilusGlobalShortcuts default: $h command, $i command do: [ :target | target generateInitialize ] description: 'Generate the initialize method'. (aBuilder shortcut: #forceGenerateInitialize) category: #NautilusGlobalShortcuts default: $h command, $k command do: [ :target | target forceGenerateInitialize ] description: 'Regenerate the initialize method'. (aBuilder shortcut: #createTestForSelectedClass) category: #NautilusGlobalShortcuts default: $n command, $j command, $c command do: [ :target | target enableSingleClassSelection ifTrue: [ target createTestForSelectedClass ]] description: 'Generate a test class for the selected class'. (aBuilder shortcut: #generateTestAndJump) category: #NautilusGlobalShortcuts default: $h command, $j command do: [ :target | target generateTestMethodsAndFocus: true ] description: 'Generate test and jump'. (aBuilder shortcut: #generateTest) category: #NautilusGlobalShortcuts default: $h command, $j command shift do: [ :target | target generateTestMethodsAndFocus: false ] description: 'Generate test'. (aBuilder shortcut: #categorizeAllUncategorized) category: #NautilusGlobalShortcuts default: $h command, $c command shift do: [ :target | target categorizeAllUncategorizedMethods ] description: 'Categorize all uncategorized'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 14:54'! buildRemoveShortcutsOn: aBuilder (aBuilder shortcut: #removeClass) category: #NautilusGlobalShortcuts default: $x command ,$c command do: [ :target | target removeClasses ] description: 'Remove the selected classes'. (aBuilder shortcut: #removePackage) category: #NautilusGlobalShortcuts default: $x command , $p command do: [ :target | target removePackages ] description: 'Remove the selected packages'. (aBuilder shortcut: #removeProtocol) category: #NautilusGlobalShortcuts default: $x command , $t command do: [ :target | target removeCategories ] description: 'Remove the selected protocols'. (aBuilder shortcut: #removeMethod) category: #NautilusGlobalShortcuts default: $x command , $m command do: [ :target | target removeMethods ] description: 'Remove the selected methods'. (aBuilder shortcut: #removeGroups) category: #NautilusGlobalShortcuts default: $x command , $g command do: [ :target | target removeGroups ] description: 'Remove the selected groups'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 14:53'! buildRenameShortcutsOn: aBuilder (aBuilder shortcut: #renameClass) category: #NautilusGlobalShortcuts default: $r command ,$c command do: [ :target | target renameClass ] description: 'Rename the selected class'. (aBuilder shortcut: #renamePackage) category: #NautilusGlobalShortcuts default: $r command , $p command do: [ :target | target renamePackage ] description: 'Rename the selected package'. (aBuilder shortcut: #renameProtocol) category: #NautilusGlobalShortcuts default: $r command , $t command do: [ :target | target renameCategory ] description: 'Rename the selected protocol'. (aBuilder shortcut: #renameGroup) category: #NautilusGlobalShortcuts default: $r command , $g command do: [ :target | target renameGroup ] description: 'Rename the selected group'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 18:05'! buildRunTestKeymappingsOn: aBuilder (aBuilder shortcut: #runTestForClasses) category: #NautilusGlobalShortcuts default: $j command ,$c command do: [ :target | target runClassTests ] description: 'runTestFor the selected classes'. (aBuilder shortcut: #runTestForPackages) category: #NautilusGlobalShortcuts default: $j command , $p command do: [ :target | target runPackagesTestsNotifying: true ] description: 'runTestFor the selected packages'. (aBuilder shortcut: #runTestForGroups) category: #NautilusGlobalShortcuts default: $j command , $g command do: [ :target | target runTestsOfGroups: target selectedGroups notifying: true ] description: 'runTestFor the selected groups'. (aBuilder shortcut: #runTestForMethods) category: #NautilusGlobalShortcuts default: $j command , $m command do: [ :target | target runTestForMethods: target selectedMethods notifying: true ] description: 'runTestFor the selected methods'.! ! !AbstractNautilusUI class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/25/2012 11:07'! initialize " self initialize " ClassesIconsCache := WeakIdentityKeyDictionary new. GroupsIconsCache := WeakIdentityKeyDictionary new. PackagesIconsCache := WeakIdentityKeyDictionary new. Icon := self buildIcon. NextFocusKey := Character arrowRight. PreviousFocusKey := Character arrowLeft.! ! TestCase subclass: #AbstractNautilusUITest instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Tests'! !AbstractNautilusUITest commentStamp: '' prior: 0! An AbstractNautilusUITest is a test class for testing the behavior of AbstractNautilusUI! !AbstractNautilusUITest methodsFor: 'initialization'! setUp "Setting up code for AbstractNautilusUITest" model := AbstractNautilusUI new.! ! !AbstractNautilusUITest methodsFor: 'initialization'! tearDown "Tearing down code for AbstractNautilusUITest" ! ! !AbstractNautilusUITest methodsFor: 'tests'! testSortClassesInCachedHierarchyB! ! Object subclass: #AbstractObjectsAsMethod instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-ObjectsAsMethods'! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:25'! flushCache! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:23'! methodClass: aMethodClass! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'MarcusDenker 2/11/2013 16:06'! origin ^self class! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'MarcusDenker 2/11/2013 15:34'! pragmas ^#()! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:23'! selector: aSymbol! ! AbstractNautilusPlugin subclass: #AbstractPackageSelectedPlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractPackageSelectedPlugin commentStamp: '' prior: 0! AbstractKeyPressedPlugin is an abstraction of plugin which react when a package is selected! !AbstractPackageSelectedPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/10/2011 14:39'! packageSelected: anAnnouncement ^ self subclassResponsibility! ! !AbstractPackageSelectedPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 5/10/2011 12:35'! registerTo: aModel aModel announcer on: NautilusPackageSelected send: #packageSelected: to: self! ! AbstractWidget subclass: #AbstractPackageWidget instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractPackageWidget commentStamp: '' prior: 0! AbstractPackageWidget is an abstraction describing a widget used to manage packages! Morph subclass: #AbstractResizerMorph instanceVariableNames: 'dotColor handleColor lastMouse' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0! I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/27/2008 21:34'! adoptPaneColor: paneColor "Just get the resizer fill style for the theme." paneColor ifNil: [^super adoptPaneColor: paneColor]. self fillStyle: (self theme resizerGripNormalFillStyleFor: self)! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'jrp 7/5/2005 21:37'! handlesMouseOver: anEvent ^ true ! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:36'! mouseEnter: anEvent self isCursorOverHandle ifTrue: [self setInverseColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation" anEvent hand showTemporaryCursor: self resizeCursor]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:36'! mouseLeave: anEvent anEvent hand showTemporaryCursor: nil. self setDefaultColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation"! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:59'! mouseUp: anEvent "Change the cursor back to normal if necessary." (self bounds containsPoint: anEvent cursorPoint) ifFalse: [ anEvent hand showTemporaryCursor: nil. self setDefaultColors; changed]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:20'! shouldDraw "Answer whether the resizer should be drawn." ^self fillStyle isTransparent not! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:35'! shouldInvalidateOnMouseTransition "Answer whether the resizer should be invalidated when the mouse enters or leaves." ^false! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:36'! dotColor ^ dotColor ifNil: [self setDefaultColors. dotColor]! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:35'! handleColor ^ handleColor ifNil: [self setDefaultColors. handleColor]! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:37'! resizeCursor self subclassResponsibility! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/29/2005 13:25'! setDefaultColors handleColor := Color lightGray lighter lighter. dotColor := Color gray lighter! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/30/2005 21:30'! setInverseColors handleColor := Color lightGray. dotColor := Color white! ! !AbstractResizerMorph methodsFor: 'event handling' stamp: 'jrp 7/5/2005 21:37'! handlesMouseDown: anEvent ^ true! ! !AbstractResizerMorph methodsFor: 'event handling' stamp: 'jrp 7/5/2005 21:42'! mouseDown: anEvent lastMouse := anEvent cursorPoint! ! !AbstractResizerMorph methodsFor: 'initialize' stamp: 'md 2/24/2006 23:01'! initialize super initialize. self color: Color transparent! ! !AbstractResizerMorph methodsFor: 'testing' stamp: 'jrp 7/5/2005 21:40'! isCursorOverHandle ^ true! ! Object subclass: #AbstractSoundSystem instanceVariableNames: '' classVariableNames: 'SoundEnabled SoundQuickStart' poolDictionaries: '' category: 'System-Sound'! !AbstractSoundSystem commentStamp: 'AlainPlantec 1/7/2010 21:36' prior: 0! This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example: SoundService default playSoundNamed: 'croak' The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the SoundSettings class>>soundEnabled Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! randomBitsFromSoundInput: bitCount self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! sampledSoundChoices self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! shutDown "Default is to do nothing."! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'! soundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'! beep "Make a primitive beep." self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'! playSampledSound: samples rate: rate self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'! playSoundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamedOrBeep: soundName self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractSoundSystem class instanceVariableNames: ''! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundEnabled ^ SoundEnabled ifNil: [SoundEnabled := false]! ! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundEnabled: aBoolean SoundEnabled := aBoolean! ! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundQuickStart ^ SoundQuickStart ifNil: [SoundQuickStart := false]! ! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundQuickStart: aBoolean SoundQuickStart := aBoolean! ! Object subclass: #AbstractSpec instanceVariableNames: 'instance bindings' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !AbstractSpec commentStamp: '' prior: 0! An AbstractSpec is a basic wrapper which describe a spec. For now it can seems useless, but structural info will be stored thanks to those wrappers! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 00:51'! bindings ^ bindings! ! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 00:51'! bindings: anObject bindings := anObject! ! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 01:19'! instance ^ instance ifNil: [ instance := self initializeInstance. ]! ! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 02:24'! instance: anObject instance := anObject! ! !AbstractSpec methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 4/24/2012 10:47'! initialize "Initialization code for AbstractSpec" super initialize. bindings := BindingsHolder new.! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 18:39'! addAsSubSpecTo: anotherSpec anotherSpec addSubSpec: self.! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 03:14'! model: aModel "nothing by default"! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2012 11:18'! removeSubWidgets ^ SpecInterpreter interpretASpec: #(model removeSubWidgets) model: self instance! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 20:42'! subSpecs ^ #()! ! !AbstractSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 01:22'! classSymbol self subclassResponsibility! ! !AbstractSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 10:47'! defaultReceiver ^ Smalltalk at: (self bindings retrieveClassSymbolFor: (self classSymbol))! ! !AbstractSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/12/2012 15:19'! initializeInstance ^ SpecInterpreter private_interpretASpec: { self classSymbol. #color:. #(Color class white)} model: DummyComposableModel new! ! Object subclass: #AbstractSpecLayoutAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Layout'! !AbstractSpecLayoutAction commentStamp: '' prior: 0! AbstractSpecLayoutAction is an abstract class representing a spec layout action.! !AbstractSpecLayoutAction methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/18/2012 04:47'! asSpecElements self subclassResponsibility ! ! !AbstractSpecLayoutAction methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/31/2012 15:10'! generateArguments ! ! AbstractNautilusPlugin subclass: #AbstractTextChangedPlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractTextChangedPlugin commentStamp: '' prior: 0! An AbstractTextChangedPlugin is a plugin which simply log each time the method displayer changed! !AbstractTextChangedPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 6/13/2012 21:18'! registerTo: aModel aModel announcer on: NautilusTextDisplayerChanged send: #displayerChanged: to: self! ! !AbstractTextChangedPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/13/2012 21:18'! displayerChanged: anAnnouncement self logCr: anAnnouncement displayerSymbol! ! Model subclass: #AbstractTool instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Base'! !AbstractTool commentStamp: '' prior: 0! I'm an abstract class grouping generic methods for managing packages/classes/groups/methods from a browser! !AbstractTool methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/23/2012 13:48'! guessTypeForName: aString ^nil! ! !AbstractTool methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/12/2012 13:20'! isCodeCompletionAllowed ^true! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 2/18/2012 21:05'! fileOutCategories: aCollection from: aClass aCollection do: [:name | aClass fileOutCategory: name ]! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 8/21/2011 17:50'! removeCategory: aCategory inClass: aClass aCategory ifNil: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. (aClass organization listAtCategoryNamed: aCategory) isEmpty ifTrue: [ aClass removeCategory: aCategory. ^ true ]. (self confirm: 'Are you sure you want to remove the protocol ', aCategory,' and all its methods?') ifTrue: [ aClass removeCategory: aCategory. ^ true ]. ^ false! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 4/13/2011 13:10'! removeEmptyCategoriesFrom: aClass aClass organization removeEmptyCategories.! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 2/20/2012 17:15'! renameCategory: aCategory from: aClass "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | aClass ifNil: [^ nil]. aCategory ifNil: [^ nil]. oldName := aCategory. newName := UIManager default request: 'Please type new category name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [^ nil ] ifFalse: [newName := newName asSymbol]. newName = oldName ifTrue: [^ nil ]. aClass organization renameCategory: oldName toBe: newName. ^ newName! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:12'! addCategoryIn: aClass self addCategoryIn: aClass before: nil! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 5/5/2011 14:48'! addCategoryIn: aClass before: aCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | labels reject lines oldIndex newName | labels := OrderedCollection new. reject := Set new. reject addAll: aClass organization categories; add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines := OrderedCollection new. aClass allSuperclasses do: [:cls | | cats | cls = Object ifFalse: [ cats := cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [ lines add: labels size. labels addAll: cats asSortedCollection. reject addAll: cats ]]]. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: 'Add Category'. newName ifNil: [ ^ nil ]. newName := newName asSymbol. aClass organization addCategory: newName before: aCategory. self selectedCategory: newName. ^ newName! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 9/7/2011 21:22'! addClassIn: aPackage " add a new class in the provided package. A dialog will be opened to let the user set the class definition " | classSymbol systemCategory classDefinition | classSymbol := #NameOfSubclass. systemCategory := aPackage ifNil: [ 'Unknown' ]. classDefinition := 'Object subclass: #' , classSymbol , ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , systemCategory name , ''''. classDefinition := UIManager default multiLineRequest: 'Define class definition:' initialAnswer: classDefinition answerHeight: 250. (classDefinition isNil or: [ classDefinition isEmpty ]) ifTrue: [ ^ self ]. self class evaluatorClass evaluate: classDefinition.! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 9/7/2011 21:22'! addTraitIn: aPackage " add a new class in the provided package. A dialog will be opened to let the user set the class definition " | classSymbol systemCategory classDefinition | classSymbol := #NameOfSubclass. systemCategory := aPackage ifNil: [ 'Unknown' ]. classDefinition := 'Trait named: #TSortable uses: {} category: ''' , systemCategory name , ''''. classDefinition := UIManager default multiLineRequest: 'Define class definition:' initialAnswer: classDefinition answerHeight: 250. (classDefinition isNil or: [ classDefinition isEmpty ]) ifTrue: [ ^ self ]. self class evaluatorClass evaluate: classDefinition.! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 2/21/2012 18:20'! browseClassRefsOf: aClass | class | aClass ifNil: [ ^false ]. class := aClass theNonMetaClass ifNil: [^self]. class isTrait ifTrue: [self systemNavigation browseAllUsersOfTrait: class] ifFalse: [self systemNavigation browseAllCallsOnClass: class] ! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:26'! browseClassVarRefsOf: aClass | cls | cls := aClass theNonMetaClass. (cls notNil and: [cls isTrait not]) ifTrue: [self systemNavigation browseClassVarRefs: cls]! ! !AbstractTool methodsFor: 'class' stamp: 'VeronicaUquillas 9/3/2011 20:46'! browseCommentVersionsOf: aRGCommentDefinition ClassCommentVersionsBrowser browseCommentOf: aRGCommentDefinition realClass! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:28'! browseInstVarDefsOf: aClass (aClass notNil and: [aClass isTrait not]) ifTrue: [self systemNavigation browseInstVarDefs: aClass]! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:29'! browseInstVarRefsOf: aClass (aClass notNil and: [aClass isTrait not]) ifTrue: [self systemNavigation browseInstVarRefs: aClass]! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 9/28/2011 18:37'! browseUnusedMethodsOf: aClass | classes unsent messageList | aClass ifNil: [^ self]. classes := Array with: aClass with: aClass class. unsent := Set new. classes do: [:c | unsent addAll: c selectors ]. unsent := self systemNavigation allUnsentMessagesIn: unsent. messageList := OrderedCollection new. classes do: [:c | (c selectors select: [:s | unsent includes: s]) asSortedCollection do: [:sel | messageList add: ((c methodDict at: sel) methodReference) ]]. self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , aClass name! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 10/7/2011 14:00'! compileANewClassFrom: aString notifying: aController startingFrom: aClass " Copied from Browser " "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass := aClass. defTokens := aString findTokens: Character separators. ((defTokens first = 'Trait' and: [defTokens second = 'named:']) or: [defTokens second = 'classTrait']) ifTrue: [^ self defineTrait: aString notifying: aController ]. keywdIx := defTokens findFirst: [:x | x beginsWith: 'category']. envt := Smalltalk globals. keywdIx := defTokens findFirst: [:x | '*subclass*' match: x]. newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKey: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ nil]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass := oldClass superclass]. class := oldClass subclassDefinerClass evaluate: aString notifying: aController logged: true. ^ (class isKindOf: Behavior) ifTrue: [ class ] ifFalse: [ nil ]! ! !AbstractTool methodsFor: 'class' stamp: 'CamilloBruni 9/12/2011 15:06'! copyClasses: aCollection | needsRefresh lastDuplicate | aCollection ifEmpty: [ ^ false -> nil ]. needsRefresh := false. aCollection do: [:class || copysName | copysName := UIManager default request: 'Please type new class name' initialAnswer: class name. copysName isEmptyOrNil ifFalse: [ needsRefresh ifFalse: [ needsRefresh := true ]. lastDuplicate := class duplicateClassWithNewName: copysName ]]. ^(needsRefresh -> lastDuplicate)! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 1/24/2013 13:54'! createInitializerWithInstVarsOf: aClass "Create a default initializer on the class side for a chosen list of instance variables" | newMessage instVars| aClass ifNil: [ ^ self ]. instVars := (TickDialogWindow itemsList: aClass instVarNames sort itemsHeaderName: 'Inst Var Names' wrapBlockOrSelector: [:e | e ] title: 'Create entry point' defaultValue: true) chooseFromOwner: self window. instVars ifNil: [ ^ self ]. instVars do: [ :aVariable| (aClass canUnderstand: (aVariable, ':') asSymbol) ifFalse: [ newMessage :=self buildSetterFor: aVariable. aClass compile: newMessage classified: 'accessing' notifying: nil ]]. (aClass theMetaClass canUnderstand: (($: join: instVars), ':') asSymbol) ifFalse: [ newMessage := self buildInitializerFor: instVars. aClass theMetaClass compile: newMessage classified: 'instance creation' notifying: nil ]! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 1/24/2013 13:58'! createInstVarAccessorsOf: aClass "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" | instVars | aClass ifNil: [ ^ self ]. instVars := (TickDialogWindow itemsList: aClass instVarNames copy sort itemsHeaderName: 'Inst Var Names' wrapBlockOrSelector: [:e | e ] title: 'Getter/Setter Creator' defaultValue: true) chooseFromOwner: self window. instVars ifNil: [ ^ self ]. instVars do: [:aName || setter newMessage | (aClass canUnderstand: aName asSymbol) ifFalse: [ newMessage := self buildGetterFor: aName. aClass compile: newMessage classified: 'accessing' notifying: nil]. (aClass canUnderstand: (aName, ':') asSymbol) ifFalse:[ newMessage :=self buildSetterFor: aName. aClass compile: newMessage classified: 'accessing' notifying: nil]]! ! !AbstractTool methodsFor: 'class' stamp: 'jeanbaptistearnaud 2/8/2013 13:38'! defineTrait: defString notifying: aController | defTokens keywdIx envt oldTrait newTraitName trait | self selectedClassOrMetaClass isTrait ifTrue:[oldTrait := self selectedClassOrMetaClass]. defTokens := defString findTokens: Character separators. keywdIx := defTokens findFirst: [:x | x = 'category']. envt := self class environment. keywdIx := defTokens findFirst: [:x | x = 'named:']. newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName]) and: [envt includesKey: newTraitName asSymbol]) ifTrue: ["Attempting to define new class/trait over existing one when not looking at the original one in this browser..." (self confirm: ((newTraitName , ' is an existing class/trait in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size)) ifFalse: [^ nil ]]. trait := self class evaluatorClass evaluate: defString notifying: aController logged: true. ^ trait! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 5/3/2011 11:27'! fileOutClasses: aCollection "Print a description of the selected class onto a file whose name is the category name followed by .st." Cursor write showWhile: [ aCollection ifNotEmpty: [ aCollection do: [:class | class theNonMetaClass fileOut ]]]! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 3/16/2012 01:36'! moveInNewPackage: aCollection | labels reject lines oldIndex newName item aPackage | aCollection ifEmpty: [^ nil ]. aPackage := aCollection first package. labels := self model packages collect: [:each | each name]. lines := {0}. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: ('Change Package (current: ', aPackage name,')'). newName ifNil: [ ^ nil ]. newName := newName asSymbol. item := self browsedEnvironment packageOrganizer packageNamed: newName. aCollection do: [:aClass | aPackage removeClass: aClass. item addClassDefinition: aClass. aClass category: item name ]. ^ item! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 16:15'! removeClass: aClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message className classToRemove result | classToRemove := aClass ifNil: [Beeper beep. ^ false]. classToRemove := classToRemove theNonMetaClass. className := classToRemove name. message := 'Are you certain that you want to REMOVE the class ', className, ' from the system?'. (result := self confirm: message) ifTrue: [classToRemove subclasses size > 0 ifTrue: [(self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem ]. ^ result! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 2/26/2012 23:55'! removeClasses: aCollection "Remove the selected classes from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message classesName classesToRemove result | aCollection isEmptyOrNil ifTrue: [ Beeper beep. ^ false ]. classesToRemove := aCollection collect: #theNonMetaClass. classesName := (classesToRemove collect: #name) joinUsing: ', '. message := 'Are you certain that you want to REMOVE the classes ', classesName, ' from the system ?'. (result := self confirm: message) ifTrue: [ classesToRemove do: [:classToRemove | message := classToRemove name, ' has subclasses. Do you really want to REMOVE it from the system ?'. classToRemove subclasses size > 0 ifTrue: [ (self confirm: message) ifTrue: [ classToRemove removeFromSystem ]] ifFalse: [ classToRemove removeFromSystem ]]]. ^ result! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 16:06'! renameClass: aClass | oldName newName obs | aClass ifNil: [ ^ self ]. oldName := aClass name. newName := UIManager default request: 'Please type new class name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [ ^ self ]. "Cancel returns" newName := newName asSymbol. newName = oldName ifTrue: [ ^ self ]. (self class environment includesKey: newName) ifTrue: [ ^ self error: newName , ' already exists' ]. aClass rename: newName. obs := self systemNavigation allReferencesTo: (aClass environment associationAt: newName). obs isEmpty ifFalse: [ self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ]. ^ newName! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 5/28/2011 13:20'! showUnreferencedClassVarsOf: aClass "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" | aList aReport | ( aClass isNil or: [aClass isTrait]) ifTrue: [^ self]. aList := self systemNavigation allUnreferencedClassVariablesOf: aClass. aList size = 0 ifTrue: [^ UIManager default inform: 'There are no unreferenced class variables in ' , aClass name]. aReport := String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced class variable(s) in ' translated, aClass name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. UIManager default inform: aReport! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 5/28/2011 13:20'! showUnreferencedInstVarsOf: aClass "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" | aList aReport | (aClass isNil or: [aClass isTrait]) ifTrue: [^ self]. aList := aClass allUnreferencedInstanceVariables. aList size = 0 ifTrue: [^ UIManager default inform: 'There are no unreferenced instance variables in ', aClass name]. aReport := String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced instance variable(s) in ' translated, aClass name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. UIManager default inform: aReport! ! !AbstractTool methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 15:17'! alertGroupExisting: name UIManager default alert: 'The group named ', name, ' already exists' title: 'Already exists'! ! !AbstractTool methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/13/2011 12:59'! mergeGroups: aCollection aCollection ifNotEmpty: [:groups || group | group := groups reduce: [:a :b | a or: b]. groups do: [:gp | gp removable ifTrue: [self groupsManager removeAGroupSilently: gp]]. ^ group]. ^ nil! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/7/2012 09:20'! browseMessagesFrom: aSelector " badly named, it browses implementors " self getSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/7/2012 09:20'! browseSendersOfMessagesFrom: aSelector "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." self getSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'method' stamp: 'StephaneDucass 5/18/2012 19:20'! browseVersionsFrom: aMethod "Create and schedule a Versions Browser, showing all versions of the currently selected message. Answer the browser or nil." | selector class | (selector := aMethod selector) ifNil: [ self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ] ifNotNil: [ class := aMethod methodClass. (Smalltalk tools versionBrowser browseVersionsOf: (RGMethodDefinition new selector: selector; className: aMethod methodClass name; asHistorical) class: class theNonMetaClass meta: class isMeta category: aMethod category selector: selector)]! ! !AbstractTool methodsFor: 'method' stamp: 'StephaneDucasse 5/28/2011 13:19'! categorizeMethods: aCollection of: aClass from: aCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | labels reject lines oldIndex newName | aCollection ifEmpty: [^ self]. aClass ifNil: [^self]. labels := OrderedCollection new. labels addAll: aClass organization categories copy sort; add: ClassOrganizer default. lines := OrderedCollection new. lines add: labels size -1. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: ('Change Protocol (current: ', aCategory, ')'). newName ifNil: [ ^self ]. newName := newName asSymbol. aCollection do: [:item | item methodClass organization classify: item selector under: newName suppressIfDefault: true ].! ! !AbstractTool methodsFor: 'method' stamp: 'CamilloBruni 9/22/2012 21:44'! compileANewMethodInClass: aClass categorized: aCategory from: aString notifyng: aController | selector existingMethod targetClass | targetClass := aClass. "try to guess the selector form the first line XXX hack" selector := aString lines first findSelector. "Warn the user if a Trait method would be overridden" (aClass includesSelector: selector) ifTrue: [ existingMethod := aClass methodNamed: selector. existingMethod isFromTrait ifTrue: [ targetClass := UIManager default chooseFrom: {'Create copy in ', aClass name. 'Compile Trait method in ', existingMethod origin name} values: { aClass. existingMethod origin} title: 'Where do you want to compile this trait method?'. targetClass ifNil: [ ^ nil ]]]. "Run the normal compilation either on aClass or the Trait" ^ targetClass compile: aString classified: aCategory notifying: aController.! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 3/25/2012 20:54'! defaultGetSelectorAndSendQuery: array to: queryPerformer with: querySelector | selector | selector := UIManager default request: 'Type selector:' initialAnswer: 'flag:'. selector ifNil: [ selector := String new ]. selector := selector copyWithout: Character space. ^ selector isEmptyOrNil ifFalse: [ (Symbol hasInterned: selector ifTrue: [ :aSymbol | array at: 1 put: aSymbol. queryPerformer perform: querySelector withArguments: array ]) ifFalse: [ self inform: 'no such selector' ] ]! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 4/13/2011 12:52'! fileOutMethods: aCollection Cursor write showWhile:[ aCollection ifNotEmpty: [:methods | methods do: [:method | method methodClass fileOutMethod: method selector ]]]! ! !AbstractTool methodsFor: 'method' stamp: 'StephaneDucasse 5/28/2011 13:19'! findMethodIn: aClass | recentList pattern foundMethod | aClass ifNil: [^ nil ]. recentList := aClass selectors. recentList size = 0 ifTrue: [pattern := UIManager default request: 'Message name or fragment?'] ifFalse: [pattern := UIManager default enterOrRequestFrom: recentList lines: #() title: 'Message name or fragment?']. pattern isEmptyOrNil ifTrue: [^ nil ]. foundMethod := self systemNavigation selectorFromPattern: pattern withCaption: '' startingFrom: self selectedClass. foundMethod ifNil: [^ nil ]. ^ foundMethod! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/8/2013 16:11'! getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs selector: aSelector "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" | strm array | array := Array new: queryArgs size + 1. strm := array writeStream. strm nextPut: nil. strm nextPutAll: queryArgs. aSelector ifNil: [ ^ self defaultGetSelectorAndSendQuery: querySelector to: queryPerformer with: array ]. array at: 1 put: aSelector. queryPerformer perform: querySelector withArguments: array.! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 6/28/2012 15:11'! methodHierarchyFrom: aMethod "Create and schedule a method browser on the hierarchy of implementors." aMethod ifNil: [ ^ self ]. self systemNavigation methodHierarchyBrowserForClass: aMethod methodClass selector: aMethod selector! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 4/13/2011 13:06'! moveMethod: aMethod inPackage: aPackage aMethod methodClass organization classify: aMethod selector under: '*', aPackage name suppressIfDefault: true.! ! !AbstractTool methodsFor: 'method' stamp: 'StephaneDucasse 5/28/2011 13:19'! moveMethodsToPackage: aCollection in: packagesList from: aPackage "Search for a package from a pattern or from the recent list" | pattern foundPackage | aCollection ifEmpty: [^ self ]. packagesList size = 0 ifTrue: [pattern := UIManager default request: 'Package name or fragment?'] ifFalse: [pattern := UIManager default enterOrRequestFrom: packagesList lines: #() title: 'Package name or fragment?']. pattern isEmptyOrNil ifTrue: [^ self flashPackage ]. foundPackage := self systemNavigation packageFromPattern: pattern withCaption: ''. foundPackage ifNil: [^ self flashPackage]. aPackage = foundPackage ifTrue: [ ^ self ]. aCollection do: [:each | self moveMethod: each inPackage: foundPackage ]. ! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/24/2012 02:50'! removeMethod: aMethod inClass: aClass "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. " | messageName confirmation | aMethod ifNil: [^ false]. messageName := aMethod selector. confirmation := self systemNavigation confirmRemovalOf: messageName on: aClass. confirmation = 3 ifTrue: [^ false]. (aClass includesLocalSelector: messageName) ifTrue: [ aClass removeSelector: messageName ] ifFalse: [ self removeNonLocalSelector: messageName ]. "In case organization not cached" confirmation = 2 ifTrue: [self systemNavigation browseAllCallsOn: messageName]. ^ true! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/24/2012 21:21'! removeMethods: aCollection inClass: aClass "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. " | messagesName confirmation | aCollection isEmptyOrNil ifTrue: [^ false]. aCollection size = 1 ifTrue: [ ^ self removeMethod: aCollection first inClass: aClass ]. messagesName := aCollection collect: #selector. confirmation := self systemNavigation confirmRemovalOfSelectors: messagesName on: aClass. confirmation = 3 ifTrue: [ ^ false ]. aCollection do: [:message|| messageName | messageName := message selector. (aClass includesLocalSelector: messageName) ifTrue: [ aClass removeSelector: messageName ] ifFalse: [ self removeNonLocalSelector: messageName ]]. "In case organization not cached" confirmation = 2 ifTrue: [ aCollection do: [:message || messageName | messageName := message selector. ((self systemNavigation allCallsOn: messageName) size > 0) ifTrue: [ self systemNavigation browseAllCallsOn: messageName ]]]. ^ true! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 4/13/2011 13:13'! removeNonLocalSelector: aSymbol from: aClass | traits isAlias | traits := aClass traitsProvidingSelector: aSymbol. isAlias := aClass isLocalAliasSelector: aSymbol. isAlias ifTrue: [ [traits size = 1] assert. aClass removeAlias: aSymbol of: traits first] ifFalse: [ traits do: [:each | aClass addExclusionOf: aSymbol to: each ]]! ! !AbstractTool methodsFor: 'method'! selectMessageAndEvaluate: aBlock defaultValue: aSelector "Subclass may override me to allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any" aBlock value: aSelector! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 3/25/2012 20:58'! selectThenBrowseMessagesFrom: aSelector " badly named, it browses implementors " self selectThenGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 3/25/2012 20:58'! selectThenBrowseSendersOfMessagesFrom: aSelector "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." self selectThenGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'method'! selectThenGetSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs selector: aSelector "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" | strm array | strm := (array := Array new: queryArgs size + 1) writeStream. strm nextPut: nil. strm nextPutAll: queryArgs. aSelector ifNil: [ ^ self defaultGetSelectorAndSendQuery: querySelector to: queryPerformer with: array ]. self selectMessageAndEvaluate: [ :selector | array at: 1 put: selector. queryPerformer perform: querySelector withArguments: array ] defaultValue: aSelector! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/19/2012 19:25'! toggleBreakOnEntryIn: aMethod "Install or uninstall a halt-on-entry breakpoint" aMethod ifNil: [^self]. aMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: aMethod] ifFalse: [BreakpointManager installInClass: aMethod methodClass selector: aMethod selector ].! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 2/5/2013 14:06'! addPackageBasedOn: aPackage | name initialAnswer package | initialAnswer := aPackage ifNil: [''] ifNotNil: [:p | p name]. name := UIManager default request: 'Name of the new package:' initialAnswer: initialAnswer title: 'Create a new package'. (self isValidPackageName: name) ifTrue: [ package := self browsedEnvironment packageOrganizer createPackageNamed: name ] ifFalse: [ self alertInvalidPackageName:name ]. ^ package! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 2/27/2012 23:44'! addPackagesAsGroup: aCollection aCollection ifNotEmpty: [| packages list blocks name | packages := aCollection sort: [:a :b | a name <= b name ]. blocks := OrderedCollection new. packages do: [:package | blocks add: [ package orderedClasses]]. name := ( packages collect: [:package | package name]) joinUsing: ' + '. ^ (self groupsManager addADynamicClassGroupNamed: name blocks: blocks)]! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 4/13/2011 12:21'! addPackagesAsGroup: aCollection named: aString aCollection ifNotEmpty: [:packages || blocks | blocks := OrderedCollection new. packages do: [:package | blocks add: [ package orderedClasses]]. ^ (self groupsManager addADynamicGroupSilentlyNamed: aString blocks: blocks)]! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 1/24/2013 18:22'! addPackagesAsGroups: aCollection | name | name := WriteStream on: ''. aCollection ifNotEmpty: [| packages firstGroup | packages := aCollection sort: [:a :b | a name <= b name ]. packages do: [:package || group | [ group := self addPackagesAsGroup: {package}. ] on: GroupAlreadyExists do: [:ex | name nextPutAll: ex groupName; nextPut: Character cr. group := nil ]. firstGroup ifNil: [ group ifNotNil: [ firstGroup := group ]]]. name := name contents. name isEmpty ifFalse: [ (GroupsAlreadyExists groupName: name) signal ]. ^ firstGroup ]. ^ nil ! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 2/5/2013 14:09'! alertInvalidPackageName:name | errorMessage | (name isNil or: [ name isEmpty ]) ifTrue: [ ^ self ]. "User cancelled the action" errorMessage := String streamContents: [:stream | stream << name << ' is not a valid package name. A package name can not begin with a *' ]. UIManager default inform: errorMessage! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 4/13/2011 12:52'! fileOutPackages: aCollection Cursor write showWhile:[ aCollection ifNotEmpty: [ aCollection do: [:package | package fileOut ]]]! ! !AbstractTool methodsFor: 'package' stamp: 'StephaneDucasse 5/28/2011 13:19'! findPackageIn: aPackageNamesList | pattern foundPackage | aPackageNamesList size = 0 ifTrue: [pattern := UIManager default request: 'Package name or fragment?'] ifFalse: [pattern := UIManager default enterOrRequestFrom: aPackageNamesList lines: #() title: 'Package name or fragment?']. pattern isEmptyOrNil ifTrue: [^ self flashPackage ]. foundPackage := self systemNavigation packageFromPattern: pattern withCaption: ''. foundPackage ifNil: [^ self flashPackage]. ^ foundPackage! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 2/5/2013 14:04'! isValidPackageName: name ^ (name isNil or: [ name isEmpty or: [ name first = $* ]]) not! ! !AbstractTool methodsFor: 'package' stamp: 'SeanDeNigris 2/5/2013 10:54'! renamePackages: aCollection | name | aCollection ifNotEmpty: [ :packages | packages do: [ :selectedPackage | self renamePackage: selectedPackage ] ].! ! !AbstractTool methodsFor: 'private' stamp: 'SeanDeNigris 2/5/2013 10:56'! renamePackage: anRPackage | newName | newName := UIManager default request: 'New name of the package' initialAnswer: anRPackage name title: 'Rename a package'. newName = anRPackage name ifTrue: [ ^ self ]. (self isValidPackageName: newName) ifTrue: [ self browsedEnvironment packageOrganizer renamePackage: anRPackage in: newName ] ifFalse: [ self alertInvalidPackageName:newName ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractTool class instanceVariableNames: ''! !AbstractTool class methodsFor: 'world menu' stamp: 'EstebanLorenzano 4/26/2012 14:03'! menuCommandOn: aBuilder (aBuilder item: #Tools) order: 1.0; target: self; icon: (self theme iconNamed: #toolsIcon). ! ! !AbstractTool class methodsFor: 'world menu' stamp: 'MarcusDenker 8/15/2011 16:34'! theme ^ UITheme current! ! Model subclass: #AbstractWidget instanceVariableNames: 'model iconClass' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractWidget commentStamp: '' prior: 0! AbstractWidget is an abstraction for the different widget which could be used to compose the Nautilus UI! !AbstractWidget methodsFor: 'accessing'! iconClass ^ self model iconClass! ! !AbstractWidget methodsFor: 'accessing'! iconClass: anObject iconClass := anObject! ! !AbstractWidget methodsFor: 'accessing'! model ^ model! ! !AbstractWidget methodsFor: 'accessing'! model: anObject model := anObject. anObject addDependent: self.! ! !AbstractWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:34'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [ dragSource getListElementSelector ]! ! !AbstractWidget methodsFor: 'update'! update: aSymbol self changed: aSymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractWidget class instanceVariableNames: ''! !AbstractWidget class methodsFor: 'instance creation'! model: model ^ self new model: model; yourself! ! AbstractDescription subclass: #AddClassDescription instanceVariableNames: 'category name' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:12'! category ^ category! ! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:12'! category: anObject category := anObject! ! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:13'! newClassName ^ name! ! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:13'! newClassName: anObject name := anObject! ! !AddClassDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:45'! generateSpec ^ { #subclass:category:. self newClassName asSymbol. self category} ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddClassDescription class instanceVariableNames: ''! !AddClassDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/27/2012 07:38'! category: ctgr name: newClassName ^ self new category: ctgr; newClassName: newClassName; yourself! ! AbstractDescription subclass: #AddInstVarDescription instanceVariableNames: 'name type' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! name ^ name! ! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:40'! name: anObject name := anObject! ! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 13:55'! type ^ type! ! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 13:55'! type: anObject type := anObject! ! !AddInstVarDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/27/2012 06:48'! initialize "Initialization code for AddInstVarDescription" super initialize. name := ''.! ! !AddInstVarDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 3/5/2012 05:51'! generateSpec ^ { #addInstVarNamed:type:. self name. self type }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddInstVarDescription class instanceVariableNames: ''! !AddInstVarDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/28/2012 13:56'! name: newName ^ self name: newName type: Object! ! !AddInstVarDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/28/2012 13:56'! name: newName type: type ^ self new name: newName; type: type; yourself! ! AbstractDescription subclass: #AddIntoMethodDescription instanceVariableNames: 'code order selector' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! code ^ code! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! code: anObject code := anObject! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! order ^ order! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! order: anObject order := anObject! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! selector ^ selector! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! selector: anObject selector := anObject! ! !AddIntoMethodDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 08:00'! generateSpec ^ { #addSourceCode:into:. self code. self selector }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddIntoMethodDescription class instanceVariableNames: ''! !AddIntoMethodDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! code: code order: order selector: selector ^ self new code: code; order: order; selector: selector; yourself! ! AbstractDescription subclass: #AddMethodDescription instanceVariableNames: 'category selector source' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:47'! category ^ category! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:47'! category: anObject category := anObject! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! selector ^ selector! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! selector: anObject selector := anObject! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! source ^ source! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! source: anObject source := anObject! ! !AddMethodDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/27/2012 07:07'! initialize "Initialization code for AddMethodDescription" super initialize. category := ''. selector := ''. source := ''.! ! !AddMethodDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:50'! generateSpec ^ { #compileWithoutReturn:classified:. self source. self category.}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddMethodDescription class instanceVariableNames: ''! !AddMethodDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/27/2012 07:00'! category: category source: source ^ self new category: category; source: source; yourself! ! Object variableSubclass: #AdditionalMethodState instanceVariableNames: 'method selector' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !AdditionalMethodState commentStamp: '' prior: 0! I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. Currently I hold the selector and any pragmas or properties the compiled method has. Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association. I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries. Hence I answer true to isMethodProperties.! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:19'! at: aKey "Answer the property value or pragma associated with aKey." ^self at: aKey ifAbsent: [self error: 'not found']! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:55'! at: aKey ifAbsent: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:54'! at: aKey ifAbsentPut: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^method propertyValueAt: aKey put: aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'CamilloBruni 4/27/2012 17:47'! at: aKey ifPresent: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer self." ^ aBlock value: (self at: aKey ifAbsent: [ ^ self ])! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'Alexandre Bergel 12/21/2009 23:53'! at: aKey put: aValue "Replace the property value or pragma associated with aKey." | keyAlreadyExists | keyAlreadyExists := false. 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [ keyAlreadyExists := true. propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value: aValue] ifFalse: [self basicAt: i put: aValue]]]. keyAlreadyExists ifFalse: [ method propertyValueAt: aKey put: aValue ]. ^ aValue ! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:36'! keysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value] ifFalse: [aBlock value: propertyOrPragma keyword value: propertyOrPragma]]! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'GabrielBarbuto 11/30/2010 11:30'! method ^method.! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 14:11'! pragmas "Answer the raw messages comprising my pragmas." | pragmaStream | pragmaStream := WriteStream on: (Array new: self basicSize). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [pragmaStream nextPut: propertyOrPragma]]. ^pragmaStream contents! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:25'! properties | propertyStream | propertyStream := WriteStream on: (Array new: self basicSize * 2). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]]. ^IdentityDictionary newFromPairs: propertyStream contents! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 19:32'! removeKey: aKey ifAbsent: aBlock "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key] ifFalse: [propertyOrPragma keyword]) == aKey ifTrue: [^method removeProperty: aKey]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector ^selector! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector: aSymbol selector := aSymbol! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:28'! setMethod: aMethod method := aMethod. 1 to: self basicSize do: [:i| | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [propertyOrPragma setMethod: aMethod]]! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 9/16/2011 11:26'! copyWith: aPropertyOrPragma "" "Answer a copy of the receiver which includes aPropertyOrPragma" | bs copy | (Association == aPropertyOrPragma class or: [Pragma == aPropertyOrPragma class]) ifFalse: [self error: self class name, ' instances should hold only Associations or Pragmas.']. "no need to initialize here; we're copying all inst vars" copy := self class basicNew: (bs := self basicSize) + 1. 1 to: bs do: [:i| copy basicAt: i put: (self basicAt: i) shallowCopy]. copy basicAt: bs + 1 put: aPropertyOrPragma. 1 to: self class instSize do: [:i| copy instVarAt: i put: (self instVarAt: i)]. ^copy! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 9/16/2011 11:27'! copyWithout: aPropertyOrPragma "" "Answer a copy of the receiver which no longer includes aPropertyOrPragma" | bs copy offset | "no need to initialize here; we're copying all inst vars" copy := self class basicNew: (bs := self basicSize) - ((self includes: aPropertyOrPragma) ifTrue: [1] ifFalse: [0]). offset := 0. 1 to: bs do: [:i| (self basicAt: i) = aPropertyOrPragma ifTrue: [offset := 1] ifFalse: [copy basicAt: i - offset put: (self basicAt: i) shallowCopy]]. 1 to: self class instSize do: [:i| copy instVarAt: i put: (self instVarAt: i)]. ^copy! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 9/14/2011 17:50'! postCopy "After copying we must duplicate any associations and pragmas so they don't end up being shared." 1 to: self basicSize do: [:i| self basicAt: i put: (self basicAt: i) shallowCopy]! ! !AdditionalMethodState methodsFor: 'decompiling' stamp: 'eem 6/11/2009 17:06'! method: aMethodNodeOrNil "For decompilation" method := aMethodNodeOrNil! ! !AdditionalMethodState methodsFor: 'printing' stamp: 'eem 9/14/2011 17:18'! printOn: aStream super printOn: aStream. aStream space; nextPut: $(; print: self identityHash; nextPut: $)! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:28'! includesProperty: aKey "Test if the property aKey is present." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:18'! propertyKeysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value]]! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:46'! propertyValueAt: aKey "Answer the property value associated with aKey." ^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:45'! propertyValueAt: aKey ifAbsent: aBlock "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^propertyOrPragma value]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'lr 2/6/2006 20:48'! removeKey: aKey "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'MarcusDenker 3/11/2010 20:08'! analogousCodeTo: aMethodProperties | bs | (bs := self basicSize) ~= aMethodProperties basicSize ifTrue: [^false]. 1 to: bs do: [:i| ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: [^false]]. ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'nice 11/8/2009 12:27'! hasAtLeastTheSamePropertiesAs: aMethodProperties "Answer if the recever has at least the same properties as the argument. N.B. The receiver may have additional properties and still answer true." aMethodProperties keysAndValuesDo: [:k :v| (v isKindOf: Pragma) "ifTrue: [Pragmas have already been checked]" ifFalse: [ (self includes: k->v) ifFalse: [^false]]]. ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'bgf 12/6/2008 12:15'! hasLiteralSuchThat: aBlock "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [(aBlock value: propertyOrPragma key) or: [(aBlock value: propertyOrPragma value) or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteralSuchThat: aBlock]]]] ifFalse: [propertyOrPragma hasLiteralSuchThat: aBlock]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 16:40'! hasLiteralThorough: literal "Answer true if any literal in these properties is literal, even if embedded in array structure." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key == literal or: [propertyOrPragma value == literal or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteral: literal]]]] ifFalse: [propertyOrPragma hasLiteral: literal]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includes: aPropertyOrPragma "" "Test if the property or pragma is present." 1 to: self basicSize do: [:i | (self basicAt: i) = aPropertyOrPragma ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includesKey: aKey "Test if the property aKey or pragma with selector aKey is present." 1 to: self basicSize do: [:i | (self basicAt: i) key == aKey ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 13:47'! isEmpty ^self basicSize = 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! isMethodProperties ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 16:49'! notEmpty ^self basicSize > 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'JohanBrichau 10/7/2009 20:07'! refersToLiteral: aLiteral ^ self pragmas anySatisfy: [ :pragma | pragma hasLiteral: aLiteral ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AdditionalMethodState class instanceVariableNames: ''! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 9/16/2011 11:25'! forMethod: aMethod selector: aSelector ^(self new: 0) selector: aSelector; setMethod: aMethod; yourself! ! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 9/16/2011 11:26'! selector: aSelector with: aPropertyOrPragma ^(self new: 1) selector: aSelector; basicAt: 1 put: aPropertyOrPragma; yourself! ! TestCase subclass: #AdditionalMethodStateTest instanceVariableNames: 'atState' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !AdditionalMethodStateTest methodsFor: 'running' stamp: 'GabrielBarbuto 11/30/2010 11:29'! setUp | pragma | pragma := (Object methodDict at: #at:) penultimateLiteral at: #primitive:. atState := AdditionalMethodState selector: #at: with: pragma copy. ! ! !AdditionalMethodStateTest methodsFor: 'tests' stamp: 'GabrielBarbuto 11/30/2010 11:29'! testCopy | copy | copy := atState copy. self deny: atState == copy. self assert: atState method == copy method. self assert: atState selector == copy selector. self assert: atState pragmas = copy pragmas. self assert: atState properties = copy properties. 1 to: atState pragmas size do: [:index | self deny: (atState pragmas at: index) == (copy pragmas at: index)].! ! Object subclass: #AdvancedHelpBrowserDummy instanceVariableNames: 'rootTopic isOpen' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! !AdvancedHelpBrowserDummy commentStamp: 'tbn 5/3/2010 19:30' prior: 0! This is a dummy for a custom Help browser that can be registered as a replacement for the HelpBrowser class. Instance Variables rootTopic: rootTopic - The root help topic ! !AdvancedHelpBrowserDummy methodsFor: 'initialize-release' stamp: 'tbn 5/3/2010 19:34'! initialize isOpen := false! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:32'! open isOpen := true! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:33'! rootTopic ^rootTopic! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:33'! rootTopic: aTopic rootTopic := aTopic! ! !AdvancedHelpBrowserDummy methodsFor: 'testing' stamp: 'tbn 5/3/2010 19:32'! isOpen ^isOpen! ! MessageDialogWindow subclass: #AlertDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AlertDialogWindow commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Message dialog with a warning icon.! !AlertDialogWindow methodsFor: 'visual properties' stamp: 'gvc 5/18/2007 10:27'! icon "Answer an icon for the receiver." ^self theme warningIcon! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlertDialogWindow class instanceVariableNames: ''! !AlertDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'gvc 5/22/2007 11:50'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallWarningIcon! ! AbstractNautilusPlugin subclass: #AlexPlugin instanceVariableNames: 'text container textMorph' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AlexPlugin commentStamp: '' prior: 0! An AlexPlugin is a plugin which show the setUp when a test method is selected! !AlexPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/21/2011 11:52'! display ^ container! ! !AlexPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 8/21/2011 11:49'! registerTo: aModel aModel announcer on: NautilusMethodSelected send: #methodSelected: to: self.! ! !AlexPlugin methodsFor: 'updating' stamp: 'MarcusDenker 4/29/2012 10:32'! methodSelected: anAnnouncement anAnnouncement method ifNotNil: [:method | ( method methodClass inheritsFrom: TestCase ) ifTrue: [ text := (method methodClass lookupSelector: #setUp) sourceCode ]] ifNil: [ text := ''] . self changed: #getText. self updateContainer! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 11:54'! buildTextMorph textMorph := PluggableTextMorph on: self text: #getText accept: nil! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 11:43'! getText ^ text! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 12:08'! initialize text := ''. container := PanelMorph new color: Color transparent; changeTableLayout; cellInset: 8; listDirection: #topToBottom; cellPositioning: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. self buildTextMorph! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 12:03'! updateContainer ^ text isEmpty ifTrue: [ container removeMorph: textMorph. container hide ] ifFalse: [ container addMorph: textMorph. container show ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlexPlugin class instanceVariableNames: ''! !AlexPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:42'! description ^ 'Display the setUp of test methods'! ! !AlexPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 8/25/2011 10:02'! defaultPosition ^ #middle! ! RectangleMorph subclass: #AlignmentMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0! Used for layout. Since all morphs now support layoutPolicy the main use of this class is no longer needed. Kept around for compability. Supports a few methods not found elsewhere that can be convenient, eg. newRow ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addAColumn: aCollectionOfMorphs | col | col := self inAColumn: aCollectionOfMorphs. self addMorphBack: col. ^col! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARow: aCollectionOfMorphs | row | row := self inARow: aCollectionOfMorphs. self addMorphBack: row. ^row! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; cellInset: cellInsetInteger! ! !AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'! isAlignmentMorph ^ true ! ! !AlignmentMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:58'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'stephane.ducasse 1/15/2009 15:58'! initialize super initialize. self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true "from AlignmentMorphBob1which was merged in this class, in an effort to remove alignementBob1 and still preserving the addInRow behavior" " self listDirection: #topToBottom. self layoutInset: 0. self hResizing: #rigid. self vResizing: #rigid"! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:34'! openInWindowLabeled: aString inWorld: aWorld self layoutInset: 0. ^super openInWindowLabeled: aString inWorld: aWorld.! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:53'! inAColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | col addMorphBack: each]. ^col! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:54'! inARightColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #bottomRight; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:55'! inARow: aCollectionOfMorphs | row | row := self class newRow color: Color transparent; vResizing: #shrinkWrap; layoutInset: 2; wrapCentering: #center; cellPositioning: #leftCenter. aCollectionOfMorphs do: [:each | row addMorphBack: each]. ^ row! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlignmentMorph class instanceVariableNames: ''! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! columnPrototype "Answer a prototypical column" | sampleMorphs aColumn | sampleMorphs := #(red yellow green) collect: [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself]. aColumn := self inAColumn: sampleMorphs. aColumn setNameTo: 'Column'. aColumn color: Color veryVeryLightGray. aColumn cellInset: 4; layoutInset: 6. aColumn enableDragNDrop. aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated. ^ aColumn! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'! inAColumn: aCollectionOfMorphs "Answer a columnar AlignmentMorph holding the given collection" | col | col := self newColumn color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'! inARow: aCollectionOfMorphs "Answer a row-oriented AlignmentMorph holding the given collection" | aRow | aRow := self newRow color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | aRow addMorphBack: each]. ^ aRow! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:51'! newColumn ^ self new listDirection: #topToBottom; hResizing: #spaceFill; extent: 1@1; vResizing: #spaceFill ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:50'! newRow ^ self new listDirection: #leftToRight; hResizing: #spaceFill; vResizing: #spaceFill; extent: 1@1; borderWidth: 0 ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! newSpacer: aColor "Answer a space-filling instance of me of the given color." ^ self new hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; extent: 1@1; color: aColor. ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! newVariableTransparentSpacer "Answer a space-filling instance of me of the given color." ^ self new hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; extent: 1@1; color: Color transparent ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! rowPrototype "Answer a prototypical row" | sampleMorphs aRow | sampleMorphs := (1 to: (2 + 3 atRandom)) collect: [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself]. aRow := self inARow: sampleMorphs. aRow setNameTo: 'Row'. aRow enableDragNDrop. aRow cellInset: 6. aRow layoutInset: 8. aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated. aRow color: Color veryVeryLightGray. ^ aRow "AlignmentMorph rowPrototype openInHand"! ! Protocol subclass: #AllProtocol instanceVariableNames: 'protocolOrganizer' classVariableNames: '' poolDictionaries: '' category: 'NewClassOrganizer'! !AllProtocol commentStamp: '' prior: 0! An AllProtocol is a special protocol to hanlde the "all" case! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! methods ^ self protocolOrganizer allMethods! ! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 14:50'! name ^ (self methods isEmpty and: [ protocolOrganizer protocols isEmpty]) ifTrue: [ self class nullCategory ] ifFalse: [ name ]! ! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! protocolOrganizer ^ protocolOrganizer! ! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! protocolOrganizer: anObject protocolOrganizer := anObject.! ! !AllProtocol methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/12/2012 16:05'! canBeRemoved ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AllProtocol class instanceVariableNames: ''! !AllProtocol class methodsFor: 'data' stamp: 'BenjaminVanRyseghem 4/12/2012 15:49'! defaultName ^ '~~~ all ~~~'! ! !AllProtocol class methodsFor: 'data' stamp: 'BenjaminVanRyseghem 4/12/2012 14:42'! nullCategory ^ 'no method'! ! !AllProtocol class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/12/2012 14:14'! protocolOrganizer: protocolOrganizer ^ self new protocolOrganizer: protocolOrganizer; yourself! ! TestCase subclass: #AllocationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Exception'! !AllocationTest commentStamp: 'StephaneDucasse 12/18/2009 12:03' prior: 0! Test originally from Andreas Raab! !AllocationTest methodsFor: 'testing' stamp: 'StephaneDucasse 4/23/2010 16:11'! testOneGigAllocation "Documentating a weird bug in the allocator" | sz array failed | failed := false. sz := 1024*1024*1024. array := [Array new: sz] on: OutOfMemory do: [:ex| failed := true]. self assert: (failed or:[array size = sz]). ! ! !AllocationTest methodsFor: 'testing' stamp: 'StephaneDucasse 4/23/2010 16:12'! testOneMegAllocation "Documentating a weird bug in the allocator" | sz array failed | failed := false. sz := 1024*1024. array := [Array new: sz] on: OutOfMemory do: [:ex| failed := true]. self assert: (failed or:[array size = sz]). ! ! !AllocationTest methodsFor: 'testing' stamp: 'MarcusDenker 8/20/2011 13:38'! testOutOfMemorySignal "Ensure that OOM is signaled eventually" | sz | sz := 512*1024*1024. "work around the 1GB alloc bug" self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory. "Call me when this test fails, I want your machine" sz := 1024*1024*1024*1024. self should:[Array new: sz] raise: OutOfMemory. ! ! ColorMappingCanvas subclass: #AlphaBlendingCanvas instanceVariableNames: 'alpha' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !AlphaBlendingCanvas commentStamp: 'LaurentLaffont 2/23/2011 20:17' prior: 0! see ColorMappingCanvas comment.! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha ^alpha! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha: newAlpha alpha := newAlpha.! ! !AlphaBlendingCanvas methodsFor: 'drawing-images' stamp: 'gvc 9/1/2008 16:31'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle. Do a blendAlpha if the rule is blend to cope with translucent images being drawn (via translucentImage:...)." rule = Form paint ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form paintAlpha alpha: alpha. ]. rule = Form over ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ]. rule = Form blend ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ].! ! !AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'! on: aCanvas myCanvas := aCanvas. alpha := 1.0.! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'! mapColor: aColor aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..." aColor isTransparent ifTrue:[^aColor]. aColor isOpaque ifTrue:[^aColor alpha: alpha]. ^aColor alpha: (aColor alpha * alpha)! ! ImageMorph subclass: #AlphaImageMorph instanceVariableNames: 'alpha cachedForm layout scale enabled autoSize getImageSelector model' classVariableNames: 'DefaultImage' poolDictionaries: '' category: 'Polymorph-Widgets'! !AlphaImageMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Displays an image with the specified alpha value (translucency) and optional scale and layout (scaled, top-right etc.).! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/26/2006 09:40'! alpha "Answer the value of alpha" ^ alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! alpha: anObject "Set the value of alpha" alpha := anObject. self cachedForm: nil; changed; changed: #alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 2/3/2010 17:46'! autoSize "Answer the value of autoSize" ^ autoSize! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 2/3/2010 17:46'! autoSize: anObject "Set the value of autoSize" autoSize := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/4/2011 12:59'! cachedForm "Answer the value of cachedForm" |form i effectiveAlpha| cachedForm ifNil: [ i := self scaledImage. effectiveAlpha := self enabled ifTrue: [self alpha] ifFalse: [self alpha / 2]. effectiveAlpha = 1.0 ifTrue: [self cachedForm: i] ifFalse: [form := Form extent: i extent depth: 32. form fillColor: (Color white alpha: 0.003922). (form getCanvas asAlphaBlendingCanvas: effectiveAlpha) drawImage: i at: 0@0. self cachedForm: form]]. ^cachedForm! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/27/2006 15:02'! cachedForm: anObject "Set the value of cachedForm" cachedForm := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:56'! enabled "Answer the value of enabled" ^enabled! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:57'! enabled: anObject "Set the value of enabled" enabled := anObject. self cachedForm: nil; changed! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:22'! getImageSelector ^ getImageSelector! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:22'! getImageSelector: anObject getImageSelector := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/28/2006 14:15'! image: anImage "Clear the cached form." ^self image: anImage size: anImage extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 3/5/2012 13:28'! image: aForm size: aPoint "Set the image to be the form scaled to the given size and padded if neccesary." |f| "Convert color forms etc. to 32 bit before resizing since scaling of ColorForm introduces degraded color resolution. Most noticable with grayscale forms." (aForm depth < 32 and: [aForm depth > 4]) ifTrue: [f := Form extent: aPoint depth: 32. f fillColor: (Color white alpha: 0.003922). f getCanvas translucentImage: aForm at: 0@0. f fixAlpha] ifFalse: [f := aForm]. f := f scaledToSize: aPoint. self autoSize ifTrue: [super image: f] ifFalse: [image := f. self changed]. self cachedForm: nil. self changed: #imageExtent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 6/30/2009 16:02'! imageExtent "Answer the extent of the original form." ^self image extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:00'! layout "Answer the value of layout" ^ layout! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/4/2011 13:04'! layout: aSymbol "Set the value of layout" |old| (old := layout) = aSymbol ifTrue: [^self]. layout := aSymbol. ((old = #scaled or: [old = #scaledAspect]) or: [aSymbol = #scaled or: [aSymbol = #scaledAspect]]) ifTrue: [self cachedForm: nil]. self changed! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/4/2011 13:04'! layoutSymbols "Answer the available layout options." ^#(#center #tiled #scaled #scaledAspect #topLeft #topCenter #topRight #rightCenter #bottomRight #bottomCenter #bottomLeft #leftCenter)! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:32'! model ^ model! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:33'! model: anObject "Set my model and make me me a dependent of the given object." model ifNotNil: [model removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. model := anObject ! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:43'! scale "Answer the value of scale" ^ scale! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! scale: aNumber "Set the value of scale" scale = aNumber ifTrue: [^self]. scale := aNumber. self cachedForm: nil; changed; changed: #scale! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 10/5/2011 16:05'! scaledImage "Answer the image scaled as required." |i| i := self image. i boundingBox area = 0 ifTrue: [^i]. (self layout == #scaled and: [self extent ~= i extent]) ifTrue: [ ^i magnify: i boundingBox by: (self extent / i extent) smoothing: 2]. (self layout == #scaledAspect and: [self extent ~= i extent]) ifTrue: [ ^self width / i width > (self height / i height) ifTrue: [i magnify: i boundingBox by: (self height / i height) smoothing: 2] ifFalse: [i magnify: i boundingBox by: (self width / i width) smoothing: 2]]. self scale ~= 1 ifTrue: [ ^i magnify: i boundingBox by: self scale smoothing: 2]. ^i! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:23'! update: aSymbol "Update the image if changed." super update: aSymbol. aSymbol = self getImageSelector ifTrue: [ self updateImage]! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:35'! updateImage "Get the image from the model." (self model notNil and: [self getImageSelector notNil]) ifTrue: [ (self model perform: self getImageSelector) ifNotNil: [:i | self image: i]]! ! !AlphaImageMorph methodsFor: 'drawing' stamp: 'gvc 8/8/2007 16:25'! drawOn: aCanvas "Draw with the current alpha Can't do simple way since BitBlt rules are dodgy!!." aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. (self cachedForm width = 0 or: [self cachedForm height = 0]) ifTrue: [^self]. self layout == #tiled ifTrue: [aCanvas fillRectangle: self innerBounds fillStyle: (AlphaInfiniteForm with: self cachedForm)] ifFalse: [aCanvas clipBy: self innerBounds during: [:c | c translucentImage: self cachedForm at: self layoutPosition]]! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'GaryChambers 10/5/2011 15:14'! displayBounds "Answer a rectangle in display coordinates that bounds the image (may be larger/smaller than visible area). Just one rep for the tiled case." ^self layoutPosition extent: self cachedForm extent ! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'GaryChambers 8/4/2011 13:06'! extent: aPoint "Allow as normal." self perform: #extent: withArguments: {aPoint} inSuperclass: Morph. (self layout = #scaled or: [self layout = #scaledAspect]) ifTrue: [self cachedForm: nil] ! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'GaryChambers 10/26/2011 11:57'! imageRectangleFromDisplayRectangle: aRectangle "Answer a rectangle in (original) image coordinates that corresponds to the given rectangle (in relative display coordinates)." |db| db := self displayBounds . db area = 0 ifTrue: [^db]. self layout == #scaledAspect ifTrue: [ ^((aRectangle translateBy: self layoutPosition negated) scaleBy: self image width / db width) rounded]. self layout == #scaled ifTrue: [ ^((aRectangle translateBy: self layoutPosition negated) scaleBy: (self image width / db width) @ (self image height / db height)) rounded]. ^self scale = 1 ifTrue: [aRectangle translateBy: self layoutPosition negated] ifFalse: [((aRectangle translateBy: self layoutPosition negated) scaleBy: 1 / self scale) rounded]! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'GaryChambers 8/4/2011 13:07'! layoutPosition "Answer the position that the cached form should be drawn based on the layout" self layout == #topCenter ifTrue: [^self innerBounds topCenter - (self cachedForm width // 2 @ 0)]. self layout == #topRight ifTrue: [^self innerBounds topRight - (self cachedForm width @ 0)]. self layout == #rightCenter ifTrue: [^self innerBounds rightCenter - (self cachedForm width @ (self cachedForm height // 2))]. self layout == #bottomRight ifTrue: [^self innerBounds bottomRight - self cachedForm extent]. self layout == #bottomCenter ifTrue: [^self innerBounds bottomCenter - (self cachedForm width // 2 @ self cachedForm height)]. self layout == #bottomLeft ifTrue: [^self innerBounds bottomLeft - (0 @ self cachedForm height)]. self layout == #leftCenter ifTrue: [^self innerBounds leftCenter - (0 @ (self cachedForm height // 2))]. (self layout == #center or: [self layout == #scaledAspect]) ifTrue: [^self innerBounds center - (self cachedForm extent // 2)]. ^self innerBounds topLeft! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 10/22/2007 11:51'! optimalExtent "Answer the optimal extent for the receiver." ^self image extent * self scale + (self borderWidth * 2)! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 12:40'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 12/3/2007 11:37'! defaultImage "Answer the default image for the receiver." ^DefaultImage ifNil: [DefaultImage := DefaultForm asFormOfDepth: 32]! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 2/3/2010 17:55'! initialize "Initialize the receiver. Use the 32 bit depth default image to avoid unnecessary conversions." enabled := true. autoSize := true. scale := 1.0. layout := #topLeft. alpha := 1.0. super initialize! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlphaImageMorph class instanceVariableNames: ''! !AlphaImageMorph class methodsFor: 'as yet unclassified' stamp: 'GaryChambers 9/8/2011 10:35'! defaultImage: aForm "Set the default image used for new instances of the receiver." DefaultImage := aForm! ! InfiniteForm subclass: #AlphaInfiniteForm instanceVariableNames: 'origin extent' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !AlphaInfiniteForm commentStamp: 'gvc 5/18/2007 13:49' prior: 0! Alpha aware InfiniteForm.! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 12/3/2008 17:09'! direction: aPoint "Ignore" ! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/7/2008 14:00'! extent "Answer the extent of the repeating area." ^extent ifNil: [SmallInteger maxVal @ SmallInteger maxVal]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:48'! extent: anObject "Set the value of extent" extent := anObject! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin "Answer the origin." ^origin ifNil: [0@0]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin: aPoint "Set the origin." origin := aPoint! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 10/7/2008 13:59'! computeBoundingBox "Refer to the comment in DisplayObject|computeBoundingBox." ^self origin extent: self extent! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 8/10/2009 11:42'! displayOnPort: aPort offsetBy: offset | targetBox patternBox savedMap top left | aPort destForm depth < 32 ifTrue: [^super displayOnPort: aPort offsetBy: offset]. "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox := aPort clipRect. patternBox := patternForm boundingBox. savedMap := aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form blend; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top := (targetBox top truncateTo: patternBox height) + offset y. left := (targetBox left truncateTo: patternBox width) + offset x. left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! ParserNotification subclass: #AmbiguousSelector instanceVariableNames: 'interval' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Exceptions'! !AmbiguousSelector commentStamp: 'nice 2/23/2010 15:40' prior: 0! An AmbiguousSelector is a notification produced by the Scanner/Parser/Compiler when encountering this ambiguous construct: 1@-2 Upper expression can be interpreted both 1 @ -2 (regular st-80 and former Squeak syntax, the minus is attached to the literal number) 1 @- 2 (extended binary selector, the minus sign is allowed at any position and thus part of the binary selector) ! !AmbiguousSelector methodsFor: 'handling' stamp: 'nice 3/5/2010 22:54'! openMenuIn: aBlock "Ask the user which selector to choose. Answer the choosen selector or nil if cancellation is requested." | labels actions lines caption choice | labels := { 'Yes I want selector ' , name , ' with positive argument'. 'Oops, I want ' , (name copyFrom: 1 to: name size - 1) , ' with negative argument'. 'cancel, I must think twice'}. actions := { name. name copyReplaceFrom: name size to: name size - 1 with: ' '. nil. }. lines := {2}. caption := 'Ambiguous selector: ' , name , ' please correct, or cancel:'. choice := aBlock value: labels value: lines value: caption. self resume: (actions at: choice ifAbsent: [nil])! ! !AmbiguousSelector methodsFor: 'private' stamp: 'nice 2/23/2010 16:51'! setName: aString range: anInterval name := aString. interval := anInterval! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AmbiguousSelector class instanceVariableNames: ''! !AmbiguousSelector class methodsFor: 'instance creation' stamp: 'nice 2/23/2010 16:52'! signalName: aString inRange: anInterval ^ (self new setName: aString range: anInterval) signal! ! Object subclass: #AndreasSystemProfiler instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime ticksPerMSec totalTicks' classVariableNames: '' poolDictionaries: '' category: 'AndreasProfiler'! !AndreasSystemProfiler commentStamp: '' prior: 0! AndreasSystemProfiler uses sub-msec VM supported PC sampling. In Memory of Andreas Raab. Author, Friend, Colleague. http://forum.world.st/In-Memory-of-Andreas-Raab-td4663424.html Released by Ron, Julie and David Example: AndreasSystemProfiler spyOn: [ 10000 timesRepeat: [ 3.14159 printString ] ] -=-=-=-=-=-=-= Apparently, the time taken to run the provided block is as twice as long as run without the profiler. -=-=-=-=-=-=-= Both AndreasSystemProfiler and MessageTally are periodic sampling profilers. The essential difference between AndreasSystemProfiler and MessageTally is in how the current method is sampled. MessageTally is driven from a high-priority process in a loop waiting on a delay. When the delay fires the lower-priority process being profiled is interrupted, its stack is walked to determine the methods along the call chain, and that data is recorded. But since the sampling occurs when the high-priority process preempts the lower-priority process, a sample is only taken at a preemption point. In particular, primitives are *not* profiled because they are not suspension points. A process can only be suspended on method activation (a non-primitive method activation, or primitive failure) or on backward branch. The cost of primitives is charged to a caller and is inferred by subtracting the cost of children of the caller from the caller itself (subtracting the number of samples in children of the caller form the number of samples in the caller itself). Another problem is that using the clock that underlies Delay, which is typically the clock used by processes being profiled, causes sampling errors due to the sampling and sampled processes cohering. Delays are limited in resolution (at best 1 millisecond) so if the profiled process waits on a delay it'll fire immediately after the profiling process (because the profiling process is at higher priority) and so the sampling process may only ever see the sampled process in a wait state. If MessageTally is used to profile multiple processes then a third problem is that if a primitive causes a process switch then its cost will end up being charged to the process switched-to, not switched from. This is again because sampling can only occur after a primitive has completed (successfully or not). AndreasSystemProfiler is driven from a high-priority process in a loop waiting on a Semaphore known to the VM. The profiling process uses a primitive to schedule a sample some number of ticks of the VM's high-performance clock in the future. When the time is reached the VM samples the current method and the current process, *before any process preemption takes place*, and independently of the standard clock, and signals the semaphore. The profiling process then collects the method,process pair via primitives. So AndreasSystemProfiler provides much more accurate results. That said there are still limitations with primitives and Cog. Currently Cog only samples "interpreter" primitives. Those primitives it implements in machine code (integer and float arithmetic, closure evaluation, at:, identityHash) are not sampled and won't show up; they will be charged to the calling method. This is fixable, since Cog actually compiles the sampling direct into interpreter primitive invocation when profiling is in effect and not at other times, but sampling could be a significant cost in these simple and performance-critical primitives.! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:31'! runProfilerProcess "Run the profiler process" | process tallyStart tallyTicks tallyStop method leaf | tallyRoot := QSystemTally new class: nil method: nil. totalTally := 0. Smalltalk profileSemaphore: semaphore. totalTicks := 0. tallyStart := tallyStop := Smalltalk highResClock. [ true ] whileTrue: [ tallyStart := tallyStop. tallyStart := Smalltalk highResClock. Smalltalk profileStart: ticks. "run for n ticks" semaphore wait. tallyStop := Smalltalk highResClock. tallyTicks := tallyStop - tallyStart. totalTicks := totalTicks + tallyTicks. process := Smalltalk profileSample. method := Smalltalk profilePrimitive. totalTally := totalTally + 1. process ifNotNil:[ leaf := tallyRoot tally: (process suspendedContext ifNil: [ thisContext ] ) by: tallyTicks. method ifNotNil: [ leaf tallyMethod: method by: tallyTicks ]. ]. ]. ! ! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:31'! spyOn: aBlock "Profile system activity during execution of aBlock. The argument is the desired samples per *milli* second. Mostly for polymorphism with MessageTally." self startProfiling. aBlock ensure: [ self stopProfiling ] ! ! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:31'! startProfiling "Start the profiler process taking samplesPerMsec samples per *milli* second" | t0 | semaphore := Semaphore new. "Run a 100 msec busy loop to figure out the ticks per msec" t0 := Time millisecondClockValue + 2. [Time millisecondClockValue >= t0] whileFalse. ticksPerMSec := Smalltalk highResClock. [Time millisecondClockValue >= (t0 + 100)] whileFalse. ticksPerMSec := (Smalltalk highResClock - ticksPerMSec) // (Time millisecondClockValue - t0). "Try to get 10 samples per msec" ticks := ticksPerMSec // 10. startTime := Time millisecondClockValue. vmStats := Smalltalk vm getParameters. profilerProcess := [ self runProfilerProcess ] forkAt: Processor timingPriority - 1. ! ! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:32'! stopProfiling "Stop the profiler process" Smalltalk profileSemaphore: nil. Smalltalk profileStart: 0. "<- profile stops now" totalTime := Time millisecondClockValue - startTime. Smalltalk vm getParameters keysAndValuesDo: [ :idx :value | value isInteger ifTrue: [ vmStats at: idx put: (value - ((vmStats at: idx) ifNil: [ 0 ])) ]. ]. profilerProcess ifNotNil: [ profilerProcess suspend. profilerProcess := nil. ]. ! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'RJT 1/23/2013 15:28'! doReport "Report the results of this profiler run" UIManager default edit: self report label: 'Spy Results'.! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'AlexandreBergel 1/29/2013 10:30'! report "Answer a report, with cutoff percentage of each element of the tree" ^String streamContents: [ :s | self report: s ]! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'RJT 1/23/2013 15:28'! report: strm "Print a report, with cutoff percentage of each element of the tree (leaves, roots, tree)=2, on the stream, strm." self report: strm cutoff: 1! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'AlexandreBergel 1/29/2013 11:46'! report: strm cutoff: threshold tallyRoot isNil ifTrue: [ strm nextPutAll: 'The profiler has not been run'. ^ self ]. tallyRoot tally = 0 ifTrue: [ strm nextPutAll: ' - no tallies obtained' ] ifFalse: [ strm nextPutAll: 'Reporting - ', totalTally asStringWithCommas,' tallies, ', totalTime asStringWithCommas, ' msec.'; cr; cr. tallyRoot fullPrintOn: strm tallyExact: false orThreshold: threshold time: totalTime. ]. totalTime isZero ifFalse: [ self reportGCStatsOn: strm. self reportProcessStatsOn: strm. ].! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'RJT 1/23/2013 15:28'! reportGCStatsOn: str | oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime rootOverflows | upTime := totalTime. oldSpaceEnd := vmStats at: 1. youngSpaceEnd := vmStats at: 2. memoryEnd := vmStats at: 3. fullGCs := vmStats at: 7. fullGCTime := vmStats at: 8. incrGCs := vmStats at: 9. incrGCTime := vmStats at: 10. tenureCount := vmStats at: 11. rootOverflows := vmStats at: 22. str cr. str nextPutAll: '**Memory**'; cr. str nextPutAll: ' old '; nextPutAll: oldSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' young '; nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' used '; nextPutAll: youngSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' free '; nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str cr. str nextPutAll: '**GCs**'; cr. str nextPutAll: ' full '; print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((fullGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. fullGCs = 0 ifFalse: [str nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' incr '; print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((incrGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. incrGCs = 0 ifFalse: [str nextPutAll:', avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' tenures '; nextPutAll: tenureCount asStringWithCommas. tenureCount = 0 ifFalse: [str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)']. str cr. str nextPutAll: ' root table '; nextPutAll: rootOverflows asStringWithCommas; nextPutAll:' overflows'. str cr. ! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'AlexandreBergel 1/29/2013 10:12'! reportProcessStatsOn: str | totalSwitches pageOverflows pageDivorces actualSwitches | vmStats size >= 61 ifFalse: [ ^ self ]. "don't try this on the closure VM" totalSwitches := vmStats at: 56. actualSwitches := totalSwitches - (2*totalTally). "exclude to/from profiler" pageOverflows := vmStats at: 60. pageDivorces := vmStats at: 61. str cr. str nextPutAll: '**Processes**'; cr. str tab; nextPutAll: 'Total process switches: ', totalSwitches printString; cr. str tab; nextPutAll: 'Without Profiler: ', actualSwitches printString; cr. str tab; nextPutAll: 'Stack page overflows: ', pageOverflows printString; cr. str tab; nextPutAll: 'Stack page divorces: ', pageDivorces printString; cr. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AndreasSystemProfiler class instanceVariableNames: ''! !AndreasSystemProfiler class methodsFor: 'LICENSE' stamp: 'RJT 1/23/2013 15:34'! LICENSE ^'Project Squeak In Memory of Andreas Raab. Author, Friend, Colleague. http://forum.world.st/In-Memory-of-Andreas-Raab-td4663424.html Copyright (c) 2005-2013, 3D Immersive Collaboration Consulting, LLC., All Rights Reserved Redistributions in source code form must reproduce the above copyright and this condition. Licensed under MIT License (MIT) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.'! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'RJT 1/23/2013 15:28'! default ^self new! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'AlexandreBergel 1/29/2013 10:21'! spyFor: seconds "Run the system profiler for the specified number of seconds" "self spyFor: 5" ^self spyOn: [ (Delay forSeconds: seconds) wait ].! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'AlexandreBergel 1/29/2013 10:23'! spyOn: aBlock "The main method for profiling and showing the report " "self spyOn: [ 10000 timesRepeat: [ 3.14159 printString ] ]" | profiler | profiler := self new. [ ^ profiler spyOn: aBlock ] ensure: [ profiler doReport ]. ! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'RJT 1/23/2013 15:28'! spyOnWorldFor: seconds "Run the system profiler for the specified number of seconds, spying on the morphic world in which it was launched. Handy for running Workspace do-its." ^self spyOn: [ | deadline | deadline := Time totalSeconds + seconds. [Time totalSeconds < deadline] whileTrue: [ World doOneCycle ]].! ! TestCase subclass: #AndreasSystemProfilerTest instanceVariableNames: 'tally' classVariableNames: '' poolDictionaries: '' category: 'AndreasProfiler'! !AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: 'AlexandreBergel 1/29/2013 10:14'! testSimple self shouldnt: [ AndreasSystemProfiler new spyOn: [ 200 timesRepeat: [ 1.23 printString ] ] ] raise: Error.! ! !AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: 'AlexandreBergel 1/29/2013 11:45'! testSimpleReport self shouldnt: [ AndreasSystemProfiler new report ] raise: Error.! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 10:45'! setUp tally := QSystemTally new. tally class: self class method: self class >> #testPrintingTally "tally class: Object method: Object >> #printString."! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:43'! testFullPrintOn | stream | stream := WriteStream on: String new. tally fullPrintOn: stream tallyExact: false orThreshold: 0 time: 10. self assert: stream contents = '**Tree** **Leaves** '! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:16'! testGetNewTab | tabs | self assert: (tally getNewTabsFor: #()) = #(). self assert: (tally getNewTabsFor: #(' ')) = #(' '). tabs := OrderedCollection new. tabs add: '['. (tally maxTabs + 1) timesRepeat: [ tabs add: ' ' ]. self assert: (tally getNewTabsFor: tabs) asArray = #('[' '[').! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 10:48'! testPrintingTally self assert: tally printString = 'AndreasSystemProfilerTest>>#testPrintingTally -- 0'! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 10:40'! testPrintingTallyUninitialized self assert: QSystemTally new printString = 'nil>>nil -- nil'! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:08'! testTallyTreePrint | stream | stream := WriteStream on: String new. tally treePrintOn: stream tabs: #() thisTab: nil total: 50 totalTime: 100 tallyExact: true orThreshold: 1. "Nothing is printed since there is no tab" self assert: stream contents isEmpty! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:10'! testTallyTreePrintWithTab | stream | stream := WriteStream on: String new. tally treePrintOn: stream tabs: #(' ') thisTab: nil total: 50 totalTime: 100 tallyExact: true orThreshold: 1. self assert: stream contents = ' 0 AndreasSystemProfilerTest testPrintingTally '! ! GIFReadWriter subclass: #AnimatedGIFReadWriter instanceVariableNames: 'forms delays comments' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !AnimatedGIFReadWriter commentStamp: 'LaurentLaffont 5/4/2011 21:27' prior: 0! Read an animated GIF file. Example: open all images of an animated GIF file in a Morphic window gifPath := '/path/to/my_animated.gif'. forms := (AnimatedGIFReadWriter formsFromFileNamed: gifPath) forms. content := UITheme builder newRow: (forms collect: [:aForm| UITheme builder newImage: aForm]). content openInWindowLabeled: 'Content of ', gifPath.! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! allImages | body colorTable | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: stream contentsOfEntireFile) ]. localColorTable := nil. forms := OrderedCollection new. delays := OrderedCollection new. comments := OrderedCollection new. self readHeader. [ (body := self readBody) isNil ] whileFalse: [ colorTable := localColorTable ifNil: [ colorPalette ]. transparentIndex ifNotNil: [ transparentIndex + 1 > colorTable size ifTrue: [ colorTable := colorTable forceTo: transparentIndex + 1 paddingWith: Color white ]. colorTable at: transparentIndex + 1 put: Color transparent ]. body colors: colorTable. forms add: body. delays add: delay ]. ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! delays ^ delays! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! forms ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'! comment: aString comments add: aString! ! !AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! readBitData | form | form := super readBitData. form offset: offset. ^form! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnimatedGIFReadWriter class instanceVariableNames: ''! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formsFromFileNamed: fileName | stream | stream := FileStream readOnlyFileNamed: fileName. ^ self formsFromStream: stream! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formsFromStream: stream | reader | reader := self new on: stream reset. Cursor read showWhile: [ reader allImages. reader close ]. ^ reader! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 6/12/2004 13:12'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('gif')! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^true! ! Model subclass: #AnimationSettings instanceVariableNames: 'useAnimation animateClosing delay numberOfSteps' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! animateClosing ^ animateClosing ifNil: [animateClosing := false]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! animateClosing: aBoolean animateClosing := aBoolean! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:24'! delay ^ delay ifNil: [delay := 8]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:22'! delay: anInteger delay := anInteger! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:23'! numberOfSteps ^ numberOfSteps ifNil: [numberOfSteps := 20]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:23'! numberOfSteps: anInteger numberOfSteps := anInteger! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:20'! useAnimation ^ useAnimation ifNil: [useAnimation := false]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! useAnimation: aBoolean useAnimation := aBoolean! ! Object subclass: #Annotation instanceVariableNames: '' classVariableNames: 'AnnotationRequests' poolDictionaries: '' category: 'System-Tools'! !Annotation commentStamp: '' prior: 0! An Annotation is a simple class describing the kinds of annotations for code browser. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Annotation class instanceVariableNames: ''! !Annotation class methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 17:51'! annotationRequests "Answer a list of symbol characterizing all the available kinds of annotations; Each symbol represents the info type: #timeStamp : The time stamp of the last submission of the method. #firstComment: The first comment in the method, if any. #masterComment: The comment at the beginning of the supermost implementor of the method if any. #documentation: Comment at beginning of the method or, if it has none, comment at the beginning of a superclass's implementation of the method. #messageCategory: Which method category the method lies in. #sendersCount: A report of how many senders there of the message. #implementorsCount: A report of how many implementors there are of the message. #recentChangeSet : The most recent change set bearing the method. #allChangeSets : A list of all change sets bearing the method. #priorVersionsCount: A report of how many previous versions there are of the method. #priorTimeStamp: The time stamp of the penultimate submission of the method, if any. " ^ AnnotationRequests ifNil: [AnnotationRequests := self defaultAnnotationInfo]! ! !Annotation class methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 17:51'! annotationRequests: aList "see annotationRequests comment" AnnotationRequests := aList! ! !Annotation class methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 17:51'! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! URLPlugin subclass: #AnnotationPanePlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AnnotationPanePlugin commentStamp: '' prior: 0! An IgorsPlugin is a plugin which displays info about the current selection! !AnnotationPanePlugin methodsFor: 'as yet unclassified' stamp: 'MarianoMartinezPeck 4/24/2012 23:25'! buildString | mdl stringBuilder | mdl := self model. stringBuilder := WriteStream on: ''. mdl selectedClass ifNil: [ '' ] ifNotNil: [:class | mdl selectedMethod ifNil: [ stringBuilder nextPutAll: (RGCommentDefinition realClass: class) timeStamp asTimeStamp asString. ] ifNotNil: [:method | stringBuilder nextPutAll: (AnnotationRequest onClass: class selector: method selector) getAnnotations. ]]. ^ stringBuilder contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnotationPanePlugin class instanceVariableNames: ''! !AnnotationPanePlugin class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/17/2012 16:39'! description ^ 'Display the information of the selected class/method'! ! Object subclass: #AnnotationRequest instanceVariableNames: 'selector class separator' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AnnotationRequest methodsFor: 'accessing' stamp: 'dc 6/18/2007 18:55'! method ^ class compiledMethodAt: selector ifAbsent: [nil]! ! !AnnotationRequest methodsFor: 'accessing' stamp: 'dc 5/2/2007 18:14'! separator: aString separator := aString! ! !AnnotationRequest methodsFor: 'actions' stamp: 'MarianoMartinezPeck 4/24/2012 23:38'! annotationRequests ^ CodeHolder annotationRequests copyWithout: #sendersCount ! ! !AnnotationRequest methodsFor: 'actions' stamp: 'lr 8/15/2010 17:10'! getAnnotations ^ String streamContents: [ :aStream | ((self annotationRequests collect: [ :request | self perform: request ]) reject: [ :stringOrNil | stringOrNil isEmptyOrNil ]) do: [ :each | aStream nextPutAll: each ] separatedBy: [ aStream nextPutAll: separator ] ]! ! !AnnotationRequest methodsFor: 'initialization' stamp: 'MAD 1/14/2009 11:44'! onClass: aClass selector: aSelector class := aClass. selector := aSelector. separator := ' - '.! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:13'! allChangeSets "A list of all change sets bearing the method." | changeSets | changeSets := ChangeSet allChangeSetsWithClass: class selector: selector. ^ changeSets isEmpty ifFalse: [ String streamContents: [ :aStream | changeSets size = 1 ifTrue: [ aStream nextPutAll: 'only in change set ' ] ifFalse: [ aStream nextPutAll: 'in change sets: ' ]. changeSets do: [ :aChangeSet | aStream nextPutAll: aChangeSet name; nextPutAll: ' ' ] ] ] ifTrue: [ 'in no change set' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:11'! documentation "Comment at beginning of the method or, if it has none, comment at the beginning of a superclass's implementation of the method." ^ class precodeCommentOrInheritedCommentFor: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:10'! firstComment "The first comment in the method, if any." ^ class firstCommentAt: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:13'! implementorsCount "A report of how many implementors there are of the message." | implementorsCount | implementorsCount := self systemNavigation numberOfImplementorsOf: selector. ^ implementorsCount = 1 ifTrue: [ '1 implementor' ] ifFalse: [ implementorsCount printString , ' implementors' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:11'! masterComment "The comment at the beginning of the supermost implementor of the method if any." ^ class supermostPrecodeCommentFor: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:15'! messageCategory "Which method category the method lies in." ^ class organization categoryOfElement: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:15'! priorTimeStamp "The time stamp of the penultimate submission of the method, if any." | stamp | ^ (stamp := VersionsBrowser timeStampFor: selector class: class reverseOrdinal: 2) isNil ifFalse: [ 'prior time stamp: ' , stamp ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:14'! priorVersionsCount "A report of how many previous versions there are of the method." | versionsCount | versionsCount := VersionsBrowser versionCountForSelector: selector class: class. ^ versionsCount > 1 ifTrue: [ versionsCount = 2 ifTrue: [ '1 prior version' ] ifFalse: [ versionsCount printString, ' prior versions' ] ] ifFalse: [ 'no prior versions' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:13'! recentChangeSet "The most recent change set bearing the method." ^ ChangeSet mostRecentChangeSetWithChangeForClass: class selector: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:12'! sendersCount "A report of how many senders there of the message." | sendersCount | sendersCount := (self systemNavigation allCallsOn: selector) size. ^ sendersCount = 1 ifTrue: [ '1 sender' ] ifFalse: [ sendersCount printString , ' senders' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:10'! timeStamp "The time stamp of the last submission of the method." ^ self method isNil ifFalse: [ self method timeStamp ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnotationRequest class instanceVariableNames: ''! !AnnotationRequest class methodsFor: 'instance-creation' stamp: 'PDC 6/25/2007 22:01'! onClass: aClass selector: aSelector ^ self new onClass: aClass selector: aSelector; yourself! ! Object subclass: #Announcement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcement commentStamp: 'Tbn 11/12/2010 10:57' prior: 0! This class is the superclass for events that someone might want to announce, such as a button click or an attribute change. Typically you create subclasses for your own events you want to announce. ! !Announcement methodsFor: '*Announcements-View' stamp: 'lr 9/3/2006 16:17'! open self inspect! ! !Announcement methodsFor: 'converting' stamp: 'lr 10/3/2006 14:32'! asAnnouncement ^ self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Announcement class instanceVariableNames: ''! !Announcement class methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 12:06'! nautilusIcon ^ self nautilusIconClass iconNamed: #announcement! ! !Announcement class methodsFor: 'converting' stamp: 'lr 10/3/2006 14:31'! asAnnouncement ^ self new! ! !Announcement class methodsFor: 'public' stamp: 'lr 9/20/2006 08:18'! , anAnnouncementClass ^ AnnouncementSet with: self with: anAnnouncementClass! ! !Announcement class methodsFor: 'testing' stamp: 'IgorStasenko 3/12/2011 17:05'! handles: anAnnouncementClass ^ anAnnouncementClass == self or: [ anAnnouncementClass inheritsFrom: self ]! ! Object subclass: #AnnouncementLogger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !AnnouncementLogger commentStamp: 'StephaneDucasse 5/9/2011 17:17' prior: 0! Use me to debug and log to the transcript annoncements. AnnouncementLogger new subscribeTo: SystemAnnouncer announcer To unsubscribe AnnouncementLogger allInstancesDo: [:each | SystemAnnouncer announcer unsubscribe: each ]! !AnnouncementLogger methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/9/2011 17:11'! logAnnouncement: ann Transcript show: ann printString ; cr! ! !AnnouncementLogger methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/9/2011 17:15'! subscribeTo: anAnnouncer anAnnouncer "weak" on: Announcement send: #logAnnouncement: to: self! ! Announcement subclass: #AnnouncementMockA instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementMockA commentStamp: 'Tbn 11/12/2010 10:54' prior: 0! This is a simple test mock.! Announcement subclass: #AnnouncementMockB instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementMockB commentStamp: 'Tbn 11/12/2010 10:54' prior: 0! This is a simple test mock! AnnouncementMockB subclass: #AnnouncementMockC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementMockC commentStamp: 'Tbn 11/12/2010 10:54' prior: 0! This is a simple test mock! Set subclass: #AnnouncementSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !AnnouncementSet commentStamp: '' prior: 0! If you want to register the same action for multiple events, simply create an AnnouncementSet using a comma: Parent>>initialize super initialize. self session announcer on: AddChild, RemoveChild do: [:it | self changeChild: it child] Motivation example: Often the UI is built after/independently from the model. You want to have the model raise fine-grained announcements to enable the layers on top, but sometimes it is easier in the UI to refresh everything whenever something happens.! !AnnouncementSet methodsFor: 'adding' stamp: 'lr 6/13/2006 08:13'! , anAnnouncementClass self add: anAnnouncementClass! ! !AnnouncementSet methodsFor: 'testing' stamp: 'lr 10/3/2006 14:31'! handles: anAnnouncementClass ^ self anySatisfy: [ :each | each handles: anAnnouncementClass ]! ! TestCase subclass: #AnnouncementSetTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementSetTest methodsFor: 'testing' stamp: 'Tbn 11/12/2010 11:07'! testIncludeOnlyOnce |set| set := AnnouncementMockA, AnnouncementMockB, AnnouncementMockA. self assert: set size = 2! ! !AnnouncementSetTest methodsFor: 'testing' stamp: 'Sd 11/26/2010 17:31'! testInstanceCreation |set| set := AnnouncementMockA, AnnouncementMockB. self assert: set size = 2 ! ! Object subclass: #AnnouncementSpy instanceVariableNames: 'announcer announcements index' classVariableNames: '' poolDictionaries: '' category: 'Announcements-View'! !AnnouncementSpy commentStamp: '' prior: 0! I am a tool to inspect live events . If you want to inspect events generated by an announcer without a priori knowledge about the kind and frequency of events, you can always open a spy on an announcer to track its events. announcer open or AnnouncementSpy openOn: announcer This opens a window which displays the sequence of events emitted by the announcer (after the spy has been launched). You can open/inspect each event individually using the contextual menu. you can also clear the list view. Try it on World announcer open (in Pharo 1.1 or later), then add and close windows to see events generated.! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! announcements ^ announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/3/2006 14:08'! announcements: aCollection announcements := aCollection. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:04'! announcer ^ announcer! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/25/2006 09:26'! announcer: anAnnouncer announcer ifNotNil: [ announcer unsubscribe: self ]. announcer := anAnnouncer. announcer ifNotNil: [ announcer subscribe: Announcement send: #announce: to: self ]! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! index ^ index ! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:20'! index: anInteger index := anInteger. self changed: #index! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 9/3/2006 14:08'! extent ^ 250 @ 400! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'StephaneDucasse 5/1/2011 14:27'! initialExtent ^ 300 @ 400! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'StephaneDucasse 5/1/2011 14:22'! label ^ 'Spy: ', (self announcer ifNil: ['no announcer'] ifNotNil: [ self announcer printString ]) ! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/3/2006 16:21'! clear self announcements: OrderedCollection new! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:19'! close self announcer: nil! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:25'! open (self announcements at: self index ifAbsent: [ ^ self ]) open! ! !AnnouncementSpy methodsFor: 'building' stamp: 'StephaneDucasse 5/1/2011 14:47'! build "self new build openInWorld" |window list| window := (SystemWindow labelled: self label) model: self. window addMorph: self buildList frame: (0 @ 0 corner: 1 @ 1). ^ window ! ! !AnnouncementSpy methodsFor: 'building' stamp: 'StephaneDucasse 5/1/2011 14:47'! buildList ^ (PluggableListMorph new) on: self list: #announcements selected: #index changeSelected: #index: menu: #buildMenu: keystroke: nil. ! ! !AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/3/2006 16:21'! buildMenu: aMenuMorph ^ aMenuMorph defaultTarget: self; add: 'open' action: #open; add: 'clear' action: #clear; yourself! ! !AnnouncementSpy methodsFor: 'initialization' stamp: 'lr 6/14/2006 17:03'! initialize super initialize. self announcements: OrderedCollection new. self index: 0! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 9/3/2006 14:09'! announce: anAnnouncement self announcements add: anAnnouncement. self index: self announcements size. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 6/14/2006 17:19'! changed: aSymbol WorldState addDeferredUIMessage: [ super changed: aSymbol ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementSpy class instanceVariableNames: ''! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! on: anAnnouncer ^ self new announcer: anAnnouncer; yourself! ! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'StephaneDucasse 5/1/2011 14:49'! openOn: anAnnouncer "Schedule a new window and open a new AnnouncementSpy on the announcer passed as argument" (self on: anAnnouncer) build openInWorld ! ! Object subclass: #AnnouncementSubscription instanceVariableNames: 'announcer announcementClass subscriber action' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !AnnouncementSubscription commentStamp: 'IgorStasenko 3/12/2011 20:23' prior: 0! The subscription is a single entry in a SubscriptionRegistry. Several subscriptions by the same object is possible. I know how to make myself weak or strong, only use this capability if it can't be determined at subscribe time though, as it uses become: (for thread-safety), which is quite slow.! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! action ^ action! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! action: anObject action := anObject! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:18'! announcementClass ^ announcementClass! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:18'! announcementClass: anObject announcementClass := anObject! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! announcer ^ announcer! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:13'! announcer: anAnnouncer announcer := anAnnouncer! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:14'! subscriber ^ subscriber! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:14'! subscriber: aSubscriber subscriber := aSubscriber! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:16'! valuable: aValuable "Used when subscriber should be extracted from valuable object" self action: aValuable. self subscriber: aValuable receiver.! ! !AnnouncementSubscription methodsFor: 'announcing' stamp: 'IgorStasenko 7/17/2011 17:09'! deliver: anAnnouncement " deliver an announcement to receiver. In case of failure, it will be handled in separate process" ^ (self handles: anAnnouncement class ) ifTrue: [ [action cull: anAnnouncement cull: announcer] on: UnhandledError fork: [:ex | ex pass ]]! ! !AnnouncementSubscription methodsFor: 'converting' stamp: 'IgorStasenko 3/12/2011 17:37'! makeStrong " i am already strong. Do nothing "! ! !AnnouncementSubscription methodsFor: 'converting' stamp: 'IgorStasenko 3/22/2011 15:41'! makeWeak action isBlock ifTrue: [ self error: 'Not currently available due to missing ephemerons support' ]. ^ announcer replace: self with: (WeakAnnouncementSubscription new announcer: announcer; action: action asWeakMessageSend; subscriber: subscriber; announcementClass: announcementClass)! ! !AnnouncementSubscription methodsFor: 'testing' stamp: 'IgorStasenko 3/12/2011 15:29'! handles: anAnnouncementClass ^ announcementClass handles: anAnnouncementClass! ! AnnouncementsHelp subclass: #AnnouncementsAPIDocumentation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Help'! !AnnouncementsAPIDocumentation commentStamp: 'Tbn 11/12/2010 11:17' prior: 0! This is a custom help book providing the API documentation for the announcements framework. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementsAPIDocumentation class instanceVariableNames: ''! !AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 10:41'! bookName ^'API Documentation'! ! !AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 10:42'! packages ^#('Announcements-Core' 'Announcements-View' 'Announcements-Tests-Core')! ! !AnnouncementsAPIDocumentation class methodsFor: 'defaults' stamp: 'Tbn 11/12/2010 10:41'! builder ^PackageAPIHelpBuilder! ! CustomHelp subclass: #AnnouncementsHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Help'! !AnnouncementsHelp commentStamp: 'Tbn 11/12/2010 11:17' prior: 0! This is a custom help book for the announcements framework. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementsHelp class instanceVariableNames: ''! !AnnouncementsHelp class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 10:35'! bookName ^'Announcements framework'! ! !AnnouncementsHelp class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 11:30'! pages ^#(introduction AnnouncementsTutorial AnnouncementsAPIDocumentation links)! ! !AnnouncementsHelp class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 11:18'! introduction "This method was automatically generated. Edit it using:" "AnnouncementsHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'The announcement framwork is an event notification framework. Compared to "traditional" Smalltalk event systems in this new framework, an event is a real object rather than a symbol. An event someone might want to announce, such as a button click or an attribute change, is defined as a subclass of the abstract superclass Announcement. The subclass can have instance variables for additional information to pass along, such as a timestamp, or mouse coordinates at the time of the event, or the old value of the parameter that has changed. To signal the actual occurrence of an event, the "announcer" creates and configures an instance of an appropriate announcement, then broadcasts that instance. Objects subscribed to receive such broadcasts from the announcer receive a broadcast notification together with the instance. They can talk to the instance to find out any additional information about the event that has occurred.!!' ! ! !AnnouncementsHelp class methodsFor: 'pages' stamp: 'MarianoMartinezPeck 4/30/2011 15:42'! links "This method was automatically generated. Edit it using:" "AnnouncementsHelp edit: #links" ^HelpTopic title: 'Links' contents: 'You can get more informations on the framework on the following websites: http://book.pharo-project.org/book/announcements http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?searchCategory=Announcements%20Framework http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?entry=3310034894 http://dougedmunds.com/pmwiki.php?n=Pharo.AnnouncementsTutorial '! ! AnnouncementsHelp subclass: #AnnouncementsTutorial instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Help'! !AnnouncementsTutorial commentStamp: 'Tbn 11/12/2010 11:17' prior: 0! This is a custom help book providing a tutorial for the announcements framework. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementsTutorial class instanceVariableNames: ''! !AnnouncementsTutorial class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 11:16'! bookName ^'Tutorial'! ! !AnnouncementsTutorial class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 13:54'! pages ^#(step1 step2 step3)! ! !AnnouncementsTutorial class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 12:59'! step1 "This method was automatically generated. Edit it using:" "AnnouncementsTutorial edit: #step1" ^HelpTopic title: 'Step 1 - Define an announcememt' contents: 'To define an announcement you just have to subclass the Announcement class: Announcement subclass: #MyInterestingAnnouncement instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Core'' If required you can add instance variables to hold data that should be transferred when an announcement is made: Announcement subclass: #GameLostAnnouncement instanceVariableNames: ''score'' classVariableNames: '''' poolDictionaries: '''' category: ''MyGame-Core''!!' readStream nextChunkText! ! !AnnouncementsTutorial class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 13:55'! step2 "This method was automatically generated. Edit it using:" "AnnouncementsTutorial edit: #step2" ^HelpTopic title: 'Step 2 - Publishers and subscribers' contents: 'If an object wants to announce an event it needs someone to make the announcement to. This is typically an instance of class Announcer which acts as the mediator between the object that has to announce something (publisher) and one or many (anonymous) subscribers who are interested in the event. | announcer | announcer := Announcer new. announcer announce: MyInterestingAnnouncement new Using #announce: we can make an announcement - but since nobody is interested yet nothing will happen. Lets add some consumers/subscribers. Subscribers just register on the Announcer instance to note that they are interested on a particular event/announcement: | announcer | announcer := Announcer new. announcer on: MyInterestingAnnouncement send: #open to: Browser. announcer on: MyInterestingAnnouncement send: #inspect to: Smalltalk. So anytime an interesting announcement is made we want to inform the two consumers with a specific message. Still nothing happens - we have to additionally make the announcement: | announcer | announcer := Announcer new. announcer on: MyInterestingAnnouncement send: #open to: Browser. announcer on: MyInterestingAnnouncement send: #inspect to: Smalltalk. announcer announce: MyInterestingAnnouncement new Note that the subscribers are decoupled from the orginal announcement publisher. They dont have to know each other. Decoupling is the key thing here ... subscribers can register for particular events/announcements and remain anonymous to the original publisher. !!' readStream nextChunkText! ! !AnnouncementsTutorial class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 14:06'! step3 "This method was automatically generated. Edit it using:" "AnnouncementsTutorial edit: #step3" ^HelpTopic title: 'Step 3 - More examples' contents: 'In Pharo there is a global called "World" pointing to the desktop morph. This world also has an announcer we can use to demonstrate the features of the framework: | announcer | World announcer on: WindowOpened send: #value to: [ Transcript show: ''A new window was opened'';cr]. So anytime a window is opened in the system a message is shown in the transcript: Transcript open. | announcer | World announcer on: WindowOpened send: #value to: [:ea | ea inspect. Transcript show: ''A new window was opened'';cr]. !!' readStream nextChunkText! ! Object subclass: #Announcer instanceVariableNames: 'registry' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcer commentStamp: 'IgorStasenko 3/12/2011 18:45' prior: 0! The code is based on the announcements as described by Vassili Bykov in . The implementation uses a threadsafe subscription registry, in the sense that registering, unregistering, and announcing from an announcer at the same time in different threads should never cause failures. For security reasons, registry is kept private, and has no accessor like in other implementations! !Announcer methodsFor: '*RPackage-core' stamp: 'EstebanLorenzano 8/3/2012 15:01'! hasSubscriber: anObject registry subscriptionsOf: anObject do: [:each | ^ true]. ^ false! ! !Announcer methodsFor: '*RPackage-core' stamp: 'StephaneDucasse 4/23/2011 12:43'! subscriptions ^ registry! ! !Announcer methodsFor: '*announcements-view' stamp: 'lr 9/20/2006 08:18'! open AnnouncementSpy openOn: self! ! !Announcer methodsFor: 'announce' stamp: 'StephaneDucasse 4/24/2011 11:06'! announce: anAnnouncement | announcement | announcement := anAnnouncement asAnnouncement. registry ifNotNil: [ registry deliver: announcement ]. ^ announcement! ! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 4/24/2011 12:15'! on: anAnnouncementClass do: aValuable "Declare that when anAnnouncementClass is raised, aValuable is executed." ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 4/24/2011 12:08'! on: anAnnouncementClass send: aSelector to: anObject "Declare that when anAnnouncementClass is raised, anObject should receive the message aSelector." ^ self subscribe: anAnnouncementClass send: aSelector to: anObject! ! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 4/24/2011 12:15'! when: anAnnouncementClass do: aValuable "Declare that when anAnnouncementClass is raised, aValuable is executed." ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'initialize-release' stamp: 'IgorStasenko 3/12/2011 16:50'! initialize super initialize. registry := SubscriptionRegistry new.! ! !Announcer methodsFor: 'statistics' stamp: 'IgorStasenko 3/12/2011 21:02'! numberOfSubscriptions ^ registry numberOfSubscriptions ! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 11:09'! removeSubscription: subscription "Remove the given subscription from the receiver" ^ registry remove: subscription ! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 12:17'! subscribe: anAnnouncementClass do: aValuable "Declare that when anAnnouncementClass is raised, aValuable is executed." ^ registry add: ( AnnouncementSubscription new announcer: self; announcementClass: anAnnouncementClass; valuable: aValuable)! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 12:16'! subscribe: anAnnouncementClass send: aSelector to: anObject "Declare that when anAnnouncementClass is raised, anObject should receive the message aSelector." ^ self subscribe: anAnnouncementClass do: (MessageSend receiver: anObject selector: aSelector)! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 12:15'! unsubscribe: anObject "Unsubscribe all subscriptions of anObject from the receiver" registry removeSubscriber: anObject! ! !Announcer methodsFor: 'weak' stamp: 'IgorStasenko 3/12/2011 20:26'! weak "announcer weak subscribe: foo" ^ WeakSubscriptionBuilder on: self! ! !Announcer methodsFor: 'private' stamp: 'IgorStasenko 3/12/2011 20:30'! basicSubscribe: subscription ^ registry add: subscription! ! !Announcer methodsFor: 'private' stamp: 'IgorStasenko 3/22/2011 15:27'! replace: subscription with: newOne ^ registry replace: subscription with: newOne ! ! TestCase subclass: #AnnouncerTest instanceVariableNames: 'announcer' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncerTest commentStamp: 'Tbn 11/12/2010 10:55' prior: 0! An AnnouncerTest is a test class used to test Announcer. Instance Variables announcer: the announcer to test announcer - the announcer that is tested ! !AnnouncerTest methodsFor: 'running' stamp: 'lr 2/26/2011 11:34'! setUp super setUp. announcer := self newAnnouncer! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:11'! testAnnounceClass self assert: (announcer announce: AnnouncementMockA) class = AnnouncementMockA! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:10'! testAnnounceInstance | instance | instance := AnnouncementMockA new. self assert: (announcer announce: instance) = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'IgorStasenko 1/2/2012 15:54'! testAnnouncingReentrant " Test that it is safe to announce when handling announcement, so announcer are reentrant " " self run: #testAnnouncingReentrant " | bool ok | ok := bool := false. announcer on: Announcement do: [ bool ifFalse: [ bool := true. announcer announce: Announcement new. ] ifTrue: [ ok := true ] ]. self should: [ announcer announce: Announcement new. ] notTakeMoreThan: 1 second. self assert: ok ! ! !AnnouncerTest methodsFor: 'testing' stamp: 'IgorStasenko 3/12/2011 21:47'! testNoArgBlock "we are supposed to accept zero-argument blocks as actions " | announcement counter | counter := nil. self shouldnt: [ announcer subscribe: AnnouncementMockA do: [ counter:= 1 ] ] raise: Exception. self shouldnt: [announcer announce: AnnouncementMockA new] raise: Exception. self assert: counter =1! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:08'! testSubscribeBlock | announcement instance | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSend | announcement instance | announcer subscribe: AnnouncementMockA send: #value: to: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSet | announcement instance | announcer subscribe: AnnouncementMockA , AnnouncementMockC do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:06'! testSubscribeSubclass | announcement instance | announcer subscribe: AnnouncementMockB do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance.! ! !AnnouncerTest methodsFor: 'testing' stamp: 'IgorStasenko 3/12/2011 21:46'! testTwoArgBlock "we are supposed to accept two-argument blocks as actions " | announcement flag | self shouldnt: [ announcer subscribe: AnnouncementMockA do: [:ann :announcer2 | flag := announcer2 == announcer ] ] raise: Exception. self shouldnt: [announcer announce: AnnouncementMockA new] raise: Exception. self assert: flag! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:10'! testUnsubscribeBlock | announcement | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSend | announcement receiver | announcer subscribe: AnnouncementMockA send: #value: to: (receiver := [ :ann | announcement := ann ]). announcer unsubscribe: receiver. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSet | announcement | announcer subscribe: AnnouncementMockA , AnnouncementMockB do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil. announcement := nil. announcer announce: AnnouncementMockB new. self assert: announcement isNil.! ! !AnnouncerTest methodsFor: 'private' stamp: 'lr 2/26/2011 11:34'! newAnnouncer ^ Announcer new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncerTest class instanceVariableNames: ''! !AnnouncerTest class methodsFor: 'testing' stamp: 'lr 2/26/2011 11:35'! shouldInheritSelectors ^ true! ! Object subclass: #AppRegistry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Applications'! !AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0! AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders. This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful. ! !AppRegistry methodsFor: 'notes' stamp: 'ads 4/2/2003 15:04'! seeClassSide "All the code for AppRegistry is on the class side."! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AppRegistry class instanceVariableNames: 'registeredClasses default'! !AppRegistry class methodsFor: '*UIManager' stamp: 'BenjaminVanRyseghem 2/22/2012 14:41'! chooseAppWithUI default := UIManager default chooseFrom: (self registeredClasses collect: [:c | c name]) values: self registeredClasses title: ('Which ' , self appName, ' would you prefer?') translated. default ifNil: [default := self registeredClasses first]. WorldState defaultWorldMenu. ^ default.! ! !AppRegistry class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:16'! cleanUp "AppRegistry cleanUp" self removeObsolete.! ! !AppRegistry class methodsFor: 'cleanup' stamp: 'StephaneDucasse 1/30/2011 21:35'! removeObsolete "AppRegistry removeObsolete" self registeredClasses copy do:[:cls| (cls class isObsolete or:[cls isBehavior and:[cls isObsolete]]) ifTrue:[self unregister: cls]]. self subclasses do:[:cls| cls removeObsolete].! ! !AppRegistry class methodsFor: 'cleanup' stamp: 'StephaneDucasse 1/30/2011 21:38'! reset "AppRegistry reset" registeredClasses := nil.! ! !AppRegistry class methodsFor: 'registering' stamp: 'ads 3/29/2003 13:36'! appName "Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to." ^ self name! ! !AppRegistry class methodsFor: 'registering' stamp: 'SeanDeNigris 9/15/2010 01:25'! register: aProviderClass (self registeredClasses includes: aProviderClass) ifTrue: [ ^ self ]. self askForNewDefaultOnNextRequest. "if you're registering a new app you probably want to use it" self registeredClasses add: aProviderClass.! ! !AppRegistry class methodsFor: 'registering' stamp: 'ads 3/29/2003 13:01'! registeredClasses ^ registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ! !AppRegistry class methodsFor: 'registering' stamp: 'ads 3/29/2003 13:03'! unregister: aProviderClass (default = aProviderClass) ifTrue: [default := nil]. self registeredClasses remove: aProviderClass ifAbsent: [].! ! !AppRegistry class methodsFor: 'singleton' stamp: 'StephaneDucasse 1/28/2011 15:16'! askForDefault "self askForDefault" self registeredClasses isEmpty ifTrue: [self inform: 'There are no ', self appName, ' applications registered.'. ^ default := nil]. self registeredClasses size = 1 ifTrue: [^ default := self registeredClasses anyOne]. ^Smalltalk globals at: #UIManager ifPresent: [:class | self chooseAppWithUI] ifAbsent: [| stream | stream := WriteStream with: 'You have to choose a Class by using ''#chooseApp: index:'''. stream nextPut: Character cr. self registeredClasses doWithIndex: [:class :index | stream nextPutAll: index asString; nextPutAll: ' - '; nextPutAll: class name asString; nextPut: Character cr]. self inform: stream contents. default := nil]! ! !AppRegistry class methodsFor: 'singleton' stamp: 'ads 3/29/2003 13:11'! default ^ default ifNil: [self askForDefault]! ! !AppRegistry class methodsFor: 'singleton' stamp: 'BenjaminVanRyseghem 2/24/2012 15:51'! default: aClassOrNil "Sets my default to aClassOrNil. Answers the old default." | oldDefault | oldDefault := default. aClassOrNil ifNotNil: [ self register: aClassOrNil ]. default := aClassOrNil. ^ oldDefault! ! !AppRegistry class methodsFor: 'singleton' stamp: 'nk 3/9/2004 12:35'! defaultOrNil ^ default! ! !AppRegistry class methodsFor: 'private' stamp: 'SeanDeNigris 9/15/2010 01:24'! askForNewDefaultOnNextRequest default := nil.! ! !AppRegistry class methodsFor: 'private' stamp: 'StephaneDucasse 1/28/2011 15:16'! chooseApp: anIndex ^default := self registeredClasses at: anIndex ifAbsent: [nil]! ! Object subclass: #Archive instanceVariableNames: 'members' classVariableNames: '' poolDictionaries: '' category: 'Compression-Archives'! !Archive commentStamp: '' prior: 0! This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addDirectory: aFileName ^self addDirectory: aFileName as: aFileName ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'! addDirectory: aFileName as: anotherFileName | newMember | newMember := self memberClass newFromDirectory: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'! addFile: aFileName ^self addFile: aFileName as: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'SeanDeNigris 5/18/2012 22:16'! addFile: aFileName as: anotherFileName | newMember | newMember := self memberClass newFromFile: aFileName. newMember localFileName: anotherFileName. self addMember: newMember. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addMember: aMember ^members addLast: aMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addString: aString as: aFileName | newMember | newMember := self memberClass newFromString: aString named: aFileName. self addMember: newMember. newMember localFileName: aFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'StephaneDucasse 6/22/2012 19:01'! addTree: aFileNameOrDirectory match: aBlock | nameSize | nameSize := aFileNameOrDirectory isString ifTrue: [aFileNameOrDirectory size] ifFalse: [aFileNameOrDirectory fullName size]. ^ self addTree: aFileNameOrDirectory removingFirstCharacters: nameSize + 1 match: aBlock! ! !Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:00'! addTree: aFileNameOrDirectory removingFirstCharacters: n ^ self addTree: aFileNameOrDirectory removingFirstCharacters: n match: [:e | true]! ! !Archive methodsFor: 'archive operations' stamp: 'SeanDeNigris 2/5/2013 15:14'! addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock | dir relativePath matches | dir := aFileNameOrDirectory asFileReference. relativePath := (dir fullName allButFirst: n) asFileReference. matches := dir entries select: [ :entry | aBlock value: entry ]. matches do: [ :e | | newMember | newMember := e isDirectory ifTrue: [ self memberClass newFromDirectory: e fullName ] ifFalse: [ self memberClass newFromFile: e fullName ]. newMember localFileName: (relativePath / e name) fullName. self addMember: newMember. e isDirectory ifTrue: [ self addTree: e fullName removingFirstCharacters: n match: aBlock ]. ]. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'! canWriteToFileNamed: aFileName "Catch attempts to overwrite existing zip file" ^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! contentsOf: aMemberOrName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. ^member contents! ! !Archive methodsFor: 'archive operations' stamp: 'CamilloBruni 5/4/2012 21:18'! extractMember: aMemberOrName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: member localFileName inDirectory: FileSystem workingDirectory.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! extractMember: aMemberOrName toFileNamed: aFileName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'CamilloBruni 5/4/2012 21:18'! extractMemberWithoutPath: aMemberOrName self extractMemberWithoutPath: aMemberOrName inDirectory: FileSystem workingDirectory.! ! !Archive methodsFor: 'archive operations' stamp: 'CamilloBruni 5/7/2012 02:03'! extractMemberWithoutPath: aMemberOrName inDirectory: dir | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: (member asFileReference basename) inDirectory: dir! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! memberNamed: aString "Return the first member whose zip name or local file name matches aString, or nil" ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'! memberNames ^members collect: [ :ea | ea fileName ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! members ^members! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! membersMatching: aString ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'! numberOfMembers ^members size! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! removeMember: aMemberOrName | member | member := self member: aMemberOrName. member ifNotNil: [ members remove: member ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! replaceMember: aMemberOrName with: newMember | member | member := self member: aMemberOrName. member ifNotNil: [ members replaceAll: member with: newMember ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'! setContentsOf: aMemberOrName to: aString | newMember oldMember | oldMember := self member: aMemberOrName. newMember := (self memberClass newFromString: aString named: oldMember fileName) copyFrom: oldMember. self replaceMember: oldMember with: newMember.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'! writeTo: aStream self subclassResponsibility! ! !Archive methodsFor: 'archive operations' stamp: 'StephaneDucasse 2/25/2010 18:02'! writeToFileNamed: aFileName "Catch attempts to overwrite existing zip file" (self canWriteToFileNamed: aFileName) ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. StandardFileStream forceNewFileNamed: aFileName do: [:stream | self writeTo: stream ] ! ! !Archive methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. members := OrderedCollection new.! ! !Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! member: aMemberOrName ^(members includes: aMemberOrName) ifTrue: [ aMemberOrName ] ifFalse: [ self memberNamed: aMemberOrName ].! ! !Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! memberClass self subclassResponsibility! ! Object subclass: #ArchiveMember instanceVariableNames: 'fileName isCorrupt' classVariableNames: '' poolDictionaries: '' category: 'Compression-Archives'! !ArchiveMember commentStamp: '' prior: 0! This is the abstract superclass for archive members, which are files or directories stored in archives.! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName ^fileName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName: aName fileName := aName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'! isCorrupt ^isCorrupt ifNil: [ isCorrupt := false ]! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! isCorrupt: aBoolean "Mark this member as being corrupt." isCorrupt := aBoolean! ! !ArchiveMember methodsFor: 'accessing' stamp: 'SeanDeNigris 6/19/2012 09:23'! localFileName: aString "Set my internal filename. Returns the (possibly new) filename" ^fileName := aString copyReplaceAll: FileSystem disk delimiter asString with: UnixStore delimiter asString.! ! !ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! close ! ! !ArchiveMember methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. fileName := ''. isCorrupt := false.! ! !ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self fileName; nextPut: $)! ! !ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'! usesFileNamed: aFileName "Do I require aFileName? That is, do I care if it's clobbered?" ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArchiveMember class instanceVariableNames: ''! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! newDirectoryNamed: aString self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromFile: aFileName self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromString: aString self subclassResponsibility! ! Error subclass: #ArithmeticError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !ArithmeticError commentStamp: 'SvenVanCaekenberghe 4/21/2011 12:40' prior: 0! I am ArithmeticError, the superclass of all exceptions related to arithmentic.! ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! !Array commentStamp: '' prior: 0! I present an ArrayedCollection whose elements are objects.! !Array methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 20:09'! +* aCollection "Premultiply aCollection by self. aCollection should be an Array or Matrix. The name of this method is APL's +.x squished into Smalltalk syntax." ^aCollection preMultiplyByArray: self ! ! !Array methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 20:10'! preMultiplyByArray: a "Answer a+*self where a is an Array. Arrays are always understood as column vectors, so an n element Array is an n*1 Array. This multiplication is legal iff self size = 1." self size = 1 ifFalse: [self error: 'dimensions do not conform']. ^a * self first! ! !Array methodsFor: '*Collections-arithmetic' stamp: 'eem 6/11/2008 12:49'! preMultiplyByMatrix: m "Answer m+*self where m is a Matrix." m columnCount = self size ifFalse: [self error: 'dimensions do not conform']. ^(1 to: m rowCount) collect: [:row | | s | s := 0. 1 to: self size do: [:k | s := (m at: row at: k) * (self at: k) + s]. s]! ! !Array methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:12'! fuelAccept: aGeneralMapper "This IF is because there are subclasses of Array that are weak. If we do not put this IF, all subclasses fuel be using the #visitVariableObject:, loosing the capability of the weak However, this method is just to optimize the method lookup of the message #fuelAccept:. If this method is removed, the default behavior of Object shuld work as well. If the performance is not that different, then we can remove this method which has an ugly if." ^ self class isWeak ifTrue: [ aGeneralMapper visitWeakObject: self ] ifFalse: [ aGeneralMapper visitVariableObject: self ] ! ! !Array methodsFor: '*Morphic' stamp: 'StephaneDucasse 12/21/2012 13:53'! asLayoutFrame ^ LayoutFrame new fromArray: self! ! !Array methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 11:34'! generateSpec | str spec | str := self readStream. spec := OrderedCollection with: #FrameLayout. #( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ) do: [:sel | spec add: sel. str next ifNil: [ spec add: 0 ] ifNotNil: [:value | spec add: value ]]. ^ spec asArray! ! !Array methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 14:03'! generateSpecFormat | str symbols | str := self readStream. symbols := #( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ). ^ String streamContents: [:s | s << '#(FrameLayout' ; cr. self first == 0 ifFalse: [ s tab << #leftFraction: << ' ' << self first asString; cr ]. self second == 0 ifFalse: [ s tab << #topFraction: << ' ' << self second asString; cr]. self third == 1 ifFalse: [ s tab << #rightFraction: << ' ' << self third asString ;cr]. self fourth == 1 ifFalse: [ s tab << #bottomFraction: << ' ' << self fourth asString ;cr]. self size = 8 ifTrue: [ 5 to: 8 do: [:i | (self at: i) == 0 ifFalse: [ s tab << (symbols at: i) << ' ' << (self at:i) asString. s cr ]]]. s skip: -1 s << ')']. ! ! !Array methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 14:29'! generateSpecFormatArray | str symbols | str := self readStream. symbols := #( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ). ^ String streamContents: [:s | s << '{#FrameLayout.' ; cr. self first asInteger== 0 ifFalse: [ s tab << ('#','leftFraction:.') << ' ' << self first asString <<'.'; cr ]. self second asInteger == 0 ifFalse: [ s tab << ('#','topFraction:.') << ' ' << self second asString <<'.'; cr]. self third asInteger == 1 ifFalse: [ s tab << ('#','rightFraction:.') << ' ' << self third asString <<'.';cr]. self fourth asInteger == 1 ifFalse: [ s tab << ('#','bottomFraction:.') << ' ' << self fourth asString <<'.';cr]. self size = 8 ifTrue: [ 5 to: 8 do: [:i | (self at: i) asInteger == 0 ifFalse: [ s tab << ('#',(symbols at: i) asString) <<'.' << ' ' << (self at:i) asString <<'.'. s cr ]]]. s skip: -1. s << '}']. ! ! !Array methodsFor: '*System-Settings-Browser' stamp: 'AlainPlantec 1/31/2010 10:35'! settingStoreOn: aStream "Use the literal form if possible." self isLiteral ifTrue: [aStream nextPut: $#; nextPut: $(. self do: [:element | element settingStoreOn: aStream. aStream space]. aStream nextPut: $)] ifFalse: [super settingStoreOn: aStream]! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'! atWrap: index "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'! atWrap: index put: anObject "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1 put: anObject! ! !Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! literalEqual: other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. self with: other do: [:e1 :e2 | (e1 literalEqual: e2) ifFalse: [^ false]]. ^ true! ! !Array methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'! asArray "Answer with the receiver itself." ^ self! ! !Array methodsFor: 'converting' stamp: 'tpr 11/2/2004 11:31'! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." otherArray class == Array ifFalse: [^ self error: 'arg must be array']. self size = otherArray size ifFalse: [^ self error: 'arrays must be same size']. (self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. (otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']]. "Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once" (Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect ifTrue: [^ self primitiveFailed]. ^ self elementsExchangeIdentityWith: otherArray! ! !Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'! elementsForwardIdentityTo: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'brp 9/26/2003 08:09'! elementsForwardIdentityTo: otherArray copyHash: copyHash "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'CamilloBruni 10/20/2012 18:10'! sorted: aSortBlock "Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." ^self copy sort: aSortBlock! ! !Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement self size = 0 ifTrue:[^DependentsArray with: newElement]. ^self copyWith: newElement! ! !Array methodsFor: 'filter streaming' stamp: 'BernardoContreras 11/6/2011 17:04'! storeOnStream: aStream self shouldBePrintedAsLiteral ifTrue: [ super storeOnStream: aStream ] ifFalse: [ aStream writeCollection: self ] ! ! !Array methodsFor: 'printing' stamp: 'BernardoContreras 11/6/2011 02:47'! printOn: aStream self shouldBePrintedAsLiteral ifTrue: [self printAsLiteralFormOn: aStream. ^ self]. self isSelfEvaluating ifTrue: [self printAsSelfEvaluatingFormOn: aStream. ^ self]. super printOn: aStream! ! !Array methodsFor: 'printing' stamp: 'ul 11/23/2010 13:28'! storeOn: aStream "Use the literal form if possible." self shouldBePrintedAsLiteral ifTrue: [aStream nextPut: $#; nextPut: $(. self do: [:element | element storeOn: aStream. aStream space]. aStream nextPut: $)] ifFalse: [super storeOn: aStream]! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! isSelfEvaluating ^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! printAsLiteralFormOn: aStream aStream nextPut: $#. self printElementsOn: aStream ! ! !Array methodsFor: 'self evaluating' stamp: 'StephaneDucasse 10/8/2011 12:07'! printAsSelfEvaluatingFormOn: aStream aStream nextPut: ${. self do: [:el | el printOn: aStream] separatedBy: [ aStream nextPutAll: '. ']. aStream nextPut: $}! ! !Array methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! isArray ^true! ! !Array methodsFor: 'testing' stamp: 'nice 11/2/2009 19:06'! isLiteral ^self class == Array and: [self allSatisfy: [:each | each isLiteral]]! ! !Array methodsFor: 'testing' stamp: 'ul 11/23/2010 13:28'! shouldBePrintedAsLiteral ^self class == Array and: [ self allSatisfy: [ :each | each shouldBePrintedAsLiteral ] ]! ! !Array methodsFor: 'private' stamp: 'nice 7/20/2011 09:03'! hasLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSymbol:" | lit | 1 to: self size do: [:index | ((lit := self at: index) literalEqual: literal) ifTrue: [^true]. (Array == lit class and: [lit hasLiteral: literal]) ifTrue: [^true]]. ^false! ! !Array methodsFor: 'private' stamp: 'md 3/1/2006 21:09'! hasLiteralSuchThat: testBlock "Answer true if testBlock returns true for any literal in this array, even if imbedded in further Arrays or CompiledMethods. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" | lit | 1 to: self size do: [:index | (testBlock value: (lit := self at: index)) ifTrue: [^ true]. (lit hasLiteralSuchThat: testBlock) ifTrue: [^ true]]. ^ false! ! !Array methodsFor: 'private' stamp: 'nice 7/20/2011 18:01'! refersToLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structures or closure methods" 1 to: self size do: [ :index | | lit | (literal literalEqual: (lit := self at: index)) ifTrue: [ ^ true ]. (lit refersToLiteral: literal) ifTrue: [ ^ true ] ]. ^ false! ! !Array methodsFor: 'private'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Array class instanceVariableNames: ''! !Array class methodsFor: 'brace support' stamp: 'di 11/18/1999 22:53'! braceStream: nElements "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ WriteStream basicNew braceArray: (self new: nElements) ! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWith: a "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 1. array at: 1 put: a. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:15'! braceWith: a with: b "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 2. array at: 1 put: a. array at: 2 put: b. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 3. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c with: d "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 4. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. array at: 4 put: d. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWithNone "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ self new: 0! ! !Array class methodsFor: 'instance creation' stamp: 'StephaneDucasse 2/13/2010 12:18'! empty "A canonicalized empty Array instance." ^ #()! ! !Array class methodsFor: 'instance creation' stamp: 'md 7/19/2004 12:34'! new: sizeRequested "Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. This is a shortcut (direct call of primitive, no #initialize, for performance" "This method runs primitively if successful" ^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:" ! ! TestCase subclass: #ArrayLiteralTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !ArrayLiteralTest methodsFor: 'initialization' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !ArrayLiteralTest methodsFor: 'running' stamp: 'EstebanLorenzano 8/3/2012 13:59'! runCase SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ] ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:34'! testByteArrayBase self class compile: 'array ^ #[2r1010 8r333 16rFF]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 3). self assert: (self array first = 10). self assert: (self array second = 219). self assert: (self array last = 255) ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:35'! testByteArrayEmpty self class compile: 'array ^ #[]'. self assert: (self array isKindOf: ByteArray). self assert: (self array isEmpty)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:36'! testByteArrayLiteral self class compile: 'array ^ #[ 1 2 3 4 ]'. self assert: (self array = self array). self assert: (self array == self array)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:45'! testByteArrayLong self class compile: 'array ^ #[ ' , ((0 to: 255) inject: ' ' into: [ :r :e | r , ' ' , e asString ]) , ' ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 256). 0 to: 255 do: [ :index | self assert: (self array at: index + 1) = index ]! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:32'! testByteArrayRange self class compile: 'array ^ #[ 0 255 ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 2). self assert: (self array first = 0). self assert: (self array last = 255)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'Henrik Sperre Johansen 3/23/2009 13:55'! testByteArrayWithinArray self class compile: 'array ^ #( #[1] #[2] )'. self assert: (self array isKindOf: Array). self assert: (self array size = 2). self assert: (self array first isKindOf: ByteArray). self assert: (self array first first = 1). self assert: (self array last isKindOf: ByteArray). self assert: (self array last first = 2) ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:09'! testSymbols self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'. self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! ! CollectionRootTest subclass: #ArrayTest uses: TEmptySequenceableTest + TSequencedElementAccessTest + TCloneTest + TIncludesWithIdentityCheckTest + TCopyTest + TCreationWithTest + TPutBasicTest + TConvertTest - {} + TOccurrencesForMultiplinessTest + TIterateSequencedReadableTest + TSequencedConcatenationTest + TReplacementSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TBeginsEndsWith + TPrintOnSequencedTest + TIndexAccess + TSubCollectionAccess + TConvertAsSetForMultiplinessIdentityTest + TCopyPartOfSequenceable + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TIndexAccessForMultipliness + TCopyPartOfSequenceableForMultipliness + TConvertAsSortedTest + TPutTest + TSequencedStructuralEqualityTest + TSortTest + TSetArithmetic instanceVariableNames: 'example1 literalArray selfEvaluatingArray otherArray nonSEArray1 nonSEarray2 example2 empty collectResult withoutEqualElements withEqualElements withCharacters unsortedCollection sortedInAscendingOrderCollection sizeCollection collectionNotIncluded removedCollection elementInForCopy elementNotInForCopy firstIndex secondIndex replacementCollection indexArray valueArray nonEmptyMoreThan1Element subCollectionNotIn replacementCollectionSameSize oldSubCollection nonEmpty1Element collectionOfCollection collectionOfFloatWithEqualElements floatCollectionWithSameBeginingAnEnd collectionWithoutNil duplicateElement collection5Elements collectionWith4Elements' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Arrayed'! !ArrayTest commentStamp: '' prior: 0! This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - there is a chapter in the PharoByExample book (http://pharobyexample.org/) - the sunit class category! !ArrayTest methodsFor: '*Collections-arithmetic-testing' stamp: 'stephane.ducasse 10/6/2008 16:53'! testPremultiply self assert: example1 +* #(2 ) = #(2 4 6 8 10 ) ! ! !ArrayTest methodsFor: 'as yet unclassified'! testStreamContents | result index | result:= self collectionClass streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !ArrayTest methodsFor: 'as yet unclassified'! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !ArrayTest methodsFor: 'as yet unclassified'! testStreamContentsSized | result | result:= self collectionClass new: 1 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection. result:= self collectionClass new: 1000 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:12'! aValue ^ 33! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! anIndex ^ 2! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! anotherValue ^ 66! ! !ArrayTest methodsFor: 'initialization' stamp: 'cyrille.delaunay 12/18/2009 12:59'! collection ^ collectionWith4Elements ! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! empty ^ empty! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! nonEmpty ^ example1! ! !ArrayTest methodsFor: 'initialization' stamp: 'cyrille.delaunay 12/18/2009 11:59'! result ^ collectResult! ! !ArrayTest methodsFor: 'initialization' stamp: 'StephaneDucasse 3/13/2010 16:58'! setUp literalArray := #(1 true 3 #four). selfEvaluatingArray := { 1. true. (3/4). Color black. (2 to: 4) . 5 }. nonSEArray1 := { 1 . Set with: 1 }. nonSEarray2 := { Smalltalk globals associationAt: #Array }. example1 := #(1 2 3 4 5) copy. indexArray:= {2. 3. 4.}. valueArray:={0. 0. 0.}. oldSubCollection:= {2. 3. 4.}. nonEmptyMoreThan1Element:= example1. subCollectionNotIn:= {1. 8. 3.}. collectionNotIncluded:= {7. 8. 9.}. removedCollection:= { 2. 4. }. example2 := {1. 2. 3/4. 4. 5}. collectionWith4Elements := #(1 -2 3 1). collectionWithoutNil := #( 1 2 3 4). collectResult := {SmallInteger. SmallInteger. SmallInteger. SmallInteger.}. empty := #(). duplicateElement := 5.2. withEqualElements := {1.5. duplicateElement . 6.1. 2.0. duplicateElement .} . withoutEqualElements := {1.1. 4.4. 6.5. 2.4. 3.1.}. withCharacters := {$a. $x. $d. $c. $m.}. unsortedCollection := {1. 2. 8. 5. 6. 7.}. sortedInAscendingOrderCollection := {1. 2. 3. 4. 5. 6.}. elementInForCopy:= 2. elementNotInForCopy:= 9. firstIndex:= 2. secondIndex:= 4. replacementCollection:= {4. 3. 2. 1.}. replacementCollectionSameSize := {5. 4. 3.}. nonEmpty1Element:={ 5.}. collectionOfCollection:={1.5. 5.5. 6.5.}. collectionOfFloatWithEqualElements:={1.5. 5.5. 6.5. 1.5}. floatCollectionWithSameBeginingAnEnd := {1.5. 5.5. 1.5 copy}. collection5Elements := { 1. 2. 5. 3. 4.}.! ! !ArrayTest methodsFor: 'parameters'! accessValuePutIn "return access the element put in the non-empty collection" ^ self perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters'! accessValuePutInOn: s "return access the element put in the non-empty collection" ^ s perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 15:12'! selectorToAccessValuePutIn "return the selector of the method that should be invoked to access an element" ^ #second! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/9/2008 18:49'! valuePutIn "the value that we will put in the non empty collection" ^ 2! ! !ArrayTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:02'! accessCollection ^ example1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! anotherElementNotIn ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 11:11'! collectionInForIncluding ^ self nonEmpty copyWithoutFirst.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:01'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collection5Elements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/30/2009 10:51'! collectionNotIncluded ^ collectionNotIncluded.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:28'! collectionWith1TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst). ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:29'! collectionWith2TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst),self oldSubCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:58'! collectionWithCharacters ^ withCharacters.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements clas' containing no elements equals ( with identity equality) but 2 elements only equals with classic equality" | result collection | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. collection add: collection first copy. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ removedCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:57'! collectionWithEqualElements ^ withEqualElements.! ! !ArrayTest methodsFor: 'requirements'! collectionWithIdentical "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" | result collection anElement | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. anElement := collection first. collection add: anElement. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:17'! collectionWithNonIdentitySameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:15'! collectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals . (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:27'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:09'! collectionWithoutEqualElements ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:39'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNil ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:27'! element ^ 3! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! elementInCollectionOfFloat ^ collectionOfCollection atRandom! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:28'! elementInForCopy ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:55'! elementInForIncludesTest ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/10/2009 14:49'! elementInForIndexAccess ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:18'! elementInForIndexAccessing ^ withoutEqualElements anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:54'! elementInForOccurrences ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! elementInForReplacement ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotIn "return an element not included in 'nonEmpty' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! elementNotInForCopy ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/7/2009 11:18'! elementNotInForIndexAccessing ^elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotInForOccurrences ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:13'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot include equal elements ( classic equality )" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! firstCollection ^example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstEven "Returns the first even number of #collection" ^ -2! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! firstIndex ^ firstIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstOdd "Returns the first odd number of #collection" ^ 1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:00'! floatCollectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 16:00'! indexArray ^ indexArray .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:59'! indexInForCollectionWithoutDuplicates ^ 2.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 16:56'! indexInNonEmpty ^ 2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 15:53'! integerCollection ^example1 .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:28'! integerCollectionWithoutEqualElements ^{1. 2. 6. 5.}! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan3Elements " return a collection including atLeast 3 elements" ^ example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan4Elements " return a collection including at leat 4 elements" ^ example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! newElement ^999! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/8/2009 11:40'! nonEmpty1Element ^ nonEmpty1Element ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 15:20'! nonEmptyMoreThan1Element ^nonEmptyMoreThan1Element .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 11:41'! oldSubCollection ^oldSubCollection ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! replacementCollection ^replacementCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:32'! replacementCollectionSameSize ^replacementCollectionSameSize ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! secondCollection ^example2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! secondIndex ^ secondIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/13/2009 16:59'! sizeCollection ^ self collection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 14:08'! smallerIndex ^ firstIndex -1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! sortedInAscendingOrderCollection ^sortedInAscendingOrderCollection . ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/3/2009 11:35'! subCollectionNotIn ^subCollectionNotIn ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! unsortedCollection ^unsortedCollection .! ! !ArrayTest methodsFor: 'requirements'! valueArray " return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " | result | result := Array new: self indexArray size. 1 to: result size do: [:i | result at:i put: (self aValue ). ]. ^ result.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! withEqualElements " return a collection of float including equal elements (classic equality)" ^ collectionOfFloatWithEqualElements! ! !ArrayTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 55! ! !ArrayTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 22:00'! collectionClass ^ Array! ! !ArrayTest methodsFor: 'test - creation'! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !ArrayTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !ArrayTest methodsFor: 'test - creation'! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !ArrayTest methodsFor: 'test - creation'! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) = ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) = ( collection occurrencesOf: element2). ! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !ArrayTest methodsFor: 'test - equality'! testEqualSignIsTrueForEmptyButNonIdenticalCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). ! ! !ArrayTest methodsFor: 'test - equality'! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !ArrayTest methodsFor: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:10'! expectedSizeAfterReject ^1! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Array! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/13/2009 16:28'! testAnySatisfy self assert: ( self collection anySatisfy: [:each | each = -2]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:12'! testDo | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result.! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:13'! testDo2 | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result. ! ! !ArrayTest methodsFor: 'testing' stamp: 'StephaneDucasse 11/6/2011 22:45'! testComplexIsSelfEvaluating "self run: #testComplexIsSelfEvaluating" | complexArray restoredArray | complexArray := {1. true. false. nil. #a. 'a'. $a. Float pi. Float halfPi. 4/5. Float infinity negated. Color red. 1@2. (0@0 extent: 1@1). 'hola'-> 0. Object. Object class}. complexArray := complexArray copyWith: complexArray. self assert: complexArray isSelfEvaluating. self shouldnt: [restoredArray := self class evaluatorClass evaluate: complexArray printString] raise: Error. self assert: restoredArray = complexArray! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:12'! testIsArray self assert: example1 isArray! ! !ArrayTest methodsFor: 'testing' stamp: 'nice 11/3/2009 21:28'! testIsLiteral "We work with a copy of literalArray, to avoid corrupting the code." | aLiteralArray | aLiteralArray := literalArray copy. self assert: aLiteralArray isLiteral. aLiteralArray at: 1 put: self class. self deny: aLiteralArray isLiteral. self deny: (literalArray as: WeakArray) isLiteral description: 'instances of Array subclasses are not literal'.! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:18'! testIsSelfEvaluating self assert: example1 isSelfEvaluating. example1 at: 1 put: Bag new. self deny: example1 isSelfEvaluating. example1 at: 1 put: 1.! ! !ArrayTest methodsFor: 'testing' stamp: 'StephaneDucasse 1/16/2010 10:07'! testLiteralEqual self deny: (example1 literalEqual: example1 asIntegerArray)! ! !ArrayTest methodsFor: 'testing' stamp: 'dc 5/24/2007 10:56'! testNewWithSize |array| array := Array new: 5. self assert: array size = 5. 1 to: 5 do: [:index | self assert: (array at: index) isNil]! ! !ArrayTest methodsFor: 'testing' stamp: 'StephaneDucasse 11/6/2011 22:46'! testPrinting "self debug: #testPrinting" self assert: literalArray printString = '#(1 true 3 #four)'. self assert: (literalArray = (self class evaluatorClass evaluate: literalArray printString)). self assert: (selfEvaluatingArray = (self class evaluatorClass evaluate: selfEvaluatingArray printString)). self assert: nonSEArray1 printString = 'an Array(1 a Set(1))'. self assert: nonSEarray2 printString = '{#Array->Array}' ! ! !ArrayTest methodsFor: 'tests - accessing' stamp: 'delaunay 4/10/2009 16:19'! testAtWrap2 | tabTest | tabTest := #(5 6 8 ). self assert: (tabTest atWrap: 2) = 6. self assert: (tabTest atWrap: 7) = 5. self assert: (tabTest atWrap: 5) = 6. self assert: (tabTest atWrap: 0) = 8. self assert: (tabTest atWrap: 1) = 5. self assert: (tabTest atWrap: -2) = 5! ! !ArrayTest methodsFor: 'tests - as identity set'! testAsIdentitySetWithIdentityEqualsElements | result | result := self collectionWithIdentical asIdentitySet. " Only one element should have been removed as two elements are equals with Identity equality" self assert: result size = (self collectionWithIdentical size - 1). self collectionWithIdentical do: [ :each | (self collectionWithIdentical occurrencesOf: each) > 1 ifTrue: [ "the two elements equals only with classic equality shouldn't 'have been removed" self assert: (result asOrderedCollection occurrencesOf: each) = 1 " the other elements are still here" ] ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'tests - as identity set'! testAsIdentitySetWithoutIdentityEqualsElements | result collection | collection := self collectionWithCopy. result := collection asIdentitySet. " no elements should have been removed as no elements are equels with Identity equality" self assert: result size = collection size. collection do: [ :each | (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'tests - as set tests'! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !ArrayTest methodsFor: 'tests - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !ArrayTest methodsFor: 'tests - as sorted collection' stamp: 'hfm 4/2/2010 13:36'! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPutTwoValues "self debug: #testAtPutTwoValues" self nonEmpty at: self anIndex put: self aValue. self nonEmpty at: self anIndex put: self anotherValue. self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty last)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsEndsWith self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst). self assert: (self nonEmpty endsWith: self nonEmpty). self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first)).! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - concatenation'! testConcatenation | result index | result:= self firstCollection,self secondCollection . "first part : " index := 1. self firstCollection do: [:each | self assert: (self firstCollection at: index)=each. index := index+1.]. "second part : " 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:index). index:=index+1]. "size : " self assert: result size = (self firstCollection size + self secondCollection size).! ! !ArrayTest methodsFor: 'tests - concatenation'! testConcatenationWithEmpty | result | result:= self empty,self secondCollection . 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:i). ]. "size : " self assert: result size = ( self secondCollection size).! ! !ArrayTest methodsFor: 'tests - converting'! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !ArrayTest methodsFor: 'tests - converting'! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:35'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size! ! !ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 14:55'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !ArrayTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !ArrayTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !ArrayTest methodsFor: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !ArrayTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !ArrayTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !ArrayTest methodsFor: 'tests - copy'! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - copy'! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !ArrayTest methodsFor: 'tests - copy'! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !ArrayTest methodsFor: 'tests - copy'! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - copy'! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !ArrayTest methodsFor: 'tests - copy'! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfter | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyEmptyMethod | result | result := self collectionWithoutEqualElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyFromTo | result index collection | collection := self collectionWithoutEqualElements . index :=self indexInForCollectionWithoutDuplicates . result := collection copyFrom: index to: collection size . "verify content of 'result' : " 1 to: result size do: [:i | self assert: (result at:i)=(collection at: (i + index - 1))]. "verify size of 'result' : " self assert: result size = (collection size - index + 1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpTo | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyAfterLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the last occurence of element :" result := collection copyAfterLast: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyAfterWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the first occurence :" result := collection copyAfter: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (collection at:(i + 1 )) = (result at: (i)) ]. "verify size: " self assert: result size = (collection size - 1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyUpToLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpToLast:' should copy until the last occurence :" result := collection copyUpToLast: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (result at: i ) = ( collection at: i ) ]. self assert: result size = (collection size - 1). ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyUpToWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpTo:' should copy until the first occurence :" result := collection copyUpTo: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying same contents'! testReverse | result | result := self nonEmpty reversed. "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at: i) = (self nonEmpty at: (self nonEmpty size - i + 1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testReversed | result | result := self nonEmpty reversed . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShuffled | result | result := self nonEmpty shuffled . "verify content of 'result: '" result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !ArrayTest methodsFor: 'tests - copying with or without'! testForceToPaddingStartWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). "verify content of 'result' : " 1 to: 2 do: [:i | self assert: ( element ) = ( result at:(i) ) ]. 3 to: result size do: [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'tests - copying with or without'! testForceToPaddingWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). "verify content of 'result' : " 1 to: self nonEmpty size do: [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. (result size - 1) to: result size do: [:i | self assert: ( result at:i ) = ( element ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'tests - copying with replacement'! firstIndexesOf: subCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceAllWithManyOccurence | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | " testing fixture here as this method may be not used for collection that can't contain equals element :" self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. " test :" diff := self replacementCollection size - self oldSubCollection size. result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . " verifying that replacementCollection has been put in places of oldSubCollections " firstIndexesOfOccurrence do: [ :each | (firstIndexesOfOccurrence indexOf: each) = 1 ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. ] ifFalse:[ (each + diff) to: self replacementCollection size do: [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. ]. ]. " verifying that the 'between' parts correspond to the initial collection : " 1 to: firstIndexesOfOccurrence size do: [ :i | i = 1 " specific comportement for the begining of the collection :" ifTrue: [ 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] " between parts till the end : " ifFalse: [ resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] ] ]. "final part :" 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: [ :i | self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . ]! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceFromToWith | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . "verify content of 'result' : " "first part of 'result' " 1 to: (indexOfSubcollection - 1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) ]. " middle part containing replacementCollection : " (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) ]. " end part :" 1 to: (result size - lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). ]. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !ArrayTest methodsFor: 'tests - element accessing'! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) = 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: 'MarcusDenker 8/20/2011 13:42'! testAt "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !ArrayTest methodsFor: 'tests - element accessing'! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !ArrayTest methodsFor: 'tests - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !ArrayTest methodsFor: 'tests - equality'! testEqualSignForSequenceableCollections "self debug: #testEqualSign" self deny: (self nonEmpty = self nonEmpty asSet). self deny: (self nonEmpty reversed = self nonEmpty). self deny: (self nonEmpty = self nonEmpty reversed).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElements "self debug: #testHasEqualElements" self deny: (self empty hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElementsIsTrueForNonIdenticalButEqualCollections "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" self assert: (self empty hasEqualElements: self empty copy). self assert: (self empty copy hasEqualElements: self empty). self assert: (self empty copy hasEqualElements: self empty copy). self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - find binary' stamp: 'SvenVanCaekenberghe 3/8/2012 14:17'! testFindBinary self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 1 - arg ]) = 1. self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 23 - arg ]) = 23. self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ]) = 11. self should: [ #(1 3 5 7 11 15 23) findBinary: [ :arg | 8 - arg ] ] raise: NotFound! ! !ArrayTest methodsFor: 'tests - find binary' stamp: 'SvenVanCaekenberghe 3/8/2012 14:10'! testFindBinaryIfNone self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ] ifNone: [ #none ]) = 11. self should: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 8 - arg ] ifNone: [ #none ]) = #none! ! !ArrayTest methodsFor: 'tests - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: self empty raise: Error. self assert: self empty size = 0. self shouldnt: self nonEmpty raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: self collectionWithElementsToRemove raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: self elementToAdd raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne. self deny: anElement copy == anElement . res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfForMultipliness self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [:i | (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. ]! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualElements ] raise: Error. self collectionWithoutEqualElements do: [:each | self assert: (self collectionWithoutEqualElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureEmptySequenceableTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 11/2/2012 15:57'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ] raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ] raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self collection ] raise: Error. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionOfFloat ] raise: Error. self collectionOfFloat do: [ :each | self assert: each class = Float ]. self shouldnt: [ self elementInForIncludesTest ] raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementInForIncludesTest ] ifNone: [ anElementIn := false ]. self assert: anElementIn = true! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessFotMultipliness self shouldnt: [ self collectionWithSameAtEndAndBegining ] raise: Error. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessTest | res collection element | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. self assert: self collectionMoreThan1NoDuplicates size >1. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. anElement := self elementTwiceInForOccurrences . collection := self collectionWithEqualElements . cpt := 0 . " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ]]. self assert: cpt = 2.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/2/2009 11:53'! test0FixtureOccurrencesTest self shouldnt: self empty raise: Error. self assert: self empty isEmpty. self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForOccurrences raise: Error. self assert: (self nonEmpty includes: self elementInForOccurrences). self shouldnt: self elementNotInForOccurrences raise: Error. self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutOneOrMoreElementsTest self shouldnt: self aValue raise: Error. self shouldnt: self indexArray raise: Error. self indexArray do: [ :each| self assert: each class = SmallInteger. self assert: (each>=1 & each<= self nonEmpty size). ]. self assert: self indexArray size = self valueArray size. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutTest self shouldnt: self aValue raise: Error. self shouldnt: self anotherValue raise: Error. self shouldnt: self anIndex raise: Error. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/14/2009 11:50'! test0FixtureSequencedConcatenationTest self shouldnt: self empty raise: Exception. self assert: self empty isEmpty. self shouldnt: self firstCollection raise: Exception. self shouldnt: self secondCollection raise: Exception! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! test0FixtureTConvertAsSetForMultiplinessTest "a collection ofFloat with equal elements:" | res | self shouldnt: [ self withEqualElements ] raise: Error. self shouldnt: [ self withEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. "a collection of Float without equal elements:" self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] raise: Error. self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self shouldnt: [ self unsortedCollection ]raise: Error. self unsortedCollection do:[:each | each isNumber]. sorted := true. self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false]. ]. self assert: sorted = false. " a collection of number sorted in an ascending order" self shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. self sortedInAscendingOrderCollection do:[:each | each isNumber]. tmp:= self sortedInAscendingOrderCollection at:1. self sortedInAscendingOrderCollection do: [: each | self assert: (each>= tmp). tmp:=each] ! ! !ArrayTest methodsFor: 'tests - fixture'! test0TSequencedStructuralEqualityTest self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! !ArrayTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! testOFixtureReplacementSequencedTest self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForReplacement raise: Error. self assert: (self nonEmpty includes: self elementInForReplacement ) . self shouldnt: self newElement raise: Error. self shouldnt: self firstIndex raise: Error. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self shouldnt: self secondIndex raise: Error. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self shouldnt: self replacementCollection raise: Error. self shouldnt: self replacementCollectionSameSize raise: Error. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !ArrayTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !ArrayTest methodsFor: 'tests - includes'! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOfIAbsent "self debug: #testIdentityIndexOfIfAbsent" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (self collectionOfFloat identityIndexOf: element ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access'! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIdentityIndexOfDuplicate "self debug: #testIdentityIndexOf" | collection element | "testing fixture here as this method may not be used by some collections testClass" self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. collection := self collectionWithNonIdentitySameAtEndAndBegining . self assert: collection first = collection last. self deny: collection first == collection last. 1 to: collection size do: [ :i | i > 1 & (i < collection size) ifTrue: [ self deny: (collection at: i) = collection first ] ]. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIdentityIndexOfIAbsentDuplicate "self debug: #testIdentityIndexOfIfAbsent" | collection element elementCopy | collection := self collectionWithNonIdentitySameAtEndAndBegining . element := collection last. elementCopy := element copy. self deny: element == elementCopy . self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (collection identityIndexOf: elementCopy ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfDuplicate "self debug: #testIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf: should return the position of the first occurrence :'" self assert: (collection indexOf: element) = 1! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent: should return the position of the first occurrence :'" self assert: (collection indexOf: element ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 55 ]) = 1. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 55 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testCollectFromTo | result | result:=self nonEmptyMoreThan1Element collect: [ :each | each ] from: 1 to: (self nonEmptyMoreThan1Element size - 1). 1 to: result size do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseDo | result | result:= OrderedCollection new. self nonEmpty reverseDo: [: each | result add: each]. 1 to: result size do: [:i| self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := firstCollection size. firstCollection reverseWith: secondCollection do: [:a :b | self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. ( index := index - 1).] ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithCollect | result firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. result := firstCollection with: secondCollection collect: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. b]. 1 to: result size do:[: i | self assert: (result at:i)= (secondCollection at: i)]. self assert: result size = secondCollection size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. firstCollection with: secondCollection do: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b.] ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOf | result expected | result := self nonEmpty occurrencesOf: self elementInForOccurrences. expected := 0. self nonEmpty do: [ :each | self elementInForOccurrences = each ifTrue: [ expected := expected + 1 ] ]. self assert: result = expected! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: self elementInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:53'! testOccurrencesOfNotIn | result | result := self empty occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !ArrayTest methodsFor: 'tests - printing'! testPrintElementsOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOnDelimiter | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOnDelimiterLast | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ].! ! !ArrayTest methodsFor: 'tests - printing'! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPutAll | aValueArray | aValueArray := self valueArray . self nonEmpty atAll: self indexArray putAll: aValueArray . 1 to: self indexArray size do: [:i | self assert: (self nonEmpty at:(self indexArray at: i))= (aValueArray at:i) ]! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtLastPut | result index | index := self indexArray anyOne. result := self nonEmpty atLast: index put: self aValue. self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtWrapPut "self debug: #testAtWrapPut" | index | index := self indexArray anyOne. self nonEmpty atWrap: 0 put: self aValue. self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. self assert: (self nonEmpty at:(1))=self aValue. self nonEmpty atWrap: (index ) put: self aValue. self assert: (self nonEmpty at: index ) = self aValue. self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . self assert: (self nonEmpty at:(index ))=self aValue .! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testFromToPut | collection index | index := self indexArray anyOne. collection := self nonEmpty copy. collection from: 1 to: index put: self aValue.. 1 to: index do: [:i | self assert: (collection at: i)= self aValue]. (index +1) to: collection size do: [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: 'Anonymous 5/24/2010 14:30'! testSwapWith "self debug: #testSwapWith" | result index | index := self indexArray anyOne. result:= self nonEmpty copy . result swap: index with: 1. self assert: (result at: index) = (self nonEmpty at:1). self assert: (result at: 1) = (self nonEmpty at: index). ! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceAllWith | result collection oldElement newElement oldOccurrences | collection := self nonEmpty . result := collection copy. oldElement := self elementInForReplacement . newElement := self newElement . oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement). result replaceAll: oldElement with: newElement . self assert: oldOccurrences = (result occurrencesOf: newElement)! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceFromToWith | result collection replacementCollec firstInd secondInd | collection := self nonEmpty . replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . result := collection copy. result replaceFrom: firstInd to: secondInd with: replacementCollec . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( firstInd + replacementCollec size - 1 ) do: [ :i | self assert: ( result at: i ) = ( replacementCollec at: ( i - firstInd +1 ) ) ]. " end part :" ( firstInd + replacementCollec size) to: (result size) do: [:i| self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ]. ! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceFromToWithStartingAt | result repStart collection replacementCollec firstInd secondInd | collection := self nonEmpty . result := collection copy. replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . repStart := replacementCollec size - ( secondInd - firstInd + 1 ) + 1. result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( replacementCollec size - repStart +1 ) do: [:i| self assert: (result at: i)=( replacementCollec at: ( repStart + ( i - firstInd ) ) ) ]. " end part :" ( firstInd + replacementCollec size ) to: ( result size ) do: [ :i | self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ].! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceAbleIfEmptyifNotEmptyDo "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfEmptyifNotEmptyDo "self debug #testSequenceIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmpty self assert: (self nonEmpty ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn ! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDoifNotEmpty self assert: (self nonEmpty ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] ifEmpty: [false])! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyifEmpty self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! !ArrayTest methodsFor: 'tests - set arithmetic'! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !ArrayTest methodsFor: 'tests - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res = separateCol! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSorted self assert: self sortedInAscendingOrderCollection isSorted. self deny: self unsortedCollection isSorted! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !ArrayTest methodsFor: 'tests - sorting'! testSort | result tmp | result := self unsortedCollection sort. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - sorting'! testSortUsingSortBlock | result tmp | result := self unsortedCollection sort: [:a :b | a>b]. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - sorting'! testSorted | result tmp | result := self unsortedCollection sorted. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - sorting'! testSortedUsingBlock | result tmp | result := self unsortedCollection sorted: [:a :b | a>b].. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - subcollections access'! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayTest class uses: TEmptySequenceableTest classTrait + TSequencedElementAccessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TCreationWithTest classTrait + TPutBasicTest classTrait + TConvertTest classTrait + TSortTest classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TReplacementSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TBeginsEndsWith classTrait + TPrintOnSequencedTest classTrait + TIndexAccess classTrait + TSubCollectionAccess classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TIndexAccessForMultipliness classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TConvertAsSortedTest classTrait + TPutTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! SequenceableCollection subclass: #ArrayedCollection uses: TSortable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !ArrayedCollection commentStamp: '' prior: 0! I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.! !ArrayedCollection methodsFor: '*Compression' stamp: 'tk 3/7/2001 18:07'! writeOnGZIPByteStream: aStream "We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream]. "super may cause an error, but will not be called." aStream nextPutAllWordArray: self! ! !ArrayedCollection methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 5/2/2010 20:32'! hexDump "Utility method, for inspecting the native code" ^ String streamContents: [:str | self do: [:each | str nextPutAll: (each printStringBase: 16) ] separatedBy: [ str space ] ]! ! !ArrayedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:36'! size "Answer how many elements the receiver contains." ^ self basicSize! ! !ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'! add: newObject self shouldNotImplement! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'! byteSize ^self basicSize * self bytesPerBasicElement ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'! bytesPerBasicElement "Answer the number of bytes that each of my basic elements requires. In other words: self basicSize * self bytesPerBasicElement should equal the space required on disk by my variable sized representation." ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'CamilloBruni 11/2/2012 14:26'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^self]. Smalltalk isLittleEndian ifTrue: [Bitmap swapBytesIn: self from: 1 to: self basicSize]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'CamilloBruni 11/2/2012 14:26'! swapHalves "A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word. This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc." | hack blt | "The implementation is a hack, but fast for large ranges" hack := Form new hackBits: self. blt := (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 2. blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3" blt sourceX: 2; destX: 0; copyBits. blt sourceX: 0; destX: 2; copyBits. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'jb 4/30/2010 17:26'! writeOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds. We only intend this for non-pointer arrays. Do nothing if I contain pointers." (self class isPointers or: [ self class isWords not ]) ifTrue: [^ self ]. aStream nextInt32Put: self basicSize. aStream nextWordsPutAll: self.! ! !ArrayedCollection methodsFor: 'printing'! storeOn: aStream 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: 'removing' stamp: 'klub 9/14/2009 16:27'! removeAll self shouldNotImplement! ! !ArrayedCollection methodsFor: 'sorting'! isSorted "Return true if the receiver is sorted by the given criterion. Optimization for isSortedBy: [:a :b | a <= b]." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm := self first. 2 to: self size do: [:index | elm := self at: index. lastElm <= elm ifFalse: [^ false]. lastElm := elm]. ^ true! ! !ArrayedCollection methodsFor: 'sorting'! isSortedBy: aBlock "Return true if the receiver is sorted by the given criterion." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm := self first. 2 to: self size do: [:index | elm := self at: index. (aBlock value: lastElm value: elm) ifFalse: [^ false]. lastElm := elm]. ^ true! ! !ArrayedCollection methodsFor: 'sorting'! mergeFirst: first middle: middle last: last into: dst by: aBlock "Private. Merge the sorted ranges [first..middle] and [middle+1..last] of the receiver into the range [first..last] of dst." | i1 i2 val1 val2 out | i1 := first. i2 := middle + 1. val1 := self at: i1. val2 := self at: i2. out := first - 1. "will be pre-incremented" "select 'lower' half of the elements based on comparator" [(i1 <= middle) and: [i2 <= last]] whileTrue: [(aBlock value: val1 value: val2) ifTrue: [dst at: (out := out + 1) put: val1. val1 := self at: (i1 := i1 + 1)] ifFalse: [dst at: (out := out + 1) put: val2. i2 := i2 + 1. i2 <= last ifTrue: [val2 := self at: i2]]]. "copy the remaining elements" i1 <= middle ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1] ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! ! !ArrayedCollection methodsFor: 'sorting'! mergeSortFrom: startIndex to: stopIndex by: aBlock "Sort the given range of indices using the mergesort algorithm. Mergesort is a worst-case O(N log N) sorting algorithm that usually does only half as many comparisons as heapsort or quicksort." "Details: recursively split the range to be sorted into two halves, mergesort each half, then merge the two halves together. An extra copy of the data is used as temporary storage and successive merge phases copy data back and forth between the receiver and this copy. The recursion is set up so that the final merge is performed into the receiver, resulting in the receiver being completely sorted." self size <= 1 ifTrue: [^ self]. "nothing to do" startIndex = stopIndex ifTrue: [^ self]. [startIndex >= 1 and: [startIndex < stopIndex]] assert. "bad start index" [stopIndex <= self size] assert. "bad stop index" self mergeSortFrom: startIndex to: stopIndex src: self copy dst: self by: aBlock! ! !ArrayedCollection methodsFor: 'sorting'! mergeSortFrom: first to: last src: src dst: dst by: aBlock "Private. Split the range to be sorted in half, sort each half, and merge the two half-ranges into dst." | middle | first = last ifTrue: [^ self]. middle := (first + last) // 2. self mergeSortFrom: first to: middle src: dst dst: src by: aBlock. self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock. src mergeFirst: first middle: middle last: last into: dst by: aBlock! ! !ArrayedCollection methodsFor: 'sorting'! sort "Sort this collection into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !ArrayedCollection methodsFor: 'sorting'! sort: aSortBlock "Sort this array using aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." self mergeSortFrom: 1 to: self size by: aSortBlock! ! !ArrayedCollection methodsFor: 'private'! defaultElement ^nil! ! !ArrayedCollection methodsFor: 'private' stamp: 'ul 11/21/2009 01:15'! fillFrom: aCollection with: aBlock "Evaluate aBlock with each of aCollections's elements as the argument. Collect the resulting values into self. Answer self." | index | index := 0. aCollection do: [ :each | self at: (index := index + 1) put: (aBlock value: each) ]! ! !ArrayedCollection methodsFor: 'private'! storeElementsFrom: firstIndex to: lastIndex on: aStream | 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 uses: TSortable classTrait instanceVariableNames: ''! !ArrayedCollection class methodsFor: 'instance creation'! new "Answer a new instance of me, with size = 0." ^self new: 0! ! !ArrayedCollection class methodsFor: 'instance creation'! new: size withAll: value "Answer an instance of me, with number of elements equal to size, each of which refers to the argument, value." ^(self new: size) atAllPut: value! ! !ArrayedCollection class methodsFor: 'instance creation'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newArray | newArray := self new: aCollection size. 1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)]. ^ newArray " Array newFrom: {1. 2. 3} {1. 2. 3} as: Array {1. 2. 3} as: ByteArray {$c. $h. $r} as: String {$c. $h. $r} as: Text "! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 10/30/2011 15:53'! newFromStream: s "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." | len | (self isPointers not & self isWords) ifFalse: [ self error: 'This method is only meant for raw bits and word-like subclasses ']. s next = 16r80 ifTrue: ["A compressed format. Could copy what BitMap does, or use a special sound compression format. Callers normally compress their own way." ^ self error: 'not implemented']. s skip: -1. len := s nextInt32. ^ s nextWordsInto: (self basicNew: len)! ! !ArrayedCollection class methodsFor: 'instance creation'! with: anObject "Answer a new instance of me, containing only anObject." | newCollection | newCollection := self new: 1. newCollection at: 1 put: anObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject "Answer a new instance of me, containing firstObject and secondObject." | newCollection | newCollection := self new: 2. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject "Answer a new instance of me, containing only the three arguments as elements." | newCollection | newCollection := self new: 3. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer a new instance of me, containing only the three arguments as 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! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject "Answer a new instance of me, containing only the five arguments as elements." | newCollection | newCollection := self new: 5. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sw 10/24/1998 22:22'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject "Answer a new instance of me, containing only the 6 arguments as elements." | newCollection | newCollection := self new: 6. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. newCollection at: 6 put: sixthObject. ^ newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:37'! withAll: aCollection "Create a new collection containing all the elements from aCollection." ^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! ! Halt subclass: #AssertionFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! ParseNode subclass: #AssignmentNode instanceVariableNames: 'variable value' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !AssignmentNode commentStamp: '' prior: 0! AssignmentNode comment: 'I represent a (var_expr) construct.'! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:27'! emitCodeForEffect: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStorePop: stack encoder: encoder! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:27'! emitCodeForValue: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStore: stack encoder: encoder! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:16'! sizeCodeForEffect: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStorePop: encoder)! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:16'! sizeCodeForValue: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStore: encoder)! ! !AssignmentNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 09:37'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" "N.B. since assigment happens _after_ the value is evaluated the value is sent the message _first_." value analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools. variable beingAssignedToAnalyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools! ! !AssignmentNode methodsFor: 'equation translation'! variable ^variable! ! !AssignmentNode methodsFor: 'initialize-release'! toDoIncrement: var var = variable ifFalse: [^ nil]. (value isMemberOf: MessageNode) ifTrue: [^ value toDoIncrement: var] ifFalse: [^ nil]! ! !AssignmentNode methodsFor: 'initialize-release'! value ^ value! ! !AssignmentNode methodsFor: 'initialize-release'! variable: aVariable value: expression variable := aVariable. value := expression! ! !AssignmentNode methodsFor: 'initialize-release' stamp: 'di 3/22/1999 12:00'! variable: aVariable value: expression from: encoder (aVariable isMemberOf: MessageAsTempNode) ifTrue: ["Case of remote temp vars" ^ aVariable store: expression from: encoder]. variable := aVariable. value := expression! ! !AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'! variable: aVariable value: expression from: encoder sourceRange: range encoder noteSourceRange: range forNode: self. ^self variable: aVariable value: expression from: encoder! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:48'! printOn: aStream indent: level variable printOn: aStream indent: level. aStream nextPutAll: ' := '. value printOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 5/9/2008 18:44'! printOn: aStream indent: level precedence: p aStream nextPut: $(. self printOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level variable printWithClosureAnalysisOn: aStream indent: level. aStream nextPutAll: ' := '. value printWithClosureAnalysisOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level precedence: p aStream nextPut: $(. self printWithClosureAnalysisOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! isAssignmentNode ^true! ! !AssignmentNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitAssignmentNode: self! ! LookupKey subclass: #Association instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !Association commentStamp: 'StephaneDucasse 2/13/2010 15:13' prior: 0! I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary. Implementation notes: Note that hash is not redefined even if the = was redefined because Association>>hash may cause extreme slowdowns in compiling Unicode methods. Association>>hash does not need to hash the value; it's slow and useless. ! !Association methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/24/2009 23:20'! settingFixedDomainValueNodeFrom: aSettingNode ^ aSettingNode fixedDomainValueNodeForAssociation: self! ! !Association methodsFor: 'accessing'! key: aKey value: anObject "Store the arguments as the variables of the receiver." key := aKey. value := anObject! ! !Association methodsFor: 'accessing'! value "Answer the value of the receiver." ^value! ! !Association methodsFor: 'accessing'! value: anObject "Store the argument, anObject, as the value of the receiver." value := anObject! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'! = anAssociation ^ super = anAssociation and: [value = anAssociation value]! ! !Association methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: '->'. value printOn: aStream! ! !Association methodsFor: 'printing'! storeOn: aStream "Store in the format (key->value)" aStream nextPut: $(. key storeOn: aStream. aStream nextPutAll: '->'. value storeOn: aStream. aStream nextPut: $)! ! !Association methodsFor: 'self evaluating' stamp: 'nice 10/30/2009 20:24'! isSelfEvaluating ^ self class == Association and: [self key isSelfEvaluating and: [self value isSelfEvaluating]]! ! !Association methodsFor: 'testing' stamp: 'nice 7/20/2011 09:00'! literalEqual: otherLiteral "Answer true if the receiver and otherLiteral represent the same literal. Variable bindings are literally equals only if identical. This is how variable sharing works, by preserving identity and changing only the value." ^self == otherLiteral! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Association class instanceVariableNames: ''! !Association class methodsFor: 'instance creation'! key: newKey value: newValue "Answer an instance of me with the arguments as the key and value of the association." ^(super key: newKey) value: newValue! ! ClassTestCase subclass: #AssociationTest instanceVariableNames: 'a b' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Support'! !AssociationTest methodsFor: 'setup' stamp: 'zz 12/5/2005 18:33'! setUp a := 1 -> 'one'. b := 1 -> 'een'.! ! !AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 07:59'! testComparison self assert: ((#a -> 'foo') < (#b -> 'zork'))! ! !AssociationTest methodsFor: 'tests' stamp: 'md 3/8/2004 16:37'! testEquality self assert: (a key = b key); deny: (a value = b value); deny: (a = b) ! ! !AssociationTest methodsFor: 'tests' stamp: 'al 10/13/2008 20:32'! testHash self assert: (a hash = a copy hash); assert: (a hash = b hash)! ! !AssociationTest methodsFor: 'tests' stamp: 'jb 7/1/2011 10:40'! testIsSelfEvaluating | anotherAssociation | self assert: (a isSelfEvaluating). self assert: (a printString = '1->''one'''). anotherAssociation := Object new -> Object new. anotherAssociation isSelfEvaluating ifTrue: [self assert: (self class evaluatorClass evaluate: anotherAssociation printString) = anotherAssociation description: 'a self evaluating should evaluate as self']. ! ! Object subclass: #AsyncFile instanceVariableNames: 'name writeable semaphore fileHandle' classVariableNames: 'Busy ErrorCode' poolDictionaries: '' category: 'Files-Kernel'! !AsyncFile commentStamp: 'HenrikSperreJohansen 2/16/2012 11:40' prior: 0! An asynchronous file allows simple file read and write operations to be performed in parallel with other processing. This is useful in multimedia applications that need to stream large amounts of sound or image data from or to a file while doing other work. Closing the file after its use is currently required to not leak external semaphores. ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! close fileHandle ifNil: [^ self]. "already closed" self primClose: fileHandle. Smalltalk unregisterExternalObject: semaphore. semaphore := nil. fileHandle := nil. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! fileHandle ^ fileHandle! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'ar 6/3/2007 22:13'! open: fullFileName forWrite: aBoolean "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise. If openForWrite is true, then: if there is no existing file with this name, then create one else open the existing file in read-write mode otherwise: if there is an existing file with this name, then open it read-only else answer nil." "Note: if an exisiting file is opened for writing, it is NOT truncated. If truncation is desired, the file should be deleted before being opened as an asynchronous file." "Note: On some platforms (e.g., Mac), a file can only have one writer at a time." | semaIndex | name := fullFileName. writeable := aBoolean. semaphore := Semaphore new. semaIndex := Smalltalk registerExternalObject: semaphore. fileHandle := self primOpen: name asVmPathName forWrite: writeable semaIndex: semaIndex. fileHandle ifNil: [ Smalltalk unregisterExternalObject: semaphore. semaphore := nil. ^ nil]. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! readByteCount: byteCount fromFilePosition: fPosition onCompletionDo: aBlock "Start a read operation to read byteCount's from the given position in this file. and fork a process to await its completion. When the operation completes, evaluate the given block. Note that, since the completion block may run asynchronous, the client may need to use a SharedQueue or a semaphore for synchronization." | buffer | buffer := String new: byteCount. self primReadStart: fileHandle fPosition: fPosition count: byteCount. "here's the process that awaits the results:" [| n | [ semaphore wait. n := self primReadResult: fileHandle intoBuffer: buffer at: 1 count: byteCount. n = Busy. ] whileTrue. "loop while busy in case the semaphore had excess signals" n = ErrorCode ifTrue: [^ self error: 'asynchronous read operation failed']. aBlock value: buffer. ] forkAt: Processor userInterruptPriority. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 5/4/2012 21:16'! test: byteCount fileName: fileName "AsyncFile new test: 10000 fileName: 'testData'" | buf1 buf2 bytesWritten bytesRead | buf1 := String new: byteCount withAll: $x. buf2 := String new: byteCount. self open: fileName asFileReference fullName forWrite: true. self primWriteStart: fileHandle fPosition: 0 fromBuffer: buf1 at: 1 count: byteCount. semaphore wait. bytesWritten := self primWriteResult: fileHandle. self close. self open: fileName asFileReference fullName forWrite: false. self primReadStart: fileHandle fPosition: 0 count: byteCount. semaphore wait. bytesRead := self primReadResult: fileHandle intoBuffer: buf2 at: 1 count: byteCount. self close. buf1 = buf2 ifFalse: [self error: 'buffers do not match']. ^ 'wrote ', bytesWritten printString, ' bytes; ', 'read ', bytesRead printString, ' bytes' ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! waitForCompletion semaphore wait! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! writeBuffer: buffer atFilePosition: fPosition onCompletionDo: aBlock "Start an operation to write the contents of the buffer at given position in this file, and fork a process to await its completion. When the write completes, evaluate the given block. Note that, since the completion block runs asynchronously, the client may need to use a SharedQueue or a semaphore for synchronization." self primWriteStart: fileHandle fPosition: fPosition fromBuffer: buffer at: 1 count: buffer size. "here's the process that awaits the results:" [| n | [ semaphore wait. n := self primWriteResult: fileHandle. n = Busy. ] whileTrue. "loop while busy in case the semaphore had excess signals" n = ErrorCode ifTrue: [^ self error: 'asynchronous write operation failed']. n = buffer size ifFalse: [^ self error: 'did not write the entire buffer']. aBlock value. ] forkAt: Processor userInterruptPriority. ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primClose: fHandle "Close this file. Do nothing if primitive fails." ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primOpen: fileName forWrite: openForWrite semaIndex: semaIndex "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise." ^ nil ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primReadResult: fHandle intoBuffer: buffer at: startIndex count: count "Copy the result of the last read operation into the given buffer starting at the given index. The buffer may be any sort of bytes or words object, excluding CompiledMethods. Answer the number of bytes read. A negative result means: -1 the last operation is still in progress -2 the last operation encountered an error" self primitiveFailed ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primReadStart: fHandle fPosition: fPosition count: count "Start a read operation of count bytes starting at the given offset in the given file." self error: 'READ THE COMMENT FOR THIS METHOD.' "NOTE: This method will fail if there is insufficient C heap to allocate an internal buffer of the required size (the value of count). If you are trying to read a movie file, then the buffer size will be height*width*2 bytes. Each Squeak image retains a value to be used for this allocation, and it it initially set to 0. If you are wish to play a 640x480 movie, you need room for a buffer of 640*480*2 = 614400 bytes. You should execute the following... Smalltalk extraVMMemory 2555000. Then save-and-quit, restart, and try to open the movie file again. If you are using Async files in another way, find out the value of count when this failure occurs (call it NNNN), and instead of the above, execute... Smalltalk extraVMMemory: Smalltalk extraVMMemory + NNNN then save-and-quit, restart, and try again. " ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primWriteResult: fHandle "Answer the number of bytes written. A negative result means: -1 the last operation is still in progress -2 the last operation encountered an error" self primitiveFailed ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: startIndex count: count "Start a write operation of count bytes starting at the given index in the given buffer. The buffer may be any sort of bytes or words object, excluding CompiledMethods. The contents of the buffer are copied into an internal buffer immediately, so the buffer can be reused after the write operation has been started. Fail if there is insufficient C heap to allocate an internal buffer of the requested size." writeable ifFalse: [^ self error: 'attempt to write a file opened read-only']. self primitiveFailed ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AsyncFile class instanceVariableNames: ''! !AsyncFile class methodsFor: 'initialization' stamp: 'bootstrap 5/31/2006 20:45'! initialize "AsyncFile initialize" "Possible abnormal I/O completion results." Busy := -1. ErrorCode := -2. ! ! Object subclass: #AtomicCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Atomic'! !AtomicCollection commentStamp: 'Igor.Stasenko 10/16/2010 03:54' prior: 0! I am just a base abstract class, containing common behavior for various queue types! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:09'! copy ^ self errorDontCopy! ! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:09'! deepCopy ^ self errorDontCopy! ! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:11'! errorDontCopy "copying a structure, involved in concurrent operations is a bad idea" ^ self error: 'Copying not available'! ! !AtomicCollection methodsFor: 'debug support' stamp: 'Igor.Stasenko 10/15/2010 17:30'! interrupt "simulate interrupt , for debugging purposes only" Processor yield! ! !AtomicCollection methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 03:54'! signalAddedNewItem "Optional, override in subclass(es) to signal that new item available in queue. Default implementation does nothing"! ! !AtomicCollection methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 03:54'! signalNoMoreItems "Optional, override in subclass(es) to signal that queue is currently empty. Default implementation does nothing"! ! !AtomicCollection methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 03:54'! waitForNewItems "Override in subclass. By default, yield current process. If you run more than one process, which popping items from queue, then there is no guarantee, that after wait, #next won't block the queue" ^ self yield! ! !AtomicCollection methodsFor: 'utils' stamp: 'IgorStasenko 2/28/2011 15:58'! newItem "override in subclass, if you need to instantiate queue items of different class or initialize them in some specific way" ^ AtomicQueueItem new! ! !AtomicCollection methodsFor: 'yielding' stamp: 'Igor.Stasenko 10/15/2010 17:30'! yield "Yield the current process. Used internally by spin loops, once detected that current process can't make any progress without some external event to happen" Processor yield! ! Object subclass: #AtomicQueueItem instanceVariableNames: 'next object' classVariableNames: '' poolDictionaries: '' category: 'Collections-Atomic'! !AtomicQueueItem commentStamp: 'Igor.Stasenko 10/16/2010 02:29' prior: 0! i am a queue item , used by atomic queues. All my new instances are circular i.e. next=self! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 17:45'! isCircular ^ next == self! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 17:45'! makeCircular "Make a receiver circular, i.e. point to itself, answer the old value of next variable. Note, this operation should be atomic" | temp | " atomic swap here" temp := next. next := self. ^ temp! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! next "Answer the value of next" ^ next! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! next: anObject "Set the value of next" next := anObject! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! object "Answer the value of object" ^ object! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! object: anObject "Set the value of object" object := anObject! ! !AtomicQueueItem methodsFor: 'initialize-release' stamp: 'IgorStasenko 2/28/2011 16:00'! initialize "make circular" super initialize. next := self.! ! WaitfreeQueue subclass: #AtomicSharedQueue instanceVariableNames: 'availSema' classVariableNames: '' poolDictionaries: '' category: 'Collections-Atomic'! !AtomicSharedQueue commentStamp: 'IgorStasenko 2/28/2011 15:33' prior: 0! I am using semaphore to signal/wait for new items available in queue I am introducing extra protocol - #next, which blocks the sender until it can successfully fetch next item from queue. ! !AtomicSharedQueue methodsFor: 'accessing' stamp: 'IgorStasenko 2/28/2011 15:20'! next "Fetch the next item from queue. If queue is locked or empty, block the sender until operation can complete" | result | [ | keepWaiting | keepWaiting := false. result := self nextIfNone: [ keepWaiting := true ]. keepWaiting ] whileTrue: [ self waitForNewItems ]. ^ result! ! !AtomicSharedQueue methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 10/15/2010 16:59'! initialize super initialize. availSema := Semaphore new. ! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/15/2010 17:00'! signalAddedNewItem availSema signal! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 01:45'! signalNoMoreItems "queue is empty, reset sema signals" availSema initSignals ! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/15/2010 17:00'! waitForNewItems availSema wait! ! ComposableModel subclass: #Authentifier instanceVariableNames: 'gmail passwordField passwordLabel result userField userLabel' classVariableNames: '' poolDictionaries: '' category: 'CI-Core-SliceSubmitter'! !Authentifier commentStamp: '' prior: 0! An Authentifier is a UI made for specifying username and password! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! gmail ^ gmail! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! passwordField ^ passwordField! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! passwordLabel ^ passwordLabel! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! userField ^ userField! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! userLabel ^ userLabel! ! !Authentifier methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/10/2013 14:43'! initializeDialogWindow: aWindow aWindow okAction: [ | user password | user := userField getText. password := passwordField getText. (user isEmpty or: [ password isEmpty ]) ifFalse: [ result contents: (user -> password) ]]. aWindow toolbar okButton keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut. aWindow toolbar cancelButton keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut. self focusOrder add: userField; add: passwordField; add: aWindow toolbar.! ! !Authentifier methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/10/2013 14:43'! initializeWidgets self instantiateModels: #( userLabel LabelModel userField TextInputFieldModel gmail LabelModel passwordLabel LabelModel passwordField TextInputFieldModel ). userLabel text: 'Username:'. userField entryCompletion: nil; autoAccept: true; keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut; ghostText: 'username'. gmail text: '@gmail.com'. passwordLabel text: 'Password:'. passwordField autoAccept: true; acceptOnCR: true; ghostText: 'password'; entryCompletion: nil; keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut; beEncrypted.! ! !Authentifier methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/4/2012 15:05'! initialize "Initialization code for Authentifier" super initialize. result := nil asValueHolder.! ! !Authentifier methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:00'! initialExtent ^ (400@180)! ! !Authentifier methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:04'! result ^ result contents! ! !Authentifier methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:51'! title ^ 'Enter username and password'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Authentifier class instanceVariableNames: ''! !Authentifier class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! spec ^ SpecLayout composed add: #userLabel origin: 0@0 corner: 0@0 offsetOrigin: 0@0 offsetCorner: 200@25; add: #userField origin: 0@0 corner: 0@0 offsetOrigin: 0@25 offsetCorner: 300@50; add: #gmail origin: 0@0 corner: 0@0 offsetOrigin: 300@25 offsetCorner: 400@50; add: #passwordLabel origin: 0@0 corner: 0@0 offsetOrigin: 0@50 offsetCorner: 200@75; add: #passwordField origin: 0@0 corner: 0@0 offsetOrigin: 0@75 offsetCorner: 300@100; yourself! ! Object subclass: #Author instanceVariableNames: 'fullName' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Author commentStamp: 'MiguelCoba 7/25/2009 01:09' prior: 0! I am responsible for the full name used to identify the current code author.! !Author methodsFor: 'accessing' stamp: 'Lr 12/9/2010 17:34'! checkAndSetFullNameWith: aString | s allowed | aString ifNil: [^self]. s := ''. allowed := ($A to: $Z) , ($a to: $z) , ($0 to: $9). aString do: [:c | (allowed includes: c) ifTrue: [s := s , c asString]]. self fullName: s! ! !Author methodsFor: 'accessing'! fullName "Answer the full name to be used to identify the current code author." [fullName isEmptyOrNil] whileTrue: [ self requestFullName. (fullName isNil or:[fullName = 'FirstnameLastname' translated]) ifTrue: [fullName := nil. ^'Anonymous']]. ^ fullName! ! !Author methodsFor: 'accessing' stamp: 'PavelKrivanek 2/8/2013 12:05'! fullName: aString fullName := aString. Smalltalk globals at: #UsersManager ifPresent: [:usersManager | usersManager default currentUser setUserName: aString forGroup: #author].! ! !Author methodsFor: 'accessing' stamp: 'PavelKrivanek 2/8/2013 12:05'! fullNamePerSe "Answer the currently-prevailing author full name, such as it is, empty or not" ^ Smalltalk globals at: #UsersManager ifPresent: [:usersManager | usersManager default currentUser userNameFor: #author] ifAbsent: [ fullName ] ! ! !Author methodsFor: 'compatibility'! ifUnknownAuthorUse: aString during: aBlock "If no author is set use the name aString while executing aBlock." "for compatibility with 1.0" | previous | fullName isEmptyOrNil ifFalse: [ ^ aBlock value ]. fullName := aString. ^ aBlock ensure: [ self reset ]! ! !Author methodsFor: 'compatibility'! reset fullName := ''! ! !Author methodsFor: 'initialization'! initialize super initialize. fullName := ''.! ! !Author methodsFor: 'testing-support'! useAuthor: aString during: aBlock | previous | previous := fullName. fullName := aString. ^ aBlock ensure: [ fullName := previous ]! ! !Author methodsFor: 'ui-requests' stamp: 'CamilloBruni 10/20/2012 21:04'! requestFullName | initialAnswer | initialAnswer := fullName isEmptyOrNil ifTrue: ['FirstnameLastname' translated] ifFalse: [fullName]. self checkAndSetFullNameWith: (AuthorNameRequest new initialAnswer: initialAnswer) signal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Author class instanceVariableNames: 'uniqueInstance'! !Author class methodsFor: 'convenience'! fullName ^ Author uniqueInstance fullName! ! !Author class methodsFor: 'convenience'! fullName: aString ^ Author uniqueInstance checkAndSetFullNameWith: aString! ! !Author class methodsFor: 'convenience'! fullNamePerSe ^ Author uniqueInstance fullNamePerSe! ! !Author class methodsFor: 'convenience'! requestFullName ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'instance creation'! new self error: 'Author is a singleton -- send uniqueInstance instead'! ! !Author class methodsFor: 'instance creation'! reset ^ uniqueInstance := nil! ! !Author class methodsFor: 'instance creation'! uniqueInstance ^ uniqueInstance ifNil: [ uniqueInstance := super new ]! ! !Author class methodsFor: 'instance creation'! uniqueInstance: anInstance "Needed by AuthorTest to restore saved instance" ^ uniqueInstance := anInstance! ! !Author class methodsFor: 'testing-support'! useAuthor: aString during: aBlock ^ self uniqueInstance useAuthor: aString during: aBlock! ! !Author class methodsFor: 'utilities'! changeStamp "Answer a string to be pasted into source code to mark who changed it and when." ^ Author fullName , ' ' , Date today mmddyyyy, ' ', ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! !Author class methodsFor: 'utilities'! changeStampPerSe "Answer a string to be pasted into source code to mark who changed it and when." ^ (Author fullNamePerSe ifNil: ['.']) , ' ' , Date today mmddyyyy, ' ', ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! !Author class methodsFor: 'utilities'! fixStamp: changeStamp | parts | parts := changeStamp findTokens: ' '. (parts size > 0 and: [parts last first isLetter]) ifTrue: ["Put initials first in all time stamps..." ^ String streamContents: [:s | s nextPutAll: parts last. parts allButLast do: [:p | s space; nextPutAll: p]]]. ^ changeStamp! ! Notification subclass: #AuthorNameRequest instanceVariableNames: 'initialAnswer' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !AuthorNameRequest commentStamp: '' prior: 0! I am used to request a new author name.! !AuthorNameRequest methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 21:03'! initialAnswer ^ initialAnswer! ! !AuthorNameRequest methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 21:03'! initialAnswer: anObject initialAnswer := anObject! ! !AuthorNameRequest methodsFor: 'exception handling' stamp: 'CamilloBruni 10/20/2012 21:03'! defaultAction ^ UIManager default request: self messagePrompt initialAnswer: initialAnswer title: 'Author identification' translated! ! !AuthorNameRequest methodsFor: 'ui-requests' stamp: 'CamilloBruni 10/22/2012 23:21'! messagePrompt ^ self class messagePrompt! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AuthorNameRequest class instanceVariableNames: ''! !AuthorNameRequest class methodsFor: 'accessing' stamp: 'CamilloBruni 10/22/2012 23:21'! messagePrompt ^ 'Please type your full name. It will be used to sign the changes you make to the image. Spaces, accents, dashes, underscore and similar characters are not allowed '! ! TestCase subclass: #AuthorTest instanceVariableNames: 'author' classVariableNames: '' poolDictionaries: '' category: 'Tests-System'! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:31'! setUp author := Author uniqueInstance. Author reset.! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:21'! tearDown Author uniqueInstance: author! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:35'! testUniqueness self should: [ Author new ] raise: Error.! ! Object subclass: #Authorizer instanceVariableNames: 'users realm' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !Authorizer commentStamp: '' prior: 0! The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method. ! !Authorizer methodsFor: 'authentication' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! encode: nameString password: pwdString "Encode per RFC1421 of the username:password combination." | clear code clearSize idx map | clear := (nameString, ':', pwdString) asByteArray. clearSize := clear size. [ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ]. idx := 1. map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'. code := String new writeStream. [ idx < clear size ] whileTrue: [ code nextPut: (map at: (clear at: idx) // 4 + 1); nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1); nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1); nextPut: (map at: (clear at: idx + 2) \\ 64 + 1). idx := idx + 3 ]. code := code contents. idx := code size. clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1]. ^code! ! !Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'! mapFrom: aKey to: aPerson "Establish a mapping from a RFC 1421 key to a user." users isNil ifTrue: [ users := Dictionary new ]. aPerson isNil ifTrue: [ users removeKey: aKey ] ifFalse: [ users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: []. users at: aKey put: aPerson ] ! ! !Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'! mapName: nameString password: pwdString to: aPerson "Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap. DO NOT call this directly, use mapName:password:to: in your ServerAction class. Only it knows how to record the change on the disk!!" self mapFrom: (self encode: nameString password: pwdString) to: aPerson ! ! !Authorizer methodsFor: 'authentication' stamp: 'ar 8/17/2001 18:19'! user: userId "Return the requesting user." ^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm ^realm! ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm: aString realm := aString ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Authorizer class instanceVariableNames: ''! !Authorizer class methodsFor: 'as yet unclassified' stamp: 'adrian_lienhard 7/18/2009 15:52'! unauthorizedFor: realm ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Pharo/',realm,'"', String crlfcrlf, 'Unauthorized

Unauthorized for ',realm, '

' ! ! TotalCost subclass: #AverageCost instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !AverageCost commentStamp: 'StephaneDucasse 6/9/2010 20:53' prior: 0! Part of an test resource to verify that super is well bound. See CompilerEvaluationTest! !AverageCost methodsFor: 'as yet unclassified' stamp: 'NikoSchwarz 6/5/2010 16:11'! total ^super total / 12! ! ImageReadWriter subclass: #BMPReadWriter instanceVariableNames: 'bfType bfSize bfOffBits biSize biWidth biHeight biPlanes biBitCount biCompression biSizeImage biXPelsPerMeter biYPelsPerMeter biClrUsed biClrImportant' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !BMPReadWriter commentStamp: 'LaurentLaffont 5/4/2011 21:27' prior: 0! I read and write BMP files. Example to save and load a screenshot of the world in a .bmp file: BMPReadWriter putForm: (Form fromDisplay: (0@0 corner: 400@400)) onFileNamed: '/tmp/screenshot.bmp'. (ImageMorph withForm: (BMPReadWriter formFromFileNamed: '/tmp/screenshot.bmp')) openInWindow.! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'! nextImage | colors | stream binary. self readHeader. biBitCount = 24 ifTrue:[^self read24BmpFile]. "read the color map" colors := self readColorMap. ^self readIndexedBmpFile: colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! read24BmpFile "Read 24-bit pixel data from the given a BMP stream." | form formBits pixelLine bitsIndex bitBlt | form := Form extent: biWidth @ biHeight depth: 32. pixelLine := ByteArray new: (24 * biWidth + 31) // 32 * 4. bitsIndex := (form height - 1) * biWidth + 1. formBits := form bits. 1 to: biHeight do: [ :i | pixelLine := stream nextInto: pixelLine. self read24BmpLine: pixelLine into: formBits startingAt: bitsIndex width: biWidth. bitsIndex := bitsIndex - biWidth ]. bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: 4278190080). bitBlt copyBits. ^ form! ! !BMPReadWriter methodsFor: 'reading' stamp: 'StephaneDucasse 12/22/2010 16:08'! read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width "Swizzles the bytes in a 24bpp scanline and fills in the given 32bpp form bits. Ensures that color black is represented as 16rFF000001 so that Form paint works properly." | pixIndex rgb bitsIndex | pixIndex := 0. "pre-increment" bitsIndex := formBitsIndex-1. "pre-increment" 1 to: width do: [:j | rgb := (pixelLine at: (pixIndex := pixIndex+1)) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 8) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 16). rgb = 0 ifTrue:[rgb := 16rFF000001] ifFalse:[rgb := rgb + 16rFF000000]. formBits at: (bitsIndex := bitsIndex+1) put: rgb]. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! readColorMap "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." | colorCount colors maxLevel b g r ccStream | colorCount := (bfOffBits - 54) // 4. "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" biBitCount >= 16 ifTrue: [ ^ nil ]. colorCount = 0 ifTrue: [ "this BMP file does not have a color map" "default monochrome color map" biBitCount = 1 ifTrue: [ ^ Array with: Color white with: Color black ]. "default gray-scale color map" maxLevel := (2 raisedTo: biBitCount) - 1. ^ (0 to: maxLevel) collect: [ :level | Color gray: level asFloat / maxLevel ] ]. ccStream := (stream next: colorCount * 4) readStream. colors := Array new: colorCount. 1 to: colorCount do: [ :i | b := ccStream next. g := ccStream next. r := ccStream next. ccStream next. "skip reserved" colors at: i put: (Color r: r g: g b: b range: 255) ]. ^ colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readHeader | reserved | bfType := stream nextLittleEndianNumber: 2. bfSize := stream nextLittleEndianNumber: 4. reserved := stream nextLittleEndianNumber: 4. bfOffBits := stream nextLittleEndianNumber: 4. biSize := stream nextLittleEndianNumber: 4. biWidth := stream nextLittleEndianNumber: 4. biHeight := stream nextLittleEndianNumber: 4. biPlanes := stream nextLittleEndianNumber: 2. biBitCount := stream nextLittleEndianNumber: 2. biCompression := stream nextLittleEndianNumber: 4. biSizeImage := stream nextLittleEndianNumber: 4. biXPelsPerMeter := stream nextLittleEndianNumber: 4. biYPelsPerMeter := stream nextLittleEndianNumber: 4. biClrUsed := stream nextLittleEndianNumber: 4. biClrImportant := stream nextLittleEndianNumber: 4! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readIndexedBmpFile: colors "Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16" | form bytesPerRow pixelData pixelLine startIndex map bitBlt mask | colors ifNil: [ form := Form extent: biWidth @ biHeight depth: biBitCount ] ifNotNil: [ form := ColorForm extent: biWidth @ biHeight depth: biBitCount. form colors: colors ]. bytesPerRow := (biBitCount * biWidth + 31) // 32 * 4. pixelData := ByteArray new: bytesPerRow * biHeight. biHeight to: 1 by: -1 do: [ :y | pixelLine := stream next: bytesPerRow. startIndex := (y - 1) * bytesPerRow + 1. pixelData replaceFrom: startIndex to: startIndex + bytesPerRow - 1 with: pixelLine startingAt: 1 ]. form bits copyFromByteArray: pixelData. biBitCount = 16 ifTrue: [ map := ColorMap shifts: #(8 -8 0 0 ) masks: #(255 65280 0 0 ). mask := 2147516416 ]. biBitCount = 32 ifTrue: [ map := ColorMap shifts: #(24 8 -8 -24 ) masks: #(255 65280 16711680 4278190080 ). mask := 4278190080 ]. map ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt sourceForm: form. bitBlt colorMap: map. bitBlt combinationRule: Form over. bitBlt copyBits ]. mask ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: mask). bitBlt copyBits ]. ^ form! ! !BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'! understandsImageFormat stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER" self readHeader. bfType = 19778 "BM" ifFalse:[^false]. biSize = 40 ifFalse:[^false]. biPlanes = 1 ifFalse:[^false]. bfSize <= stream size ifFalse:[^false]. biCompression = 0 ifFalse:[^false]. ^true! ! !BMPReadWriter methodsFor: 'writing' stamp: 'StephaneDucasse 12/22/2010 16:04'! nextPutImage: aForm | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen pixline | depth := aForm depth. depth := #(1 4 8 32 ) detect: [ :each | each >= depth]. image := aForm asFormOfDepth: depth. image unhibernate. bhSize := 14. "# bytes in file header" biSize := 40. "info header size in bytes" biWidth := image width. biHeight := image height. biClrUsed := depth = 32 ifTrue: [0] ifFalse:[1 << depth]. "No. color table entries" bfOffBits := biSize + bhSize + (4*biClrUsed). rowBytes := ((depth min: 24) * biWidth + 31 // 32) * 4. biSizeImage := biHeight * rowBytes. "Write the file header" stream position: 0. stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" stream nextLittleEndianNumber: 4 put: 0. "bfReserved" stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" stream position: bhSize. stream nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" stream nextLittleEndianNumber: 4 put: image width. "biWidth" stream nextLittleEndianNumber: 4 put: image height. "biHeight" stream nextLittleEndianNumber: 2 put: 1. "biPlanes" stream nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" stream nextLittleEndianNumber: 4 put: 0. "biCompression" stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" stream nextLittleEndianNumber: 4 put: biClrUsed. stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues := image colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [:i | rgb := colorValues at: i. 0 to: 24 by: 8 do: [:j | stream nextPut: (rgb >> j bitAnd: 16rFF)]]]. depth < 32 ifTrue: [ "depth = 1, 4 or 8." data := image bits asByteArray. ppw := 32 // depth. scanLineLen := biWidth + ppw - 1 // ppw * 4. "# of bytes in line" 1 to: biHeight do: [:i | stream next: scanLineLen putAll: data startingAt: (biHeight-i)*scanLineLen+1. ]. ] ifFalse: [ data := image bits. pixline := ByteArray new: (((biWidth * 3 + 3) // 4) * 4). 1 to: biHeight do:[:i | self store24BitBmpLine: pixline from: data startingAt: (biHeight-i)*biWidth+1 width: biWidth. stream nextPutAll: pixline. ]. ]. stream position = (bfOffBits + biSizeImage) ifFalse: [self error:'Write failure']. stream close.! ! !BMPReadWriter methodsFor: 'writing' stamp: 'StephaneDucasse 12/22/2010 16:09'! store24BitBmpLine: pixelLine from: formBits startingAt: formBitsIndex width: width "Stores a single scanline containing 32bpp RGBA values in a 24bpp scanline. Swizzles the bytes as needed." | pixIndex rgb bitsIndex | pixIndex := 0. "pre-increment" bitsIndex := formBitsIndex-1. "pre-increment" 1 to: width do: [:j | rgb := (formBits at: (bitsIndex := bitsIndex+1)) bitAnd: 16rFFFFFF. pixelLine at: (pixIndex := pixIndex+1) put: (rgb bitAnd: 255). pixelLine at: (pixIndex := pixIndex+1) put: ((rgb bitShift: -8) bitAnd: 255). pixelLine at: (pixIndex := pixIndex+1) put: ((rgb bitShift: -16) bitAnd: 255). ]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BMPReadWriter class instanceVariableNames: ''! !BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('bmp')! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'CamilloBruni 5/7/2012 01:06'! displayAllFrom: fd "BMPReadWriter displayAllFrom: FileDirectory default" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display. Display forceDisplayUpdate] on: Error do:[:nix|]. ]. ]. fd directoryNames do:[:fdName| self displayAllFrom: (fd / fdName) ].! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'CamilloBruni 5/7/2012 01:06'! readAllFrom: fd "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix]. ]. ]. fd directoryNames do:[:fdName| self readAllFrom: (fd / fdName) ].! ! TestCase subclass: #BMPReadWriterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Tests-Files'! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData16bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk24AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABAAAAAAAIIAAADDDgAAww4AAAAAAAAAAAAA 4APgA+AD4AMfAB8AHwAfAOAD4APgA+ADHwAfAB8AHwDgA+AD/3//f/9//38fAB8A4APgA/9/ /3//f/9/HwAfAAAAAAD/f/9//3//fwB8AHwAAAAA/3//f/9//38AfAB8AAAAAAAAAAAAfAB8 AHwAfAAAAAAAAAAAAHwAfAB8AHwAAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData24bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest24.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk32AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABgAAAAAAAAAAADEDgAAxA4AAAAAAAAAAAAA AP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8A /////////////////wAA/wAAAP8AAP8A/////////////////wAA/wAAAAAAAAAA//////// ////////AAD/AAD/AAAAAAAA////////////////AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/ AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/AAD/AAD/' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData32bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk04AQAAAAAAADYAAAAoAAAACAAAAAgAAAABACAAAAAAAAIBAADDDgAAww4AAAAAAAAAAAAA AP8AAAD/AAAA/wAAAP8AAP8AAAD/AAAA/wAAAP8AAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8A AAD/AAAA/wAAAAD/AAAA/wAA////AP///wD///8A////AP8AAAD/AAAAAP8AAAD/AAD///8A ////AP///wD///8A/wAAAP8AAAAAAAAAAAAAAP///wD///8A////AP///wAAAP8AAAD/AAAA AAAAAAAA////AP///wD///8A////AAAA/wAAAP8AAAAAAAAAAAAAAAAAAAAAAAAA/wAAAP8A AAD/AAAA/wAAAAAAAAAAAAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAA' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:41'! bmpData4bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData8bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataR5G6B5 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-R5G6B5.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA APgAAOAHAAAfAAAAAAAAAOAH4AfgB+AHHwAfAB8AHwDgB+AH4AfgBx8AHwAfAB8A4AfgB/// ////////HwAfAOAH4Af//////////x8AHwAAAAAA//////////8A+AD4AAAAAP////////// APgA+AAAAAAAAAAAAPgA+AD4APgAAAAAAAAAAAD4APgA+AD4AAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataX4R4G4B4 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-X4R4G4B4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA AA8AAPAAAAAPAAAAAAAAAPAA8ADwAPAADwAPAA8ADwDwAPAA8ADwAA8ADwAPAA8A8ADwAP8P /w//D/8PDwAPAPAA8AD/D/8P/w//Dw8ADwAAAAAA/w//D/8P/w8ADwAPAAAAAP8P/w//D/8P AA8ADwAAAAAAAAAAAA8ADwAPAA8AAAAAAAAAAAAPAA8ADwAPAAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:05'! bmpDataX8R8G8B8 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32-X8R8G8B8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk1IAQAAAAAAAEYAAAA4AAAACAAAAAgAAAABACAAAwAAAAIBAADDDgAAww4AAAAAAAAAAAAA AAAA/wAA/wAA/wAAAAAAAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8AAAD/AAAA/wAAAAD/AAAA /wAAAP8AAAD/AAD/AAAA/wAAAP8AAAD/AAAAAP8AAAD/AAD///8A////AP///wD///8A/wAA AP8AAAAA/wAAAP8AAP///wD///8A////AP///wD/AAAA/wAAAAAAAAAAAAAA////AP///wD/ //8A////AAAA/wAAAP8AAAAAAAAAAAD///8A////AP///wD///8AAAD/AAAA/wAAAAAAAAAA AAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAAAAAAAAAAAAAAAAAAAAAAAP8AAAD/AAAA/wAA AP8AAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp16Bit | reader form | reader := BMPReadWriter new on: self bmpData16bit readStream. form := reader nextImage. "special black here to compensate for zero-is-transparent effect" self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 32768! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'tbn 12/27/2010 10:17'! testBmp24Bit | reader form | reader := BMPReadWriter new on: (ReadStream on: self bmpData24bit). form := reader nextImage. self assert: (form colorAt: 7@1) = Color red. self assert: (form colorAt: 1@7) = Color green. self assert: (form colorAt: 7@7) = Color blue. self assert: (form colorAt: 4@4) = Color white. self assert: (form pixelValueAt: 1@1) = 16rFF000001. ! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp32Bit | reader form | reader := BMPReadWriter new on: self bmpData32bit readStream. form := reader nextImage. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp4Bit | reader form | reader := BMPReadWriter new on: self bmpData4bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp8Bit | reader form | reader := BMPReadWriter new on: self bmpData8bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! Object subclass: #BadEqualer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always report #= correctly. Used for testing the EqualityTester.! !BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! = other self class = other class ifFalse: [^ false]. ^ 100 atRandom < 30 ! ! Object subclass: #BadHasher instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always hash correctly. I am used for testing the HashTester.! !BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! hash "answer with a different hash some of the time" 100 atRandom < 30 ifTrue: [^ 1]. ^ 2! ! Collection subclass: #Bag instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !Bag commentStamp: '' prior: 0! I represent an unordered collection of possibly duplicate elements. I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index self errorNotKeyed! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index put: anObject self errorNotKeyed! ! !Bag methodsFor: 'accessing' stamp: 'tao 1/5/2000 18:25'! cumulativeCounts "Answer with a collection of cumulative percents covered by elements so far." | s n | s := self size / 100.0. n := 0. ^ self sortedCounts asArray collect: [:a | n := n + a key. (n / s roundTo: 0.1) -> a value]! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:35'! size "Answer how many elements the receiver contains." | tally | tally := 0. contents do: [:each | tally := tally + each]. ^ tally! ! !Bag methodsFor: 'accessing' stamp: 'StephaneDucasse 12/25/2009 12:11'! sortedCounts "Answer with a collection of counts with elements, sorted by decreasing count." "Suggested by l. Uzonyi" ^(Array new: contents size streamContents: [ :stream | contents associationsDo: [ :each | stream nextPut: each value -> each key ] ]) sort: [:x :y | x >= y ]; yourself! ! !Bag methodsFor: 'accessing' stamp: 'StephaneDucasse 12/25/2009 12:32'! sortedElements "Answer with a collection of elements with counts, sorted by element." "Suggested by l. Uzonyi" ^contents associations sort; yourself! ! !Bag methodsFor: 'accessing' stamp: 'md 1/20/2006 15:58'! valuesAndCounts ^ contents! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:18'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." ^ self add: newObject withOccurrences: 1! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:20'! add: newObject withOccurrences: anInteger "Add newObject anInteger times to the receiver. Answer newObject." contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger. ^ newObject! ! !Bag methodsFor: 'comparing' stamp: 'md 10/17/2004 16:09'! = aBag "Two bags are equal if (a) they are the same 'kind' of thing. (b) they have the same size. (c) each element occurs the same number of times in both of them" (aBag isKindOf: Bag) ifFalse: [^false]. self size = aBag size ifFalse: [^false]. contents associationsDo: [:assoc| (aBag occurrencesOf: assoc key) = assoc value ifFalse: [^false]]. ^true ! ! !Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:34'! asBag ^ self! ! !Bag methodsFor: 'converting' stamp: 'nice 10/20/2009 19:37'! asSet "Answer a set with the elements of the receiver." ^ contents keys asSet! ! !Bag methodsFor: 'copying' stamp: 'nice 10/5/2009 08:54'! postCopy super postCopy. contents := contents copy! ! !Bag methodsFor: 'enumerating'! do: aBlock "Refer to the comment in Collection|do:." contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! !Bag methodsFor: 'math functions' stamp: 'ul 11/7/2010 01:46'! sum "Faster than the superclass implementation when you hold many instances of the same value (which you probably do, otherwise you wouldn't be using a Bag)." | sum first | first := true. contents keysAndValuesDo: [ :value :count | first ifTrue: [ sum := value * count. first := false ] ifFalse: [ sum := sum + (value * count) ] ]. first ifTrue: [ self errorEmptyCollection ]. ^sum! ! !Bag methodsFor: 'removing' stamp: 'sma 5/12/2000 14:32'! remove: oldObject ifAbsent: exceptionBlock "Refer to the comment in Collection|remove:ifAbsent:." | count | count := contents at: oldObject ifAbsent: [^ exceptionBlock value]. count = 1 ifTrue: [contents removeKey: oldObject] ifFalse: [contents at: oldObject put: count - 1]. ^ oldObject! ! !Bag methodsFor: 'removing' stamp: 'nice 9/14/2009 20:28'! removeAll "Implementation Note: as contents will be overwritten, a shallowCopy of self would be modified. An alternative implementation preserving capacity would be to create a new contents: self setContents: (self class contentsClass new: contents size)." contents removeAll! ! !Bag methodsFor: 'testing'! includes: anObject "Refer to the comment in Collection|includes:." ^contents includesKey: anObject! ! !Bag methodsFor: 'testing'! occurrencesOf: anObject "Refer to the comment in Collection|occurrencesOf:." (self includes: anObject) ifTrue: [^contents at: anObject] ifFalse: [^0]! ! !Bag methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'! setContents: aDictionary contents := aDictionary! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bag class instanceVariableNames: ''! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! contentsClass ^Dictionary! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'! new ^ self new: 4! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! new: nElements ^ super new setContents: (self contentsClass new: nElements)! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:17'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." ^ self withAll: aCollection "Examples: Bag newFrom: {1. 2. 3. 3} {1. 2. 3. 3} as: Bag "! ! CollectionRootTest subclass: #BagTest uses: TAddTest + TIncludesWithIdentityCheckTest + TCloneTest + TCopyTest + TSetArithmetic + TConvertTest + TAsStringCommaAndDelimiterTest + TRemoveForMultiplenessTest + TPrintTest + TConvertAsSortedTest + TConvertAsSetForMultiplinessTest + TConcatenationTest + TStructuralEqualityTest + TCreationWithTest - {#testOfSize} + TOccurrencesForMultiplinessTest instanceVariableNames: 'empty nonEmpty collectResult emptyButAllocatedWith20 elementExistsTwice element collectionWithElement collectionIn collectionNotIn collectionOfString elementNotIn collectionWithCharacters otherCollectionWithoutEqualElements collectionWithoutNilMoreThan5' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !BagTest methodsFor: 'as yet unclassified' stamp: 'damienpollet 1/13/2009 15:57'! testAnySastify self assert: ( self collection anySatisfy: [:each | each = self element]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAdd "self run: #testAdd" "self debug: #testAdd" | aBag | aBag := Bag new. aBag add: 'a'. aBag add: 'b'. self assert: aBag size = 2. aBag add: 'a'. self assert: aBag size = 3. self assert: (aBag occurrencesOf: 'a') = 2 ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAddWithOccurrences "self debug:#testAddWithOccurrences" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. self assert: (aBag size = 3). ! ! !BagTest methodsFor: 'basic tests' stamp: 'TJ 3/8/2006 08:42'! testAsBag | aBag | aBag := Bag new. self assert: aBag asBag = aBag.! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:29'! testAsSet | aBag aSet | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. aSet := aBag asSet. self assert: aSet size = 2. self assert: (aSet occurrencesOf: 'a') = 1 ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:30'! testCopy "self run: #testCopy" | aBag newBag | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. newBag := aBag copy. self assert: newBag = newBag. self assert: newBag asSet size = 2.! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:32'! testOccurrencesOf "self debug: #testOccurrencesOf" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. self assert: (aBag occurrencesOf:'a') = 3. self assert: (aBag occurrencesOf:'b') = 4. self assert: (aBag occurrencesOf:'c') = 0. self assert: (aBag occurrencesOf: nil) =0. aBag add: nil. self assert: (aBag occurrencesOf: nil) =1. ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:07'! collectionInForIncluding ^ collectionIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:16'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collectionWithoutNilMoreThan5 ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:08'! collectionNotIncluded ^ collectionNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfString! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:22'! collectionWithCharacters ^ collectionWithCharacters .! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfString! ! !BagTest methodsFor: 'requirements' stamp: 'sd 1/28/2009 16:32'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ collectionWithElement! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ collectionIn! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:20'! collectionWithEqualElements ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:31'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! collectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:15'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNilMoreThan5! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! element ^ super element! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:19'! elementInForIncludesTest ^ self element ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:32'! elementInForOccurrences " return an element included in nonEmpty" ^self nonEmpty anyOne.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:40'! elementNotIn ^elementNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:33'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ self elementTwiceIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:19'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot incllude equal elements ( classic equality ) all elements included are elements for which copy is not identical to the element " ^ collectionOfString ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! firstCollection " return a collection that will be the first part of the concatenation" ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! integerCollectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 10:54'! nonEmpty1Element ^ self speciesClass new add: self element ;yourself.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ otherCollectionWithoutEqualElements ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! otherCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! secondCollection " return a collection that will be the second part of the concatenation" ^ collectionWithCharacters ! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:40'! selectedNumber ^ 4! ! !BagTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Bag! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:21'! withEqualElements " return a collection including equal elements (classic equality)" ^ nonEmpty .! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! collection ^ nonEmpty. ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:13'! empty ^ empty ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:26'! emptyButAllocatedWith20 ^ emptyButAllocatedWith20! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:14'! nonEmpty ^ nonEmpty ! ! !BagTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:12'! result ^ collectResult. ! ! !BagTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:12'! setUp empty := self speciesClass new. nonEmpty := self speciesClass new add: 13; add: -2; add: self elementTwiceIn; add: 10; add: self elementTwiceIn; add: self element; yourself. elementNotIn := 0. collectionIn := self speciesClass new add: -2; add: self elementTwiceIn; add: 10; yourself. collectionNotIn := self speciesClass new add: self elementNotIn; add: 5; yourself. collectionOfString := self speciesClass new add: 1.5; add: 5.5; add: 7.5; yourself. otherCollectionWithoutEqualElements := self speciesClass new add: 1; add: 20; add: 30; add: 40; yourself. collectionWithoutNilMoreThan5 := self speciesClass new add: 1; add: 2; add: 3; add: 4; add: 5; add: 6; yourself. collectResult := self speciesClass new add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; yourself. emptyButAllocatedWith20 := self speciesClass new: 20. collectionWithElement := self spec