'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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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 <stdio.h>'.
			'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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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
	<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: '<historical>' 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
	<api: #inspect>
	"Return the border color"
	
	^ borderColor contents! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:31'!
borderColor: aColor
	<api: #color getter:#borderColor registration: #whenBorderColorChanged:>
	"Set the border width"
	
	borderColor contents: aColor ! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:17'!
borderWidth
	<api: #inspect>
	"Return the border width"
	
	^ borderWidth contents! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 17:46'!
borderWidth: anInteger
	<api: #integer min:0 max: 5 getter:#borderWidth registration: #whenBorderWidthChanged:>
	"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
	<api: #do>
	"Disable the label"
	
	self enabled: false! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:06'!
enable
	<api: #do>
	"Enable the label"
	
	self enabled: true! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:02'!
enabled
	<api: #inspect>
	^ enabledHolder contents! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:02'!
enabled: aBoolean
	<api: #boolean getter: #enabled registration: #whenEnabledChanged:>
	"Set if the button is enabled (clickable)"
	
	enabledHolder contents: aBoolean! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 17:55'!
help
	<api: #inspect>
	"Return the ballon text"
	
	^ helpHolder contents! !

!AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:18'!
help: aString
	<api: #string getter:#help registration: #whenHelpChanged:>
	"Set the help string"
	
	helpHolder contents: aString! !


!AbstractBasicWidget methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:36'!
whenBorderColorChanged: aBlock
	<api: #event>
	"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
	<api: #event>
	"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
	<api: #event>
	"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
	<api: #event>
	"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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' prior: 0!
An AbstractNautilusUI is an abstraction of the UI handling packages and classes.

Instance Variables
	cachedHierarchy:		<Object>
	classesSelection:		<Object>
	commentButton:		<Object>
	commentTextArea:		<Object>
	currentDisplayChoice:		<Object>
	firstColumn:		<Object>
	groupsSelection:		<Object>
	hierarchyClass:		<Object>
	list:		<Object>
	list2:		<Object>
	model:		<Object>
	packagesSelection:		<Object>
	secondColumn:		<Object>
	sourceCodeContainer:		<Object>
	sourceCodePanel:		<Object>
	sourceTextArea:		<Object>
	sourceTextAreaLimit:		<Object>
	window:		<Object>!


!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 '<<aClass name<<'"';cr;cr.
		str tab << 'super initialize.';cr.
		aClass instVarNames sort do: [:name | str cr tab << name << ' := nil.' ]].
	! !

!AbstractNautilusUI methodsFor: 'menus behavior'!
buildSetUpCodeFor: aClass 
	
	^ String streamContents: [:str | str << 'setUp';cr.
		str tab << '"Setting up code for '<<aClass name<<'"';cr;cr.
		aClass instVarNames sort do: [:name | str cr tab << name << ' := nil.' ]].
	! !

!AbstractNautilusUI methodsFor: 'menus behavior'!
buildTearDownCodeFor: aClass 
	
	^ String streamContents: [:str | str << 'tearDown';cr.
		str tab << '"Tearing down code for '<<aClass name<<'"';cr;cr.
		aClass instVarNames sort do: [:name | str cr tab << name << ' := nil.' ]].
	! !

!AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 1/30/2013 22:07'!
categorizeAllUncategorizedMethods
	"Categorize methods by looking in parent classes for a method category."
	self selectedClass ifNotNil: [ :aClass | | methods |
		self flag: 'TODO: why the heck do all  the methods.* methods return selectors??'.
		methods := aClass uncategorizedMethods collect: [ :selector| aClass >> 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
	<contextMenu>
	<nautilusGlobalClassMenu>
	| 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
	<contextMenu>
	<nautilusGlobalClassFixMenu>
	| 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
	<contextMenu>
	<nautilusGlobalClassMenu>
	| 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
	<contextMenu>
	<nautilusGlobalMethodMenu>
	<nautilusGlobalProtocolMenu>
	<nautilusGlobalClassMenu>
	<nautilusGlobalPackageMenu>
	<nautilusGlobalGroupMenu>
	
	| 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
	<contextMenu>
	<nautilusGlobalGroupFixMenu>
	| 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
	<contextMenu>
	<nautilusGlobalGroupMenu>
	| 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
	<contextMenu>
	<nautilusGlobalPackageFixMenu>
	| 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
	<contextMenu>
	<nautilusGlobalPackageMenu>
	| 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
	<contextMenu>
	<nautilusGlobalSourceCodeMenu>
	| 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
	<contextMenu>
	<nautilusGlobalSourceCodeMenu>
	
	| 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
	<contextMenu>
	<nautilusGlobalSourceCodeMenu>
	| 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
	<keymap>

	(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
	<keymap>	

	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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>	

	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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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
	<keymap>

	(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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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  
	<worldMenu>
	(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: '<historical>' 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: '<historical>' 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 "<Association|Pragma>" |
		(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 "<Association|Pragma>" |
		(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 "<Association|Pragma>" |
               (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 "<Association|Pragma>" |
		(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 "<Association|Message>" |
		(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 "<Association|Pragma>" |
		(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 "<Association|Pragma>" |
		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 "<Association|Pragma>" |
		(propertyOrPragma := self basicAt: i) isVariableBinding ifFalse:
			[propertyOrPragma setMethod: aMethod]]! !


!AdditionalMethodState methodsFor: 'copying' stamp: 'eem 9/16/2011 11:26'!
copyWith: aPropertyOrPragma "<Association|Pragma>"
	"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 "<Association|Pragma>"
	"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 "<Association|Pragma>" |
		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 "<Association|Pragma>" |
		(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 "<Association|Pragma>" |
		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 "<Association|Pragma>" |
		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 "<Association|Pragma>" |
		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 "<Association|Pragma>"
	"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:		<HelpTopic>

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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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: '<historical>' 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 <http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?searchCategory=Announcements%20Framework>. 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:		<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: '<historical>' 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: '<historical>' 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: '<historical>' 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"
	<primitive: 60>
	^ 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"
	<primitive: 61>
	^ 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."

	<primitive: 128>
	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."
	<primitive: 72>
	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."
	<primitive: 249>
	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."
	<primitive: 105>
	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"

	<primitive: 71>  "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: '<historical>' 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 | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).
! !

!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: '<historical>' 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."

	<primitive: 62>
	^ 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: '<historical>' 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 "<BlockNode>"  rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>"
	"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."

	<primitive: 'primitiveAsyncFileClose' module: 'AsynchFilePlugin'>
! !

!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."

	<primitive: 'primitiveAsyncFileOpen' module: 'AsynchFilePlugin'>
	^ 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"

	<primitive: 'primitiveAsyncFileReadResult' module: 'AsynchFilePlugin'>
	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."

	<primitive: 'primitiveAsyncFileReadStart' module: 'AsynchFilePlugin'>
	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"

	<primitive: 'primitiveAsyncFileWriteResult' module: 'AsynchFilePlugin'>
	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."

	<primitive: 'primitiveAsyncFileWriteStart' module: 'AsynchFilePlugin'>
	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: '<historical>' 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
<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: '<historical>' 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: '<historical>' 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, '<html><title>Unauthorized</title><body><h2>Unauthorized for ',realm, '</h2></body></html>'

! !
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."
	<primitive: 'primitiveRead24BmpLine' module:'BMPReadWriterPlugin'>
	
	| 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."
	<primitive: 'primitiveWrite24BmpLine' module:'BMPReadWriterPlugin'>

	| 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: '<historical>' 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