'! ! !CUHighlightExample methodsFor: 'examples' stamp: 'lr 2/17/2009 11:33'! someHtmlString ^ ' SCG Wiki: Diesel

Diesel

'! ! Object subclass: #CULindaBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Linda'! CULindaBinding subclass: #CUDontCareBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Linda'! !CUDontCareBinding methodsFor: 'actions' stamp: 'lr 2/16/2009 11:11'! lindaBind: anObject ^ anObject! ! CULindaBinding subclass: #CUGlobalLindaBinding instanceVariableNames: 'binding' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Linda'! !CUGlobalLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! binding ^ binding! ! !CUGlobalLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! binding: aBinding binding := aBinding! ! !CUGlobalLindaBinding methodsFor: 'actions' stamp: 'lr 2/13/2009 14:00'! lindaBind: anObject binding value: anObject. ^ anObject! ! CULindaBinding subclass: #CUInstanceLindaBinding instanceVariableNames: 'receiver index' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Linda'! !CUInstanceLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! index ^ index! ! !CUInstanceLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! index: anInteger index := anInteger! ! !CUInstanceLindaBinding methodsFor: 'actions' stamp: 'lr 2/13/2009 14:00'! lindaBind: anObject ^ receiver instVarAt: index put: anObject! ! !CUInstanceLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! receiver ^ receiver! ! !CUInstanceLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! receiver: anObject receiver := anObject! ! !CULindaBinding methodsFor: 'actions' stamp: 'lr 2/13/2009 13:58'! lindaBind: anObject self subclassResponsibility! ! !CULindaBinding methodsFor: 'testing' stamp: 'lr 2/11/2009 15:47'! lindaMatch: anObject "A binding matches everything." ^ true! ! CULindaBinding subclass: #CUTemporaryLindaBinding instanceVariableNames: 'context index' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Linda'! !CUTemporaryLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:58'! context ^ context! ! !CUTemporaryLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! context: aContext context := aContext! ! !CUTemporaryLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:58'! index ^ index! ! !CUTemporaryLindaBinding methodsFor: 'accessing' stamp: 'lr 2/13/2009 13:59'! index: anInteger index := anInteger! ! !CUTemporaryLindaBinding methodsFor: 'actions' stamp: 'lr 2/13/2009 13:57'! lindaBind: anObject ^ context tempAt: index put: anObject! ! Object subclass: #CULindaSpace instanceVariableNames: 'monitor tuples' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Linda'! !CULindaSpace methodsFor: 'initialization' stamp: 'lr 2/13/2009 15:19'! initialize monitor := Monitor new. tuples := OrderedCollection new! ! !CULindaSpace methodsFor: 'public' stamp: 'lr 2/13/2009 15:12'! read: aTuple "Blocking, non-destructive read from the tuple space." ^ self read: aTuple ifNone: nil! ! !CULindaSpace methodsFor: 'public' stamp: 'lr 2/13/2009 15:15'! read: aTuple ifNone: aBlock "Non-blocking, non-destructive read from the tuple space." monitor critical: [ [ 1 to: tuples size do: [ :index | (aTuple lindaMatch: (tuples at: index)) ifTrue: [ ^ aTuple lindaBind: (tuples at: index) ] ]. aBlock isNil ifTrue: [ monitor wait ] ifFalse: [ ^ aBlock value ] ] repeat ]! ! !CULindaSpace methodsFor: 'public' stamp: 'lr 2/11/2009 16:49'! scan: aTuple "Scan the complete tuple space and answer all matching tuples." | stream | stream := WriteStream on: (Array new: 16). self scan: aTuple do: [ :tuple | stream nextPut: tuple ]. ^ stream contents! ! !CULindaSpace methodsFor: 'public' stamp: 'lr 2/13/2009 14:56'! scan: aTuple do: aBlock "Scan the complete tuple space and evaluate aBlock for all matching tuples." | tuple | monitor critical: [ 1 to: tuples size do: [ :index | (aTuple lindaMatch: (tuple := tuples at: index)) ifTrue: [ aBlock value: (aTuple lindaBind: tuple) ] ] ]! ! !CULindaSpace methodsFor: 'public' stamp: 'lr 2/13/2009 15:12'! take: aTuple "Blocking, destructive read from the tuple space." ^ self take: aTuple ifNone: nil! ! !CULindaSpace methodsFor: 'public' stamp: 'lr 2/13/2009 15:20'! take: aTuple ifNone: aBlock "Non-blocking, destructive read from the tuple space." monitor critical: [ [ 1 to: tuples size do: [ :index | (aTuple lindaMatch: (tuples at: index)) ifTrue: [ ^ aTuple lindaBind: (tuples removeAt: index) ] ]. aBlock isNil ifTrue: [ monitor wait ] ifFalse: [ ^ aBlock value ] ] repeat ]! ! !CULindaSpace methodsFor: 'public' stamp: 'lr 2/13/2009 14:57'! write: aTuple "Add a tuple into a space." monitor critical: [ tuples add: aTuple. monitor signalAll ]! ! Object subclass: #CULindaTest instanceVariableNames: 'space instVar' classVariableNames: 'ClassVar DontCare' poolDictionaries: '' category: 'Cutie-Helvetia-Linda'! !CULindaTest class methodsFor: 'transformations' stamp: 'lr 2/18/2010 21:08'! annotatExpand | | ^ CHTreePattern new expression: '`var asLindaBinding' do: [ :context | "binding := context scopedTree receiver binding markWrite; asLindaBinding. ASTChecker new scope: context scopedTree owningScope; visitNode: binding. context scopedTree swapWith: binding" ]; yourself! ! !CULindaTest class methodsFor: 'initialization' stamp: 'lr 2/16/2009 11:12'! initialize DontCare := CUDontCareBinding new! ! !CULindaTest methodsFor: 'utilities' stamp: 'lr 2/23/2009 13:41'! fibonacci: anInteger "Calculates fibonacci numbers." | result | " try to read a cached version " (space read: { 'fib'. anInteger. result asLindaBinding } ifNone: [ nil ]) isNil ifFalse: [ ^ result ]. " set beginning of recursion " anInteger < 2 ifTrue: [ space write: { 'fib'. anInteger. 1 }. ^ 1 ]. " recurse " [ space write: { 'fib'. anInteger. (self fibonacci: anInteger - 1) + (self fibonacci: anInteger - 2) } ] fork. " wait for result " space read: { 'fib'. anInteger. result asLindaBinding }. ^ result! ! !CULindaTest methodsFor: 'utilities' stamp: 'lr 2/23/2009 13:41'! philosophersLife "The dining philosopher process." | total name ticket fork1 fork2 | " determine the total number and my name " space read: { 'total'. total asLindaBinding }. space take: { 'philosopher'. name asLindaBinding }. " philosophers eat 10 times, then they are done " 10 timesRepeat: [ Transcript show: 'Philosopher ' , name asString , ' is thinking.'; cr. (Delay forMilliseconds: 500 atRandom) wait. ticket := space take: { 'ticket' }. fork1 := space take: { 'fork'. name }. fork2 := space take: { 'fork'. (name \\ total) + 1 }. Transcript show: 'Philosopher ' , name asString , ' is eating.'; cr. (Delay forMilliseconds: 500 atRandom) wait. space write: fork1; write: fork2; write: ticket ]. Transcript show: 'Philosopher ' , name asString , ' is done.'; cr! ! !CULindaTest methodsFor: 'utilities' stamp: 'lr 2/23/2009 13:41'! philosophersTableOf: anInteger "Runs the dining philosopher problem with the philosophers given in anArray." " CULindaTest new setUp; philosophersTableOf: 5 " " remember the number of participants " space write: { 'total'. anInteger }. " create the philosophers and give them each a fork " 1 to: anInteger do: [ :index | space write: { 'fork'. index }. space write: { 'philosopher'. index }. index < anInteger ifTrue: [ space write: { 'ticket' } ] ]. " start the philosophers " 1 to: anInteger do: [ :index | [ self philosophersLife ] forkAt: Processor userBackgroundPriority named: 'Philosopher ' , index asString ]! ! !CULindaTest methodsFor: 'running' stamp: 'lr 2/23/2009 13:40'! setUp space := CULindaSpace new! ! !CULindaTest methodsFor: 'testing-bindings' stamp: 'lr 2/23/2009 13:40'! testBindDontCare space write: { 'testBindDontCare'. true }. space read: { 'testBindDontCare'. DontCare }! ! !CULindaTest methodsFor: 'testing-bindings' stamp: 'lr 2/23/2009 13:40'! testBindGlobal ClassVar := false. space write: { 'testGlobalBinding'. true }. space read: { 'testGlobalBinding'. ClassVar asLindaBinding }. self assert: ClassVar! ! !CULindaTest methodsFor: 'testing-bindings' stamp: 'lr 2/23/2009 13:40'! testBindInstance instVar := false. space write: { 'testInstanceBinding'. true }. space read: { 'testInstanceBinding'. instVar asLindaBinding }. self assert: instVar! ! !CULindaTest methodsFor: 'testing-bindings' stamp: 'lr 2/23/2009 13:40'! testBindTemp | temp | temp := false. space write: { 'testTempBinding'. true }. space read: { 'testTempBinding'. temp asLindaBinding }. self assert: temp! ! !CULindaTest methodsFor: 'testing-scenario' stamp: 'lr 2/23/2009 13:41'! testFibonacci self assert: (self fibonacci: 5) = 8. self assert: (self fibonacci: 8) = 34. self assert: (self fibonacci: 12) = 233. self assert: (self fibonacci: 30) = 1346269! ! !CULindaTest methodsFor: 'testing-matching' stamp: 'lr 2/23/2009 13:41'! testMatchBlock space write: #(1); write: #(2); write: #(3). self assert: (space scan: { [ :a | a even ] }) size = 1. self assert: (space scan: { [ :a | a odd ] }) size = 2! ! !CULindaTest methodsFor: 'testing-matching' stamp: 'lr 2/23/2009 13:41'! testMatchClass space write: #('foo'); write: #(123); write: #(45.6); write: #(false). self assert: (space scan: { String }) size = 1. self assert: (space scan: { Integer }) size = 1. self assert: (space scan: { Float }) size = 1. self assert: (space scan: { Boolean }) size = 1. self assert: (space scan: { UndefinedObject }) isEmpty! ! !CULindaTest methodsFor: 'testing-matching' stamp: 'lr 2/23/2009 13:41'! testMatchLiteral space write: #('foo'); write: #(123); write: #(45.6); write: #(false). self assert: (space scan: #('foo')) size = 1. self assert: (space scan: #(123)) size = 1. self assert: (space scan: #(45.6)) size = 1. self assert: (space scan: #(false)) size = 1. self assert: (space scan: #(true)) isEmpty! ! !CULindaTest methodsFor: 'testing' stamp: 'lr 2/23/2009 13:40'! testRead | value semaphore process | value := false. semaphore := Semaphore new. process := [ space read: { value asLindaBinding }. semaphore signal ] newProcess. process resume. self deny: value. self deny: process isTerminated. space write: #(true). semaphore wait. self assert: value! ! !CULindaTest methodsFor: 'testing' stamp: 'lr 2/23/2009 13:40'! testReadIfNone | result value | result := space read: { value asLindaBinding } ifNone: [ true ]. self assert: result. self assert: value isNil. space write: #(1). result := space read: { value asLindaBinding } ifNone: [ false ]. self assert: result = #(1). self assert: value = 1. result := space read: { value asLindaBinding } ifNone: [ false ]. self assert: result = #(1). self assert: value = 1! ! !CULindaTest methodsFor: 'testing' stamp: 'lr 2/23/2009 13:40'! testScan self assert: (space scan: #()) isEmpty. self assert: (space scan: #(1)) isEmpty. space write: #(); write: #(1). self assert: (space scan: #()) size = 1. self assert: (space scan: #(1)) size = 1 ! ! !CULindaTest methodsFor: 'testing' stamp: 'lr 2/23/2009 13:40'! testScanDo space scan: #() do: [ :each | self fail ]. space write: #(1). space scan: #() do: [ :each | self fail ]. space scan: #(1) do: [ :each | self assert: each first = 1 ]! ! !CULindaTest methodsFor: 'testing' stamp: 'lr 2/23/2009 13:40'! testTake | value semaphore process | value := false. semaphore := Semaphore new. process := [ space take: { value asLindaBinding }. semaphore signal ] newProcess. process resume. self deny: value. self deny: process isTerminated. space write: #(true). semaphore wait. self assert: value. self assert: (space take: { DontCare } ifNone: [ true ])! ! !CULindaTest methodsFor: 'testing' stamp: 'lr 2/23/2009 13:40'! testTakeIfNone | result value | result := space take: { value asLindaBinding } ifNone: [ true ]. self assert: result. self assert: value isNil. space write: #(1). result := space take: { value asLindaBinding } ifNone: [ false ]. self assert: result = #(1). self assert: value = 1. result := space take: { value asLindaBinding } ifNone: [ false ]. self deny: result. self assert: value = 1! ! Object subclass: #CUTransaction instanceVariableNames: 'context changes objectChanges' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Trans'! !CUTransaction methodsFor: 'private' stamp: 'lr 2/23/2009 16:41'! abort "Abort a transaction." context := changes := objectChanges := nil! ! !CUTransaction methodsFor: 'public' stamp: 'lr 2/23/2009 15:09'! abort: aValue "Abort a transaction." thisContext swapSender: context. self abort. ^ aValue! ! !CUTransaction methodsFor: 'accessing' stamp: 'lr 2/23/2009 15:11'! addChange: aChange ^ changes add: aChange! ! !CUTransaction methodsFor: 'public' stamp: 'lr 2/23/2009 13:54'! atomic: aBlock "Start a transaction with aBlock." ^ self atomic: aBlock ifConflict: [ self signalConflict ]! ! !CUTransaction methodsFor: 'public' stamp: 'lr 2/23/2009 16:42'! atomic: aBlock ifConflict: aConflictBlock "Evaluate aBLock within a new transaction, unless we are already in an existing transactional context. Evaluate aConflictBlock if the transaction conflicts with concurrent edits." | result | context := thisContext sender. self begin. [ result := aBlock on: CUTransactionCurrent do: [ :err | err resume: self ] ] ifCurtailed: [ self abort ]. self commitIfConflict: aConflictBlock. ^ result! ! !CUTransaction methodsFor: 'private' stamp: 'lr 2/23/2009 16:41'! begin "Start a transaction. If this is a nested transaction copy the parent changes into our own context." changes := OrderedCollection new. objectChanges := IdentityDictionary new! ! !CUTransaction methodsFor: 'accessing' stamp: 'lr 2/23/2009 15:11'! changeFor: anObject ^ objectChanges at: anObject ifAbsentPut: [ self addChange: (CUObjectChange on: anObject) ]! ! !CUTransaction methodsFor: 'accessing' stamp: 'lr 2/23/2009 15:11'! changes "Answer an ordered collection of unique changes." ^ changes! ! !CUTransaction methodsFor: 'public' stamp: 'lr 2/23/2009 13:58'! checkpoint "Checkpoint a transaction." self commit; begin! ! !CUTransaction methodsFor: 'private' stamp: 'lr 2/23/2009 15:10'! commit "Commit a transaction." self commitIfConflict: [ self signalConflict ]! ! !CUTransaction methodsFor: 'private' stamp: 'lr 2/23/2009 16:40'! commitIfConflict: aBlock "Commit a transaction atomically." [ changes do: [ :each | each hasConflict ifTrue: [ ^ aBlock value ] ]. changes do: [ :each | each hasChanged ifTrue: [ each apply ] ] ] valueUnpreemptively! ! !CUTransaction methodsFor: 'accessing' stamp: 'lr 2/23/2009 15:11'! objectChanges ^ objectChanges! ! !CUTransaction methodsFor: 'public' stamp: 'lr 2/23/2009 16:13'! retry: aBlock "Unconditionally retry to evaluate aBlock until there are no conflict." ^ self atomic: aBlock ifConflict: [ self retry: aBlock ]! ! !CUTransaction methodsFor: 'private' stamp: 'lr 2/23/2009 16:43'! signalConflict ^ CUTransactionConflict new transaction: self; signal! ! !Object methodsFor: '*cutie-helvetia-linda' stamp: 'lr 2/13/2009 16:25'! asLindaBinding self error: 'There is something wrong with your compiler.'! ! !Object methodsFor: '*cutie-helvetia-trans' stamp: 'lr 2/23/2009 15:56'! atomicInstVarAt: anInteger ^ self instVarAt: anInteger! ! !Object methodsFor: '*cutie-helvetia-trans' stamp: 'lr 2/23/2009 15:56'! atomicInstVarAt: anInteger put: anObject ^ self instVarAt: anInteger put: anObject! ! !Object methodsFor: '*cutie-helvetia-linda' stamp: 'lr 2/11/2009 15:56'! lindaBind: anObject "Bind the value anObject to the receiver. Does nothing by default." ^ anObject! ! !Object methodsFor: '*cutie-helvetia-linda' stamp: 'lr 2/11/2009 15:47'! lindaMatch: anObject "Normally the default Smalltalk comparator is used." ^ self = anObject! ! PPDelegateParser subclass: #CUCompositeParser instanceVariableNames: 'productions unresolved' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Parser'! !CUCompositeParser class methodsFor: 'private' stamp: 'lr 4/26/2010 23:15'! isActionNode: aNode aNode parent isNil ifTrue: [ ^ false ]. (aNode parent isMessage and: [ aNode parent arguments notEmpty and: [ aNode parent arguments first = aNode and: [ #(==> map: foldLeft: foldRight:) includes: aNode parent selector ] ] ]) ifTrue: [ ^ true ]. ^ self isActionNode: aNode parent! ! !CUCompositeParser class methodsFor: 'parsing' stamp: 'lr 10/23/2008 17:02'! parse: aString ^ self new parse: aString! ! !CUCompositeParser class methodsFor: 'parsing' stamp: 'lr 10/23/2008 17:02'! parse: aString ifError: aBlock ^ self new parse: aString ifError: aBlock! ! !CUCompositeParser class methodsFor: 'private' stamp: 'lr 4/26/2010 23:01'! transformation ^ CHConditionPattern new if: [ :context | context tree isMethod and: [ context tree selector isUnary and: [ context theClass ~= CUCompositeParser and: [ context tree selector ~= #initialize ] ] ] ] then: (Array " convert terminals " with: (CHTreePattern new verification: [ :node | (self isActionNode: node) not and: [ node value isString or: [ node value isCharacter ] ] ]; expression: '`#var' do: [ :context | context node swapWith: ``(`,(context node value) asParser) ]) " convert nonterminals " with: (CHTreePattern new verification: [ :node | (self isActionNode: node) not ]; expression: '`var' do: [ :context | ((context theClass bindingOf: context node name) isNil and: [ (context tree allDefinedVariables includes: context node name) not and: [ (context theClass allInstVarNames includes: context node name) not and: [ (#('self' 'super' 'thisContext') includes: context node name) not ] ] ]) ifTrue: [ context node swapWith: ``(self productionAt: `,(context node name asSymbol)) ] ]) " fixup method body " with: [ :context | context tree body addReturn ])! ! !CUCompositeParser methodsFor: 'initialization' stamp: 'lr 5/7/2009 10:44'! initialize super initialize. productions := IdentityDictionary new. unresolved := OrderedCollection new. parser := self productionAt: #start. self resolve! ! !CUCompositeParser methodsFor: 'parsing' stamp: 'lr 4/26/2010 22:28'! parse: aString ifError: aBlock ^ self parse: aString onError: aBlock! ! !CUCompositeParser methodsFor: 'private' stamp: 'lr 5/5/2009 11:31'! productionAt: aSymbol productions at: aSymbol ifPresent: [ :value | ^ value ]. productions at: aSymbol put: (unresolved add: (PPUnresolvedParser new name: aSymbol)). ^ productions at: aSymbol put: ((self perform: aSymbol) name: aSymbol)! ! !CUCompositeParser methodsFor: 'private' stamp: 'lr 4/3/2009 11:38'! resolve | resolved | unresolved := unresolved asArray. resolved := unresolved collect: [ :each | (productions at: each name) memoized name: each name; yourself ]. unresolved elementsForwardIdentityTo: resolved. unresolved := #()! ! !CUCompositeParser methodsFor: 'accessing' stamp: 'lr 5/26/2008 13:53'! start "Answer the production to start this parser with." self subclassResponsibility! ! !CUCompositeParser methodsFor: 'parsing' stamp: 'lr 5/7/2009 13:08'! withContextDo: aBlock "Make sure that the composite parser is on the stack, this is useful when redefining the grammar so that the token have the right type." ^ aBlock value! ! CUCompositeParser subclass: #CUFactorialParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Parser'! CUFactorialParser subclass: #CUFactorialCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Parser'! !CUFactorialCompiler methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:02'! apply super apply ==> [ :node | RBMessageNode receiver: ``(self) selector: (self selector: node second count: node third size) arguments: node third ]! ! !CUFactorialCompiler methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:02'! binary super binary ==> [ :node | ``(`,(node second) ? `,(node fourth)) selector: node third asSymbol; yourself ]! ! !CUFactorialCompiler methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:02'! condition super condition ==> [ :node | ``(`,(node second) ifTrue: [ `,(node fourth) ] ifFalse: [ `,(node sixth) ]) ]! ! !CUFactorialCompiler methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:02'! function super function ==> [ :node | RBMethodNode selector: (self selector: node first count: node second size) arguments: node second body: ((RBSequenceNode statements: (Array with: node fourth)) addReturn; yourself) ]! ! !CUFactorialCompiler methodsFor: 'grammar' stamp: 'lr 5/5/2009 15:08'! literal super literal ==> [ :token | RBLiteralNode literalToken: token value: token value asNumber ]! ! !CUFactorialCompiler methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:02'! operation super operation ==> [ :node | node asString = '==' ifTrue: [ #= ] ifFalse: [ node asSymbol ] ]! ! !CUFactorialCompiler methodsFor: 'private' stamp: 'lr 5/26/2008 15:01'! selector: aString count: anInteger | stream | stream := WriteStream on: String new. stream nextPutAll: aString. 1 to: anInteger do: [ :index | index > 1 ifTrue: [ stream nextPutAll: 'with' ]. stream nextPut: $: ]. ^ stream contents asSymbol! ! !CUFactorialCompiler methodsFor: 'grammar' stamp: 'lr 5/5/2009 15:07'! variable super variable ==> [ :token | RBVariableNode identifierToken: token ]! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! add $+ token! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 4/3/2009 11:23'! apply open , id , expression star , close! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 5/26/2008 14:59'! binary open , expression , operation , expression , close! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! close $) token! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! cmp '==' token! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 5/26/2008 14:59'! condition if , expression , then , expression , else , expression! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! else 'else' token! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! equal $= token! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 9/18/2008 11:15'! expression apply / condition / binary / variable / literal! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 5/26/2008 14:59'! function id , variable star , equal , expression! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! id #letter plus token! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! if 'if' token! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 5/26/2008 14:59'! literal num! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! num #digit plus token! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:06'! open $( token! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 9/18/2008 11:15'! operation cmp / add / sub! ! !CUFactorialParser methodsFor: 'accessing' stamp: 'lr 4/3/2009 11:23'! start function end! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:07'! sub $- token! ! !CUFactorialParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:07'! then 'then' token! ! !CUFactorialParser methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:00'! variable id! ! CUFactorialParser subclass: #CUFactorialPrinter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Parser'! !CUFactorialPrinter methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:01'! apply super apply ==> [ :node | '(' , node second , ' ' , (node third fold: [ :a :b | a , ' ' , b ]) , ')' ]! ! !CUFactorialPrinter methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:01'! binary super binary ==> [ :node | '(' , node second , ' ' , node third , ' ' , node fourth , ')' ]! ! !CUFactorialPrinter methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:01'! condition super condition ==> [ :node | 'if ' , node second , ' then ' , node fourth , ' else ' , node sixth ]! ! !CUFactorialPrinter methodsFor: 'grammar' stamp: 'lr 5/26/2008 15:01'! function super function ==> [ :node | node first , ' ' , (node second fold: [ :a :b | a , ' ' , b ]) , ' = ' , node fourth ]! ! Error subclass: #CUTransactionConflict instanceVariableNames: 'transaction' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Trans'! !CUTransactionConflict methodsFor: 'accessing' stamp: 'lr 5/25/2007 09:04'! transaction ^ transaction! ! !CUTransactionConflict methodsFor: 'accessing' stamp: 'lr 5/25/2007 09:04'! transaction: aTransaction transaction := aTransaction! ! Notification subclass: #CUTransactionCurrent instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Trans'! !RBParseTreeSearcher methodsFor: '*cutie-helvetia' stamp: 'lr 4/26/2010 23:34'! searches ^ searches! ! PPCompositeParser subclass: #CUAutomatonGrammar instanceVariableNames: 'identifier character automaton initial state transition' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Automaton'! CUAutomatonGrammar subclass: #CUAutomatonCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Automaton'! !CUAutomatonCompiler methodsFor: 'productions' stamp: 'lr 11/11/2009 13:52'! automaton ^ super automaton ==> [ :nodes | | result | result := CUAutomaton new. result initialState: nodes first value. nodes second do: [ :each | | newState | newState := result newState: each key. each value do: [ :assoc | newState on: assoc key do: assoc value ] ]. result ]! ! !CUAutomatonCompiler methodsFor: 'productions' stamp: 'lr 11/11/2009 13:19'! state ^ super state ==> [ :nodes | nodes first value -> nodes last ]! ! !CUAutomatonCompiler methodsFor: 'productions' stamp: 'lr 11/11/2009 13:20'! transition ^ super transition ==> [ :nodes | nodes first value first -> nodes last value ]! ! !CUAutomatonGrammar methodsFor: 'productions' stamp: 'lr 11/11/2009 13:51'! automaton ^ initial , state plus! ! !CUAutomatonGrammar methodsFor: 'tokens' stamp: 'lr 4/26/2010 23:31'! character ^ #letter asParser token trim! ! !CUAutomatonGrammar methodsFor: 'tokens' stamp: 'lr 4/26/2010 23:31'! identifier ^ (#letter asParser , #word asParser plus) token trim! ! !CUAutomatonGrammar methodsFor: 'productions' stamp: 'lr 11/11/2009 13:07'! initial ^ identifier! ! !CUAutomatonGrammar methodsFor: 'accessing' stamp: 'lr 11/11/2009 13:51'! start ^ automaton end! ! !CUAutomatonGrammar methodsFor: 'productions' stamp: 'lr 4/26/2010 23:30'! state ^ identifier , $: asParser token trim , transition star! ! !CUAutomatonGrammar methodsFor: 'productions' stamp: 'lr 4/26/2010 23:30'! transition ^ character , '->' asParser token trim , identifier! ! !RBTransformationRule methodsFor: '*cutie-helvetia' stamp: 'lr 3/28/2008 14:45'! setClass: aClass class := aClass! ! !BlockClosure methodsFor: '*cutie-helvetia-trans' stamp: 'lr 5/18/2009 15:02'! atomic ^ CUTransaction new atomic: self! ! !BlockClosure methodsFor: '*cutie-helvetia-linda' stamp: 'lr 5/18/2009 15:02'! lindaMatch: anObject "Use a block condition to compare." ^ self value: anObject! ! !SequenceableCollection methodsFor: '*cutie-helvetia-linda' stamp: 'lr 2/11/2009 15:56'! lindaBind: anObject "Bind the value anObject to the receiver." | result | result := self class new: self size. 1 to: self size do: [ :index | result at: index put: ((self at: index) lindaBind: (anObject at: index)) ]. ^ result! ! !SequenceableCollection methodsFor: '*cutie-helvetia-linda' stamp: 'lr 2/11/2009 15:50'! lindaMatch: anObject "This is the tuple comparison. Dispatch to the individual elements of the other collection." | other | (anObject isCollection and: [ self size = anObject size ]) ifFalse: [ ^ false ]. other := anObject asArray. 1 to: self size do: [ :index | ((self at: index) lindaMatch: (other at: index)) ifFalse: [ ^ false ] ]. ^ true! ! !OBPluggableTextMorphWithShout class methodsFor: '*cutie-helvetia-override' stamp: 'lr 4/2/2009 15:34'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel | styler answer | answer := self new. styler := CHTextStyler new view: answer; yourself. ^ answer styler: styler; on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel! ! QQTestCase subclass: #CUAssociationExample instanceVariableNames: 'other' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! !CUAssociationExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:14'! translateReleation ^ CHConditionPattern new if: [ :context | context hasPragmaNamed: #opposite: ] then: (CHTreePattern new method: '`method: `argument `variable := `argument' do: [ :context | | opposite variable | opposite := (context pragmaNamed: #opposite:) arguments first. variable := context @ '`variable'. context tree body addNodeFirst: ``(`,(variable) isNil ifFalse: [ `,(variable) instVarNamed: `,(opposite) put: nil ]). context tree body addNode: ``(`,(variable) isNil ifFalse: [ `,(variable) instVarNamed: `,(opposite) put: self ]) ])! ! !CUAssociationExample methodsFor: 'accessing' stamp: 'lr 8/19/2008 13:38'! other ^ other! ! !CUAssociationExample methodsFor: 'accessing' stamp: 'lr 8/19/2008 13:39'! other: anObject other := anObject! ! !CUAssociationExample methodsFor: 'testing' stamp: 'lr 8/19/2008 13:39'! testEmpty | test | test := self copy. self assert: self other isNil. self assert: test other isNil.! ! !CUAssociationExample methodsFor: 'testing' stamp: 'lr 4/26/2010 23:13'! testNil | test | test := self copy. test other: self. self other: nil. self assert: self other isNil. self assert: test other isNil! ! !CUAssociationExample methodsFor: 'testing' stamp: 'lr 4/26/2010 23:14'! testOpposite | test | test := self copy. test other: self. self assert: self other == test. self assert: test other == self! ! !CUAssociationExample methodsFor: 'testing' stamp: 'lr 4/26/2010 23:14'! testSwap | test1 test2 | test1 := self copy. self other: test1. test2 := self copy. self other: test2. self assert: self other = test2. self assert: test1 other isNil. self assert: test2 other = self! ! !CUAssociationExample methodsFor: 'testing' stamp: 'lr 4/26/2010 23:14'! testThis | test | test := self copy. self other: test. self assert: self other = test. self assert: test other = self! ! QQTestCase subclass: #CUAutomatonTest instanceVariableNames: 'repository' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia-Automaton'! !CUAutomatonTest methodsFor: 'running' stamp: 'lr 4/27/2010 11:58'! setUp super setUp. repository := CUAutomatonRepository new! ! !CUAutomatonTest methodsFor: 'testing' stamp: 'lr 4/27/2010 12:00'! testExample self assert: (repository example accept: 'car'). self assert: (repository example accept: 'cdr'). self assert: (repository example accept: 'cadr'). self assert: (repository example accept: 'cdar'). self assert: (repository example accept: 'caadr'). self assert: (repository example accept: 'cdaar'). self assert: (repository example accept: 'caddr'). self assert: (repository example accept: 'cddar')! ! QQTestCase subclass: #CUCastingExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! !CUCastingExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:27'! transformCast ^ CHTreePattern new expression: '(``@obj cast: `literal) `@msg: ``@args' do: [ :context | context node swapWith: ``(`,(context node receiver receiver) perform: `,(context node selector) withArguments: { `,(context node arguments) } inSuperclass: `,(context node receiver arguments first)) ]; yourself! ! !CUCastingExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:11'! transformThis ^ Array with: (CHTreePattern new expression: 'this `@msg: ``@args' do: [ :context | context node swapWith: ``(self perform: `,(context node selector) withArguments: { `,(context node arguments) } inSuperclass: `,(context theClass)) ]; yourself) with: (CHTreePattern new expression: 'this' do: [ :context | context node swapWith: ``(self) ]; yourself)! ! !CUCastingExample methodsFor: 'testing-cast' stamp: 'lr 4/27/2010 11:42'! testBinaryCast | point1 point2 | point1 := 1 @ 2. point2 := 1 @ 2. self assert: point1 = point2. self deny: (point1 cast: Object) = point2! ! !CUCastingExample methodsFor: 'testing-this' stamp: 'lr 6/10/2008 21:45'! testEqualityThis self assert: self == super. self assert: super == self. self assert: self == this. self assert: this == self. self assert: super == this. self assert: this == super! ! !CUCastingExample methodsFor: 'testing-cast' stamp: 'lr 4/16/2008 23:24'! testKeywordCast | point | point := 1 @ 2. self assert: (String streamContents: [ :stream | point printOn: stream ]) = '1@2'. self assert: (String streamContents: [ :stream | (point cast: Object) printOn: stream ]) = 'a Point'! ! !CUCastingExample methodsFor: 'testing-cast' stamp: 'lr 4/17/2008 10:45'! testUnaryCast | point | point := 1 @ 2. self assert: (point hash) ~= point identityHash. self assert: (point cast: Object) hash = point identityHash! ! QQTestCase subclass: #CUControlExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! !CUControlExample class methodsFor: 'transformation' stamp: 'lr 4/2/2009 15:28'! transformIf ^ CHTreePattern new expression: '`@statement if: `@boolean' do: [ :context | | statement condition | statement := context @ '`@statement'. statement isBlock ifFalse: [ statement := ``[ `,statement ] ]. condition := context @ '`@boolean'. context node swapWith: ``(`,condition ifTrue: `,statement) ]; yourself! ! !CUControlExample methodsFor: 'as yet unclassified' stamp: 'lr 2/25/2009 09:45'! testWithBlock | marker | [ marker := 1 ] if: true. self assert: marker = 1. [ marker := 2 ] if: false. self assert: marker = 1 ! ! !CUControlExample methodsFor: 'as yet unclassified' stamp: 'lr 2/25/2009 09:46'! testWithoutBlock | marker | (marker := 1) if: true. self assert: marker = 1. (marker := 2) if: false. self assert: marker = 1 ! ! QQTestCase subclass: #CUExpandExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! !CUExpandExample class methodsFor: 'transformations' stamp: 'lr 8/13/2008 13:42'! expand: aNode arguments: aNodeArray | stream parts string char index argument | aNode value isEmpty ifTrue: [ ^ aNode ]. stream := aNode value readStream. parts := OrderedCollection new. [ stream atEnd ] whileFalse: [ string := stream upTo: $<. string isEmpty ifFalse: [ parts add: string lift ]. stream atEnd ifFalse: [ char := stream next asUppercase. char = $N ifTrue: [ parts add: ``(String cr) ]. char = $T ifTrue: [ parts add: ``(String tab) ]. char isDigit ifTrue: [ index := char digitValue. [ stream atEnd or: [ (char := stream next asUppercase) isDigit not ] ] whileFalse: [ index := index * 10 + char digitValue ]. argument := aNodeArray at: index ifAbsent: [ self error: 'Invalid argument' ]. char = $? ifTrue: [ parts add: ``(`,argument ifTrue: [ `,(stream upTo: $:) ] ifFalse: [ `,(stream upTo: $>) ]). stream skip: -1 ]. char = $P ifTrue: [ parts add: ``(`,argument printString) ]. char = $S ifTrue: [ parts add: argument ] ]. stream skipTo: $> ] ]. ^ parts fold: [ :a :b | ``(`,a , `,b) ]! ! !CUExpandExample class methodsFor: 'transformations' stamp: 'lr 9/18/2008 11:17'! flattenChain: aNode to: aCollection (aNode isMessage and: [ aNode isBinary ]) ifFalse: [ aCollection add: aNode ] ifTrue: [ self flattenChain: aNode receiver to: aCollection. aCollection add: aNode arguments first ]. ^ aCollection! ! !CUExpandExample class methodsFor: 'transformations' stamp: 'lr 4/2/2009 15:28'! transformExpand | node | ^ CHTreePattern new expression: '`#literal << `@arguments' do: [ :context | node := context scopedTree. context scopedTree swapWith: (self expand: node receiver arguments: (self flattenChain: node arguments first to: OrderedCollection new)) ]; yourself! ! !CUExpandExample class methodsFor: 'transformations' stamp: 'lr 4/2/2009 15:28'! transformHighlight ^ CHTreePattern new expression: '`#literal << `@arguments'; at: '`#literal' do: (CHMatchPattern new expression: '<([^>]+)>' do: TextEmphasis italic; yourself); yourself! ! !CUExpandExample methodsFor: 'testing' stamp: 'lr 2/25/2009 09:46'! testBoolean self assert: '<1?yes:no>' << true = 'yes'. self assert: 'a<1?yes:no>' << false = 'ano'. self assert: '<1?yes:no>a' << true = 'yesa'. self assert: 'a<1?yes:no>b' << false = 'anob'! ! !CUExpandExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:16'! testEmpty self assert: '' << nil = String tab! ! !CUExpandExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:14'! testExample self assert: '<1s> owns <2p> pair<3?s:>' << ('Hans' , 1 , false) = 'Hans owns 1 pair'. self assert: '<1s> owns <2p> pair<3?s:>' << ('Kurt' , 2 , true) = 'Kurt owns 2 pairs'! ! !CUExpandExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:16'! testNewLine self assert: '' << nil = String cr.! ! !CUExpandExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:15'! testPrint self assert: '<1p>' << 1 = '1'. self assert: 'a<1p>' << 2 = 'a2'. self assert: '<1p>a' << 3 = '3a'. self assert: 'a<1p>b' << 4 = 'a4b'! ! !CUExpandExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:15'! testString self assert: '<1s>' << 'x' = 'x'. self assert: 'a<1s>' << 'y' = 'ay'. self assert: '<1s>a' << 'z' = 'za'. self assert: 'a<1s>b' << ' ' = 'a b'! ! !CUExpandExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:16'! testTab self assert: '' << nil = String tab! ! QQTestCase subclass: #CUInterpolateExample instanceVariableNames: 'instVar' classVariableNames: 'ClassVar' poolDictionaries: '' category: 'Cutie-Helvetia'! !CUInterpolateExample class methodsFor: 'transformations' stamp: 'lr 8/13/2008 13:42'! interpolate: aString | stream parts string | aString isEmpty ifTrue: [ ^ aString lift ]. stream := aString readStream. parts := OrderedCollection new. [ stream atEnd ] whileFalse: [ string := stream upTo: ${. string isEmpty ifFalse: [ parts add: (string lift adjustBy: stream position - string size + 1) ]. string := stream upTo: $}. string isEmpty ifFalse: [ parts add: (``(`,(QQParser parseExpression: string) asString) adjustBy: stream position - string size + 1) ] ]. ^ parts fold: [ :a :b | ``(`,a , `,b) ]! ! !CUInterpolateExample class methodsFor: 'transformations' stamp: 'lr 4/2/2009 21:25'! transformHighlight ^ CHTreePattern new verification: [ :node | node value isString and: [ node value isSymbol not ] ]; expression: '`#literal' do: (CHRangePattern new begin: '{' do: Color black; end: '}' do: Color black; outer: (CHHighlightAttribute new color: (Color lightGray alpha: 0.25); yourself); inner: Color gray muchDarker; yourself); yourself! ! !CUInterpolateExample class methodsFor: 'transformations' stamp: 'lr 4/2/2009 15:28'! transformInterpolate ^ CHTreePattern new verification: [ :node | node value isString and: [ node value isSymbol not ] ]; expression: '`#literal' do: [ :context | context node swapWith: (self interpolate: context node value) ]; yourself! ! !CUInterpolateExample methodsFor: 'utilities' stamp: 'lr 5/26/2008 15:37'! owner: owner object: object count: count ^ '{owner} owns {count} {object asPluralBasedOn: count}'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 7/4/2008 10:18'! testArithmetic self assert: '{1}' = '1'. self assert: '{1 + 2}' = '3'. self assert: '{10 factorial}' = '3628800'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 4/17/2008 14:55'! testClassVar ClassVar := 'abc'. self assert: '{ClassVar}' = 'abc'. self assert: 'x{ClassVar}' = 'xabc'. self assert: '{ClassVar}x' = 'abcx'. self assert: 'x{ClassVar}x' = 'xabcx'. ClassVar := 123. self assert: '{ClassVar}' = '123'. self assert: 'x{ClassVar}' = 'x123'. self assert: '{ClassVar}x' = '123x'. self assert: 'x{ClassVar}x' = 'x123x'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 4/17/2008 14:54'! testEmpty self assert: '' = ''. self assert: '' == ''! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 5/26/2008 15:38'! testExample self assert: (self owner: 'Hans' object: 'computer' count: 1) = 'Hans owns 1 computer'. self assert: (self owner: 'Kurt' object: 'cow' count: 2) = 'Kurt owns 2 cows'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 6/10/2008 22:23'! testExample2 | owner object count | owner := 'Hans'. count := 1. object := 'computer'. self assert: '{owner} owns {count} {object asPluralBasedOn: count}' = 'Hans owns 1 computer'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 4/17/2008 14:53'! testInstVar instVar := 'abc'. self assert: '{instVar}' = 'abc'. self assert: 'x{instVar}' = 'xabc'. self assert: '{instVar}x' = 'abcx'. self assert: 'x{instVar}x' = 'xabcx'. instVar := 123. self assert: '{instVar}' = '123'. self assert: 'x{instVar}' = 'x123'. self assert: '{instVar}x' = '123x'. self assert: 'x{instVar}x' = 'x123x'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 4/17/2008 14:54'! testPlain self assert: 'abc' = 'abc'. self assert: 'abc' == 'abc'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 4/17/2008 15:11'! testSideEffect | x | self assert: '{x := 1}' = '1'. self assert: '{x := x + 1}' = '2'. self assert: '{x := x + 2}' = '4'! ! !CUInterpolateExample methodsFor: 'testing' stamp: 'lr 4/17/2008 14:54'! testTempVar | tempVar | tempVar := 'abc'. self assert: '{tempVar}' = 'abc'. self assert: 'x{tempVar}' = 'xabc'. self assert: '{tempVar}x' = 'abcx'. self assert: 'x{tempVar}x' = 'xabcx'. tempVar := 123. self assert: '{tempVar}' = '123'. self assert: 'x{tempVar}' = 'x123'. self assert: '{tempVar}x' = '123x'. self assert: 'x{tempVar}x' = 'x123x'! ! QQTestCase subclass: #CULintExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! CULintExample class instanceVariableNames: 'lintRules spellRules transformRules'! CULintExample class instanceVariableNames: 'lintRules spellRules transformRules'! !CULintExample class methodsFor: 'private' stamp: 'lr 4/26/2010 23:33'! buildLintRules | highlight | highlight := Array with: (CHHighlightAttribute new borderColorBottom: (CHHighlightAttribute wave: Color orange height: 3); borderWidthBottom: 3; outline: 2; yourself) with: (CHGutterAttribute warning). ^ (RBCompositeLintRule rulesFor: RBParseTreeLintRule) collect: [ :rule | [ :context | (rule matcher executeTree: context scopedTree initialAnswer: nil) ifNotNil: [ :node | context scopeNode: node with: nil visit: highlight ] ] fixTemps ]! ! !CULintExample class methodsFor: 'private' stamp: 'lr 4/2/2009 15:34'! buildSpellRules | class highlight | class := Smalltalk classNamed: #RBSpellChecker. class isNil ifTrue: [ ^ Array new ]. highlight := CHHighlightAttribute new borderColorBottom: (CHHighlightAttribute wave: Color red height: 3); borderWidthBottom: 3; outline: 2; yourself. ^ [ :context | (RBSpellChecker default check: context string) do: [ :word | | index | index := 0. [ index := context string findString: word startingAt: index + 1 caseSensitive: false. index > 0 ifTrue: [ context scopeFrom: index to: index + word size - 1 with: nil visit: highlight ]. index between: 1 and: context string size ] whileTrue ] ]! ! !CULintExample class methodsFor: 'private' stamp: 'lr 4/2/2009 15:34'! buildTransformRules | highlight | highlight := Array with: (CHHighlightAttribute new borderColorBottom: (CHHighlightAttribute wave: Color blue height: 3); borderWidthBottom: 3; outline: 2; yourself) with: (CHGutterAttribute warning). ^ (RBCompositeLintRule rulesFor: RBTransformationRule) gather: [ :rule | rule rewriteRule searches collect: [ :search | CHTreePattern new searchTree: search searchTree do: (Array with: highlight with: (CHClickAction new do: [ :context :model | ((rule setClass: context theClass; rewriteRule) executeTree: context node) ifTrue: [ context node replaceWith: rule rewriteRule tree. context tree printString ] ])) ] ]! ! !CULintExample class methodsFor: 'rules' stamp: 'lr 4/2/2009 13:13'! lintRules ^ lintRules ifNil: [ lintRules := self buildLintRules ]! ! !CULintExample class methodsFor: 'private' stamp: 'lr 4/2/2009 13:16'! reset lintRules := spellRules := transformRules := nil! ! !CULintExample class methodsFor: 'rules' stamp: 'lr 4/2/2009 13:13'! spellRules ^ spellRules ifNil: [ spellRules := self buildSpellRules ]! ! !CULintExample class methodsFor: 'rules' stamp: 'lr 4/2/2009 13:13'! transformRules ^ transformRules ifNil: [ transformRules := self buildTransformRules ]! ! !CULintExample methodsFor: 'examples' stamp: 'lr 4/2/2009 15:54'! crypticCode | x | x := 12. x > 0 ifTrue: [ x := 0 ]. x < 0 ifTrue: [ x := 0 ]. 1 <= x and: [ x <= 12 ]! ! !CULintExample methodsFor: 'examples' stamp: 'lr 4/2/2009 12:15'! selfAndSuper self asString. super asString! ! !CULintExample methodsFor: 'examples' stamp: 'lr 4/2/2009 13:33'! spellChecking ^ #( weighted wagted inefficient ineffiect immediately imidatly )! ! !CULintExample methodsFor: 'examples' stamp: 'lr 4/3/2009 17:39'! unknownMessage Object asNumber! ! !CULintExample methodsFor: 'examples' stamp: 'lr 4/2/2009 12:15'! yourselfMissing ^ OrderedCollection new add: 12; add: 13! ! QQTestCase subclass: #CURaisedToExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! !CURaisedToExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:13'! raise: aNode to: anInteger "self raise: ``(x) to: -5" anInteger = 0 ifTrue: [ ^ ``1 ]. anInteger = 1 ifTrue: [ ^ aNode ]. anInteger < 0 ifTrue: [ ^ ``(1 / `,(self raise: aNode to: anInteger abs)) ]. ^ ``(`,(self raise: aNode to: anInteger abs - 1) * `,aNode)! ! !CURaisedToExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:13'! transformRaisedTo ^ CHTreePattern new expression: '`@source raisedTo: `#literal' do: [ :context | context node swapWith: (self raise: context node receiver to: context node arguments first value) ]; yourself! ! !CURaisedToExample methodsFor: 'testing' stamp: 'lr 4/17/2008 11:48'! testMatch self assert: (2 raisedTo: -3) = (1/8). self assert: (2 raisedTo: -1) = (1/2). self assert: (2 raisedTo: 0) = 1. self assert: (2 raisedTo: 1) = 2. self assert: (2 raisedTo: 5) = 32. self assert: (2 raisedTo: 16) = 65536! ! !CURaisedToExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:44'! testParse self assert: (self class raise: ``(x) to: -3) = (self parse: '1 / (x * x * x)'). self assert: (self class raise: ``(x) to: -1) = (self parse: '1 / x'). self assert: (self class raise: ``(x) to: 0) = (self parse: '1'). self assert: (self class raise: ``(x) to: 1) = (self parse: 'x'). self assert: (self class raise: ``(x) to: 5) = (self parse: 'x * x * x * x * x')! ! !CURaisedToExample methodsFor: 'testing' stamp: 'lr 8/13/2008 13:42'! testSplice self assert: `@(self raise: 2 to: -3) = (1/8). self assert: `@(self raise: 2 to: -1) = (1/2). self assert: `@(self raise: 2 to: 0) = 1. self assert: `@(self raise: 2 to: 1) = 2. self assert: `@(self raise: 2 to: 5) = 32. self assert: `@(self raise: 2 to: 16) = 65536! ! !CURaisedToExample methodsFor: 'testing' stamp: 'lr 4/17/2008 11:48'! testTempVar | x | x := 2. self assert: (x raisedTo: -3) = (1/8). self assert: (x raisedTo: -1) = (1/2). self assert: (x raisedTo: 0) = 1. self assert: (x raisedTo: 1) = 2. self assert: (x raisedTo: 5) = 32. self assert: (x raisedTo: 16) = 65536! ! QQTestCase subclass: #CURegexExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! !CURegexExample class methodsFor: 'transformations' stamp: 'lr 4/2/2009 15:28'! transformRegex ^ Array with: (CHTreePattern new verification: [ :node | node receiver value isString ]; expression: '`#literal asRegex' do: [ :context | context node swapWith: context node receiver value asRegex lift ]; yourself) with: (CHTreePattern new verification: [ :node | node receiver value isString ]; expression: '`#literal asRegexIgnoringCase' do: [ :context | context node swapWith: context node receiver value asRegexIgnoringCase lift ]; yourself)! ! !CURegexExample methodsFor: 'testing' stamp: 'lr 4/17/2008 16:10'! testAsRegex | regex | regex := 'abc' asRegex. self assert: (thisContext method literals anySatisfy: [ :each | each = regex ])! ! !CURegexExample methodsFor: 'testing' stamp: 'lr 4/17/2008 16:10'! testAsRegexIgnoringCase | regex | regex := 'abc' asRegexIgnoringCase. self assert: (thisContext method literals anySatisfy: [ :each | each = regex ])! ! QQTestCase subclass: #CURomanExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! CURomanExample class instanceVariableNames: 'arabicToRoman romanToArabic'! CURomanExample class instanceVariableNames: 'arabicToRoman romanToArabic'! !CURomanExample class methodsFor: 'utilties' stamp: 'lr 3/18/2009 09:32'! arabicToRoman: anInteger "Convert an arabic integer to a roman string." | number roman | arabicToRoman isNil ifTrue: [ self initializeArabicToRoman ]. number := anInteger. roman := WriteStream on: String new. arabicToRoman do: [ :pair | [ number >= pair first ] whileTrue: [ roman nextPutAll: pair second. number := number - pair first ] ]. ^ roman contents! ! !CURomanExample class methodsFor: 'transformations' stamp: 'lr 4/2/2009 15:34'! highlightRoman ^ CHTreePattern new verification: [ :node | (self romanToArabic: node name) notNil ]; expression: '`var' do: (Array with: (CHHighlightAttribute new color: (Color black alpha: 0.25); yourself) with: Color black); yourself! ! !CURomanExample class methodsFor: 'initialization' stamp: 'lr 3/18/2009 09:32'! initializeArabicToRoman arabicToRoman := #((1000 'M') (900 'CM') (500 'D') (400 'CD') (100 'C') (90 'XC') (50 'L') (40 'XL') (10 'X') (9 'IX') (5 'V') (4 'IV') (1 'I'))! ! !CURomanExample class methodsFor: 'initialization' stamp: 'lr 3/18/2009 09:32'! initializeRomanToArabic romanToArabic := Dictionary new at: $I put: 1; at: $V put: 5; at: $X put: 10; at: $L put: 50; at: $C put: 100; at: $D put: 500; at: $M put: 1000; yourself! ! !CURomanExample class methodsFor: 'utilties' stamp: 'lr 3/18/2009 09:32'! romanToArabic: aString "Convert a roman string to an arabic integer, answer nil if not a roman number." | arabic last digit | romanToArabic isNil ifTrue: [ self initializeRomanToArabic ]. arabic := 0. last := 1000. aString do: [ :each | digit := romanToArabic at: each ifAbsent: [ ^ nil ]. last < digit ifTrue: [ arabic := arabic - (2 * last) ]. arabic := arabic + (last := digit) ]. ^ (self arabicToRoman: arabic) = aString ifTrue: [ arabic ]! ! !CURomanExample class methodsFor: 'transformations' stamp: 'lr 4/2/2009 15:28'! transformRoman ^ CHTreePattern new expression: '`var' do: [ :context | | arabic | arabic := self romanToArabic: context node name. arabic notNil ifTrue: [ context node swapWith: arabic lift ] ]; yourself! ! !CURomanExample methodsFor: 'testing' stamp: 'lr 3/18/2009 09:33'! testArithmetic self assert: CXXI + CXII = CCXXXIII. self assert: XVI + VII = XXIII. self assert: XVII - VI = XI. self assert: CXII * II = CCXXIV. self assert: CIV + VI = CX. self assert: MCMXCVI + XIV = MMX! ! !CURomanExample methodsFor: 'testing-utilities' stamp: 'lr 3/18/2009 09:33'! testConvert | roman arabic | 1 to: 4000 do: [ :each | roman := self class arabicToRoman: each. self assert: roman isString. self assert: roman notEmpty. arabic := self class romanToArabic: roman. self assert: arabic isInteger. self assert: arabic = each ]! ! !CURomanExample methodsFor: 'testing-utilities' stamp: 'lr 3/18/2009 09:33'! testInvalid | arabic | arabic := self class romanToArabic: 'A'. self assert: arabic isNil. arabic := self class romanToArabic: 'x'. self assert: arabic isNil! ! !CURomanExample methodsFor: 'testing' stamp: 'lr 3/18/2009 09:33'! testValues self assert: I = 1. self assert: II = 2. self assert: III = 3. self assert: IV = 4. self assert: V = 5! ! QQTestCase subclass: #CUSwapExample instanceVariableNames: 'i1 i2' classVariableNames: 'C1 C2' poolDictionaries: '' category: 'Cutie-Helvetia'! !CUSwapExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:05'! swap: a with: b "self astSwap: ``(x) with: ``(y)" ^ ``[ | temp | temp := `,a. `,a := `,b. `,b := temp ] body! ! !CUSwapExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:08'! transformAssign ^ CHTreePattern new expression: '{ `@.target } <== { `@.source }' do: [ :context | | source target | source := context @ '`@.source'. target := context @ '`@.target'. (source size = target size and: [ target allSatisfy: [ :each | each isVariable ] ]) ifTrue: [ | sequence | sequence := RBSequenceNode new. source with: target do: [ :expression :variable | sequence addNode: (RBAssignmentNode variable: variable value: expression) ]. context node swapWith: sequence ] ]; yourself! ! !CUSwapExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:05'! transformSwap ^ CHTreePattern new expression: '`source <==> `target' do: [ :context | context node swapWith: (self swap: context node receiver with: context node arguments first) ]; yourself! ! !CUSwapExample methodsFor: 'testing-assign' stamp: 'lr 12/14/2009 10:40'! testAssignClassVars { C1. C2 } <== { 1. 2 }. self assert: C1 = 1. self assert: C2 = 2! ! !CUSwapExample methodsFor: 'testing-assign' stamp: 'lr 12/14/2009 10:38'! testAssignInstVars { i1. i2 } <== { 1. 2 }. self assert: i1 = 1. self assert: i2 = 2! ! !CUSwapExample methodsFor: 'testing-assign' stamp: 'lr 12/14/2009 10:40'! testAssignTempVars | t1 t2 | { t1. t2 } <== { 1. 2 }. self assert: t1 = 1. self assert: t2 = 2! ! !CUSwapExample methodsFor: 'testing-swap' stamp: 'lr 12/14/2009 10:39'! testSwapClassVars C1 := 1. C2 := 2. C1 <==> C2. self assert: C1 = 2. self assert: C2 = 1! ! !CUSwapExample methodsFor: 'testing-swap' stamp: 'lr 12/14/2009 10:39'! testSwapInstVars i1 := 1. i2 := 2. i1 <==> i2. self assert: i1 = 2. self assert: i2 = 1! ! !CUSwapExample methodsFor: 'testing-swap' stamp: 'lr 12/14/2009 10:39'! testSwapTempVars | t1 t2 | t1 := 1. t2 := 2. t1 <==> t2. self assert: t1 = 2. self assert: t2 = 1! ! QQTestCase subclass: #CUTypeExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-Helvetia'! !CUTypeExample class methodsFor: 'private' stamp: 'lr 8/5/2008 14:06'! assert: anObject type: aClass name: aString "Assert anObject is of type aClass. Use aString to give the user an appropriate error message. Answer anObject." (anObject isKindOf: aClass) ifFalse: [ self error: aString , ' expected to be of type ' , aClass name ]. ^ anObject! ! !CUTypeExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:13'! transformArguments | type | ^ [ :context | context tree arguments reverseDo: [ :each | (type := self typeOf: each name) isNil ifFalse: [ context tree body addNodeFirst: ``(self class assert: `,each type: `,type name: `,(each name)) ] ] ]! ! !CUTypeExample class methodsFor: 'transformations' stamp: 'lr 4/26/2010 23:23'! transformReturn | pragma type | ^ CHConditionPattern new if: [ :context | (pragma := context pragmaNamed: #return:) notNil and: [ (type := self typeOf: pragma arguments first value) notNil ] ] then: (CHTreePattern new expression: '^ ``@expr'; at: '``@expr' do: [ :context | context node replaceWith: ``(self class assert: `,(context node) type: `,type name: 'return value') ])! ! !CUTypeExample class methodsFor: 'private' stamp: 'lr 4/26/2010 23:23'! typeOf: aString "Answer the class encoded in the given string. Prefixes and postfixes are corpped if possible. If no meaningful class is found, nil is returned." | start stop | start := aString findFirst: [ :each | each isUppercase ]. start isZero ifTrue: [ start := 1 ]. stop := aString findLast: [ :each | each isLetter ]. stop isZero ifTrue: [ stop := aString size ]. ^ start < stop ifTrue: [ Smalltalk classNamed: (aString copyFrom: start to: stop) ]! ! !CUTypeExample methodsFor: 'mocks' stamp: 'lr 8/5/2008 13:48'! + anInteger! ! !CUTypeExample methodsFor: 'mocks' stamp: 'lr 8/5/2008 13:49'! pnt: aPoint int: anInteger! ! !CUTypeExample methodsFor: 'mocks' stamp: 'lr 4/26/2010 23:23'! ret: aNumber aNumber negative ifTrue: [ ^ aNumber ] ifFalse: [ ^ aNumber negated ]! ! !CUTypeExample methodsFor: 'testing' stamp: 'lr 8/5/2008 14:44'! testBinaryMessage self + 123. self + 123 factorial. self should: [ self + 1.23 ] raise: Error! ! !CUTypeExample methodsFor: 'testing' stamp: 'lr 8/5/2008 14:44'! testKeywordMessage self pnt: 1 @ 2 int: 123. self pnt: 1 @ 2 int: 123 factorial. self should: [ self pnt: 1 int: 123 ] raise: Error. self should: [ self pnt: 1 @ 2 int: 1.23 ] raise: Error! ! !CUTypeExample methodsFor: 'testing' stamp: 'lr 8/5/2008 15:09'! testReturn self ret: 123. self ret: -123. self should: [ self ret: 1.23 ] raise: Error. self should: [ self ret: -1.23 ] raise: Error! ! CULindaTest initialize!