'From Squeak3.2 of 11 July 2002 [latest update: #4956] on 24 September 2002 at 3:53:26 pm'!
"Change Set:		TupleSmalltalk
Date:			24 September 2002
Author:			Gary T. Leavens

Tuples and a parser to support Tuple Smalltalk.

The parser understands the syntax
	expression ::= ( expression [ . expression ] ... [ . ] )
                     | ... other Squeak expressions ....

For example, (1 . 2 + 4 . 5 . 7), is compiled into code that
returns the tuple (1 . 6 . 5. 7).
One element tuple expressions are considered by the parser to be
just the same as the contained expression.  For example, the syntax
(541.) compiles into code that returns the number 541.

(There is no longer a need for the tuple with: method to be a no-op to
support this, it's done directly in the parser.)

To get this to work just file in this change set,
and then you can file in the TupleParsingTest.st class if you wish.

"!

ParseNode subclass: #NodeWithElements
	instanceVariableNames: 'elements sourceLocations emitNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!NodeWithElements commentStamp: 'GTL 9/24/2002 15:32' prior: 0!
An abstract superclass for forms with sequences of expressions inside.
Used for compiling and decompiling brace constructs.
!

NodeWithElements subclass: #BraceNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!BraceNode commentStamp: '<historical>' prior: 0!
Used for compiling and decompiling brace constructs.

These now compile into either a fast short form for 4 elements or less:
	Array braceWith: a with: b ... 
or a long form of indefinfite length:
	(Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray.

The erstwhile brace assignment form is no longer supported.!

BraceNode class
	instanceVariableNames: ''!

SequenceableCollection variableSubclass: #Tuple
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tuple-Smalltalk'!

!Tuple commentStamp: 'GTL 9/24/2002 15:32' prior: 0!
Tuples, for use in multiple dispatch.

E.g.,

	Tuple new: 0. 
	(Tuple new: 2) at: 1 put: 342; at: 2 put: 541; yourself.
	Tuple with: 99.
	Tuple with: 7 with: 9.
	(Tuple with: 0 with: 'hi' with: #there).
	(Tuple with: 0 with: 'hi' with: #there with: 99).
	(Tuple with: 0 with: 'hi' with: #there with: 99) classes asArray.

	Tuple withAll: #(3 4 5 6 7 8)

The following expressions can be used to test parsing of tuples.

	(541.)

	(3. 4 + 5) , 
	(3 + 7. 4 + 5.) , 
	(3 + 7 . 4 + 5 .) , 
	( 3 + 7 . 4 + 5 + 3)

	( 0 . 'hi'. #there) , 
	( 0 . 'hi'. #there . 99.)

  (3. 4. 5. 6. 7. 8.)

!

Tuple class
	instanceVariableNames: ''!
NodeWithElements subclass: #TupleNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!TupleNode commentStamp: 'GTL 9/23/2002 23:04' prior: 0!
Used for compiling and decompiling tuple constructs.

These now compile into either a fast short form for 4 elements or less:
	Tuple with: a with: b ... 
or a long form of indefinfite length:
	(Array tupleStream: N) nextPut: a; nextPut: b; ...; asTuple.

Tests:
| a |
a := Array new: 3.
a at: 1 put: (VariableNode new name: #x).
a at: 2 put: (VariableNode new name: #y).
a at: 3 put: (VariableNode new name: #z).
TupleNode new elements: a
	!

TestCase subclass: #TupleTest
	instanceVariableNames: 't0 t2 t3 t4 tmore '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tuple-Smalltalk'!

!TupleTest commentStamp: 'GTL 9/24/2002 00:31' prior: 0!
To test this class, execute

	TestRunner runTests

and then select this class from the tests menu; and the press the run button.
!


!NodeWithElements methodsFor: 'initialize-release' stamp: 'GTL 9/19/2002 14:53'!
elements: collection
	"Decompile."

	elements := collection! !

!NodeWithElements methodsFor: 'initialize-release' stamp: 'GTL 9/19/2002 14:52'!
elements: collection sourceLocations: locations
	"Compile."

	elements := collection.
	sourceLocations := locations! !

!NodeWithElements methodsFor: 'testing' stamp: 'GTL 9/19/2002 12:15'!
numElements

	^ elements size! !

!NodeWithElements methodsFor: 'printing' stamp: 'GTL 9/19/2002 17:45'!
printElementSeparatorOn: aStream
	"Print the separator string for this type of node, e.g., '.', on aStream"
	self subclassResponsibility
! !

!NodeWithElements methodsFor: 'printing' stamp: 'GTL 9/19/2002 12:19'!
printLeftOn: aStream
	"Print the left marker for this syntax (e.g., a left brace)."
	self subclassResponsibility! !

!NodeWithElements methodsFor: 'printing' stamp: 'GTL 9/19/2002 17:48'!
printOn: aStream indent: level

	self printLeftOn: aStream.
	1 to: elements size do: 
		[:i | (elements at: i) printOn: aStream indent: level.
		i < elements size ifTrue: [self printElementSeparatorOn: aStream.
															 aStream nextPut: $ ]].
	self printRightOn: aStream.! !

!NodeWithElements methodsFor: 'printing' stamp: 'GTL 9/19/2002 12:20'!
printRightOn: aStream
	"Print the right marker for this syntax (e.g., a right brace)."
	self subclassResponsibility! !

!NodeWithElements methodsFor: 'tiles' stamp: 'GTL 9/19/2002 14:53'!
asMorphicSyntaxIn: parent

	| row |

	row := (parent addRow: self leftSymbol on: self) layoutInset: 1.
	row addMorphBack: (StringMorph new contents: 
		(String streamContents: [:aStream | self printOn: aStream indent: 0])).
	^row
! !

!NodeWithElements methodsFor: 'tiles' stamp: 'GTL 9/19/2002 12:23'!
leftSymbol
	"Return the left symbol for use in the morphic syntax."
	self subclassResponsibility
! !

!NodeWithElements methodsFor: 'code generation' stamp: 'GTL 9/19/2002 14:50'!
convertToUnderlyingTypeSymbol
	"Return a symbol that is the name of a message 
	to convert an ArrayStream into the appropriate type for this node."
	self subclassResponsibility! !

!NodeWithElements methodsFor: 'code generation' stamp: 'GTL 9/19/2002 14:32'!
emitForValue: stack on: aStream

	^ emitNode emitForValue: stack on: aStream! !

!NodeWithElements methodsFor: 'code generation' stamp: 'GTL 9/19/2002 14:33'!
selectorForShortForm: nElements
	"Return nil or the short form selector for a node with nElements"
	self subclassResponsibility! !

!NodeWithElements methodsFor: 'code generation' stamp: 'GTL 9/19/2002 14:51'!
sizeForValue: encoder

	emitNode :=
   (elements size <= 4)
		ifTrue: ["Short form, e.g., Array braceWith: a with: b ... "
				MessageNode new
					receiver: (encoder encodeVariable: self underlyingTypeSymbol)
					selector: (self selectorForShortForm: elements size)
					arguments: elements precedence: 3 from: encoder]
		ifFalse: ["Long form, e.g., (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray"
				CascadeNode new
					receiver: (MessageNode new
								receiver: (encoder encodeVariable: #Array)
								selector: #braceStream:
								arguments: (Array with: (encoder encodeLiteral: elements size))
								precedence: 3 from: encoder)
					messages: ((elements collect: [:elt | MessageNode new receiver: nil
														selector: #nextPut:
														arguments: (Array with: elt)
														precedence: 3 from: encoder])
								copyWith: (MessageNode new receiver: nil
														selector: self convertToUnderlyingTypeSymbol
														arguments: (Array new)
														precedence: 1 from: encoder))].
	^ emitNode sizeForValue: encoder! !

!NodeWithElements methodsFor: 'code generation' stamp: 'GTL 9/19/2002 14:36'!
underlyingTypeSymbol
	"Return the symbol that names the type of elements to construct."
	self subclassResponsibility	! !


!BraceNode methodsFor: 'code generation' stamp: 'GTL 9/19/2002 14:59'!
convertToUnderlyingTypeSymbol
	^#braceArray! !

!BraceNode methodsFor: 'code generation' stamp: 'di 1/4/2000 11:24'!
selectorForShortForm: nElements

	nElements > 4 ifTrue: [^ nil].
	^ #(braceWithNone braceWith: braceWith:with:
			braceWith:with:with: braceWith:with:with:with:) at: nElements + 1! !

!BraceNode methodsFor: 'code generation' stamp: 'GTL 9/19/2002 15:00'!
underlyingTypeSymbol
	^#Array! !

!BraceNode methodsFor: 'printing' stamp: 'GTL 9/19/2002 17:46'!
printElementSeparatorOn: aStream
	aStream nextPut: $.
! !

!BraceNode methodsFor: 'printing' stamp: 'GTL 9/19/2002 14:55'!
printLeftOn: aStream

	aStream nextPut: ${! !

!BraceNode methodsFor: 'printing' stamp: 'GTL 9/19/2002 14:55'!
printRightOn: aStream

	aStream nextPut: $}! !

!BraceNode methodsFor: 'tiles' stamp: 'GTL 9/19/2002 14:57'!
leftSymbol
	^#brace! !


!Parser methodsFor: 'expression types' stamp: 'GTL 9/19/2002 18:34'!
emptyTupleExpression
	^TupleNode new elements: #()

	"()"
	! !

!Parser methodsFor: 'expression types' stamp: 'GTL 9/23/2002 23:51'!
primaryExpression 
	hereType == #word 
		ifTrue: 
			[parseNode _ self variable.
			(parseNode isUndefTemp and: [self interactive])
				ifTrue: [self queryUndefined].
			parseNode nowHasRef.
			^ true].
	hereType == #leftBracket
		ifTrue: 
			[self advance.
			self blockExpression.
			^true].
	hereType == #leftBrace
		ifTrue: 
			[self braceExpression.
			^true].
	hereType == #leftParenthesis
		ifTrue: 
			[self advance.
			(self match: #rightParenthesis)
				ifTrue: [parseNode _ self emptyTupleExpression.
								 ^true].
			self expression ifFalse: [^self expected: 'expression'].
			(self match: #rightParenthesis)
				ifFalse: [(self match: #period)
									ifTrue: [self restOfTupleExpression.
													 ^true].
									^self expected: 'right parenthesis or period'].
			^true].
	(hereType == #string or: [hereType == #number or: [hereType == #literal]])
		ifTrue: 
			[parseNode _ encoder encodeLiteral: self advance.
			^true].
	(here == #- and: [tokenType == #number])
		ifTrue: 
			[self advance.
			parseNode _ encoder encodeLiteral: self advance negated.
			^true].
	^false! !

!Parser methodsFor: 'expression types' stamp: 'GTL 9/24/2002 15:17'!
restOfTupleExpression
	" ( expression {. <expression>}* ) => TupleNode.
	  When started, this has already parsed the ( expression part,
	  and has matched the period."

	| elements locations loc more |
	elements _ OrderedCollection new.
	locations _ OrderedCollection new.
	"put the expression already parsed in the collection"
	elements addLast: parseNode.
	locations addLast: prevMark.
	more _ hereType ~~ #rightParenthesis.
	[more]
		whileTrue: 
			[loc _ hereMark + requestorOffset.
			self expression
				ifTrue: 
					[elements addLast: parseNode.
					locations addLast: loc]
				ifFalse:
					[^self expected: 'Variable or expression'].
			(self match: #period)
				ifTrue: [more _ hereType ~~ #rightParenthesis]
				ifFalse: [more _ false]].
	(elements size = 1)
		ifFalse: [parseNode _ TupleNode new elements: elements
																			  sourceLocations: locations]
		ifTrue: [parseNode _ elements at: 1].
	(self match: #rightParenthesis)
		ifFalse: [^self expected: 'Period or right parenthesis'].
	^true

	"(1 . 2 . 3)"! !


!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'GTL 9/23/2002 22:20'!
translateColor: aColorOrSymbol

	aColorOrSymbol isColor  ifTrue: [^ aColorOrSymbol].
	aColorOrSymbol == #comment  ifTrue: [^ Color blue lighter].
	aColorOrSymbol == #block  ifTrue: [^ Color r: 0.903 g: 1.0 b: 0.903].
	aColorOrSymbol == #method  ifTrue: [^ Color r: 0.903 g: 1.0 b: 0.903].
	aColorOrSymbol == #text  ifTrue: [^ Color r: 0.9 g: 0.9 b: 0.9].

	self noTileColor ifTrue: [^ Color r: 1.0 g: 0.839 b: 0.613].	"override"

	aColorOrSymbol == #assignment  ifTrue: [^ Color paleGreen].
	aColorOrSymbol == #keyword1  ifTrue: [^ Color paleBuff].	"binary"
	aColorOrSymbol == #keyword2  ifTrue: [^ Color paleBuff lighter].	"multipart" 
	aColorOrSymbol == #cascade  ifTrue: [^ Color paleYellow darker].	"has receiver"
	aColorOrSymbol == #cascade2  ifTrue: [^ Color paleOrange].	"one send in the cascade"
	aColorOrSymbol == #literal  ifTrue: [^ Color paleMagenta].
	aColorOrSymbol == #message  ifTrue: [^ Color paleYellow].
	aColorOrSymbol == #method  ifTrue: [^ Color white].
	aColorOrSymbol == #error  ifTrue: [^ Color red].
	aColorOrSymbol == #return  ifTrue: [^ Color lightGray].
	aColorOrSymbol == #variable  ifTrue: [^ Color paleTan].
	aColorOrSymbol == #brace  ifTrue: [^ Color paleOrange].
	aColorOrSymbol == #leftParenthesis  ifTrue: [^ Color paleOrange].
	aColorOrSymbol == #tempVariable  ifTrue: [^ Color paleYellow mixed: 0.75 with: Color paleGreen
		"Color yellow lighter lighter"].
	aColorOrSymbol == #blockarg2  ifTrue: [
			^ Color paleYellow mixed: 0.75 with: Color paleGreen].	"arg itself"
	aColorOrSymbol == #blockarg1  ifTrue: [^ Color paleRed].	"container"
		"yellow mixed: 0.5 with: Color white"

	^ Color tan	"has to be something!!"! !


!Tuple methodsFor: 'tuple support' stamp: 'GTL 9/23/2002 14:45'!
classes
	"Return a tuple of my classes."
	^self collect: [ :e | e class ]! !

!Tuple methodsFor: 'tuple support' stamp: 'GTL 9/23/2002 15:04'!
size
	"Return my size."
	^self basicSize! !


!Tuple class methodsFor: 'instance creation' stamp: 'GTL 9/19/2002 18:43'!
tupleWithNone
	^self new: 0! !

!Tuple class methodsFor: 'instance creation' stamp: 'GTL 9/24/2002 15:28'!
with: a 
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| tuple |
	tuple _ self new: 1.
	tuple at: 1 put: a.
	^ tuple! !

!Tuple class methodsFor: 'instance creation' stamp: 'GTL 9/19/2002 18:45'!
with: a with: b
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| tuple |
	tuple _ self new: 2.
	tuple at: 1 put: a.
	tuple at: 2 put: b.
	^ tuple! !

!Tuple class methodsFor: 'instance creation' stamp: 'GTL 9/19/2002 18:46'!
with: a with: b with: c
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| tuple |
	tuple _ self new: 3.
	tuple at: 1 put: a.
	tuple at: 2 put: b.
	tuple at: 3 put: c.
	^ tuple! !

!Tuple class methodsFor: 'instance creation' stamp: 'GTL 9/24/2002 00:07'!
with: a with: b with: c with: d
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| tuple |
	tuple _ self new: 4.
	tuple at: 1 put: a.
	tuple at: 2 put: b.
	tuple at: 3 put: c.
	tuple at: 4 put: d.
	^ tuple! !

!Tuple class methodsFor: 'instance creation' stamp: 'GTL 9/23/2002 14:48'!
withAll: anOrderedCollection
	"This method is used in compilation of tuple constructs.
	It MUST NOT be deleted or altered."

	| tuple siz |
	siz := anOrderedCollection size.
	tuple _ self new: siz.
	(1 to: siz) do: [ :i | tuple at: i put: (anOrderedCollection at: i)].
	^ tuple! !


!TupleNode methodsFor: 'code generation' stamp: 'GTL 9/19/2002 14:59'!
convertToUnderlyingTypeSymbol
	^#tupleArray! !

!TupleNode methodsFor: 'code generation' stamp: 'GTL 9/19/2002 17:19'!
selectorForShortForm: nElements

	nElements > 4 ifTrue: [^ nil].
	^ #(tupleWithNone with: with:with:
			with:with:with: with:with:with:with:) at: nElements + 1! !

!TupleNode methodsFor: 'code generation' stamp: 'GTL 9/19/2002 18:37'!
underlyingTypeSymbol
	^#Tuple! !

!TupleNode methodsFor: 'printing' stamp: 'GTL 9/23/2002 23:03'!
printElementSeparatorOn: aStream
	aStream nextPutAll: '.'
! !

!TupleNode methodsFor: 'printing' stamp: 'GTL 9/19/2002 14:55'!
printLeftOn: aStream

	aStream nextPut: $(! !

!TupleNode methodsFor: 'printing' stamp: 'GTL 9/19/2002 14:55'!
printRightOn: aStream

	aStream nextPut: $)! !

!TupleNode methodsFor: 'tiles' stamp: 'GTL 9/19/2002 17:56'!
leftSymbol
	^#leftParenthesis! !


!TupleTest methodsFor: 'Testing' stamp: 'GTL 9/24/2002 15:31'!
testClassMethodsAndSize
	"Test the class methods and the method size for tuples.
	 Note that setUp has already made
	some tuples with these."

	self assert: (t0 size = 0).
	self assert: (t2 size = 2).
	self assert: ((t2 at: 1) = 342).
	self assert: ((t2 at: 2) = 541).
	self assert: (t3 size = 3).
	self assert: ((t3 at: 1) = 541).
	self assert: ((t3 at: 2) = '342').
	self assert: ((t3 at: 3) = #(641)).
	self assert: (t4 size = 4).
	self assert: (tmore size = 7).
	self assert: ((tmore at: 3) = #tuple).

	"Tuples of length 1 are now considered tuples,
	and no longer have to be hacked to help the parser."
	self assert: ((Tuple with: 99.) isKindOf: Tuple).
	self assert: ((Tuple with: 99 ) size = 1).
	self assert: (((Tuple with: 99) at: 1) = 99).

	"Also a tuple of length 1 can be formed using withAll:"
	self assert: ((Tuple withAll: #(99)) isKindOf: Tuple).
	self assert: (((Tuple withAll: #(99)) at: 1) = 99).
	self assert: ((Tuple withAll: #(99)) asArray = #(99)).
	! !

!TupleTest methodsFor: 'Testing' stamp: 'GTL 9/24/2002 01:15'!
testClasses

	self assert: (t0 classes = t0).
	self assert: (t2 classes asArray = {SmallInteger. SmallInteger}).
	self assert: (t3 classes asArray = {SmallInteger. String. Array}).
	"self assert:
	 (t4 classes = Tuple with: Symbol with: Symbol with: Symbol with: String)."
! !

!TupleTest methodsFor: 'Testing' stamp: 'GTL 9/24/2002 01:30'!
testEquals

	self assert: (t0 = t0).
	self assert: (t2 = t2).
	self assert: (t3 = t3).
	self assert: (t4 = t4).
	self assert: (tmore = tmore).
	self deny: (t0 = t2).
	self deny: (t2 = t3).
	self assert: (t2 = (Tuple with: 342 with: 541)).
	self deny: (t2 = (Tuple with: #yzzy with: #abcde)).

	self assert: 
		(Tuple with: #xyzzy with: #abcde) = (Tuple with: #xyzzy with: #abcde).
	self deny:
		 (Tuple with: #abcde with: #abcde) = (Tuple with: #xyzzy with: #abcde).
	self deny:
		 (Tuple with: #abcde with: #xyzzy) = (Tuple with: #xyzzy with: #abcde).! !

!TupleTest methodsFor: 'Running' stamp: 'GTL 9/24/2002 00:36'!
setUp
	t0 := Tuple tupleWithNone.
	t2 := Tuple with: 342 with: 541.
	t3 := Tuple with: 541 with: '342' with: #(641).
	t4 := Tuple with: #a with: #b with: #c with: 'd'.
	tmore := Tuple withAll: #(a good tuple is here today 'hooray!!')
! !


!WriteStream methodsFor: 'private' stamp: 'GTL 9/23/2002 22:09'!
tupleArray
	"This method is used in compilation of tuple constructs.
	It MUST NOT be deleted or altered."

	^ Tuple withAll: collection! !

!WriteStream methodsFor: 'private' stamp: 'GTL 9/23/2002 22:09'!
tupleArray: anArray
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	self braceArray: anArray! !

BraceNode removeSelector: #asMorphicSyntaxIn:!
BraceNode removeSelector: #elements:!
BraceNode removeSelector: #elements:sourceLocations:!
BraceNode removeSelector: #emitForValue:on:!
BraceNode removeSelector: #printOn:indent:!
BraceNode removeSelector: #sizeForValue:!