VM Maker: VMMaker-dtl.338.mcz

 
David T. Lewis uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-dtl.338.mcz

==================== Summary ====================

Name: VMMaker-dtl.338
Author: dtl
Time: 20 January 2014, 7:13:23.86 pm
UUID: 29946156-9015-45c9-83a2-c12d43f67ece
Ancestors: VMMaker-dtl.337

VMMaker 4.12.14

C translation updates from oscog required for case statement code generation, e.g. shorten:toIndexableSize code generation.

Add shorten:toIndexableSize from oscog, presumed working for NewObjectMemory but not verified for ClassicObjectMemory

=============== Diff against VMMaker-dtl.337 ===============

Item was added:
+ ----- Method: BlockNode>>isPotentialCCaseLabel:in: (in category '*VMMaker-C translation') -----
+ isPotentialCCaseLabel: stmt in: aTMethod
+ (stmt isVariableNode
+ or: [stmt isLiteralNode
+ and: [stmt isConstantNumber or: [stmt literalValue isSymbol]]]) ifTrue:
+ [^true].
+ stmt isMessageNode ifTrue:
+ [| selector method |
+ selector := stmt selector key.
+ (#(* + -) includes: selector) ifTrue:
+ [^(self isPotentialCCaseLabel: stmt receiver in: aTMethod)
+   and: [self isPotentialCCaseLabel: stmt arguments first in: aTMethod]].
+
+ (selector = #asSymbol
+  and: [stmt receiver isLiteralNode
+  and: [stmt receiver literalValue isSymbol]]) ifTrue:
+ [^true].
+
+ (stmt arguments isEmpty
+  and: [method := (aTMethod definingClass whichClassIncludesSelector: selector) >> selector.
+   (method isQuick
+ or: [(method literalAt: 1) isInteger
+ and: [method numLiterals = 3]])
+   and: [(aTMethod definingClass basicNew perform: selector) isInteger]]) ifTrue:
+ [^true]].
+ ^false!

Item was added:
+ ----- Method: BlockNode>>isPotentialCCaseLabelIn: (in category '*VMMaker-C translation') -----
+ isPotentialCCaseLabelIn: aTMethod
+ | stmt |
+ statements size ~= 1 ifTrue: [^false].
+ stmt := statements first.
+ ^self isPotentialCCaseLabel: stmt in: aTMethod!

Item was added:
+ ----- Method: BraceNode>>asTranslatorNodeIn: (in category '*VMMaker-C translation') -----
+ asTranslatorNodeIn: aTMethod
+ "make a CCodeGenerator equivalent of me"
+ self assert: (elements allSatisfy:
+ [:elem|
+ elem isMessageNode
+ and: [elem selector key = #->
+ and: [elem receiver isBlockNode
+ and: [elem arguments first isBlockNode
+ and: [elem receiver isPotentialCCaseLabelIn: aTMethod]]]]]).
+ ^TBraceCaseNode new
+ caseLabels: (elements collect: [:elem| elem receiver asTranslatorNodeIn: aTMethod]);
+ cases: (elements collect: [:elem| elem arguments first asTranslatorNodeIn: aTMethod]);
+ comment: comment!

Item was added:
+ ----- Method: CCodeGenerator>>isBuiltinSelector: (in category 'utilities') -----
+ isBuiltinSelector: sel
+ "Answer true if the given selector is one of the builtin selectors."
+
+ ^(self isKernelSelector: sel) or: [translationDict includesKey: sel]!

Item was added:
+ ----- Method: CCodeGenerator>>isKernelSelector: (in category 'utilities') -----
+ isKernelSelector: sel
+ "Answer true if the given selector is one of the kernel selectors that are implemented as macros."
+
+ ^(#(error:
+ oopAt: oopAt:put: oopAtPointer: oopAtPointer:put:
+ byteAt: byteAt:put: byteAtPointer: byteAtPointer:put:
+ shortAt: shortAt:put: shortAtPointer: shortAtPointer:put:
+ intAt: intAt:put: intAtPointer: intAtPointer:put:
+ longAt: longAt:put: longAtPointer: longAtPointer:put:
+ longLongAt: longLongAt:put: longLongAtPointer: longLongAtPointer:put:
+ fetchFloatAt:into: storeFloatAt:from:
+ fetchFloatAtPointer:into: storeFloatAtPointer:from:
+ fetchSingleFloatAt:into: storeSingleFloatAt:from:
+ fetchSingleFloatAtPointer:into: storeSingleFloatAtPointer:from:
+ pointerForOop: oopForPointer:
+ cCoerce:to: cCoerceSimple:to:)
+ includes: sel)!

Item was added:
+ ----- Method: ClassicObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
+ shorten: obj toIndexableSize: nSlots
+ "Currently this works for pointer objects only, and is almost certainly wrong for 64 bits."
+ | deltaBytes desiredLength fixedFields fmt hdr totalLength |
+ (self isPointersNonInt: obj) ifFalse:
+ [^obj].
+ hdr := self baseHeader: obj.
+ fmt := self formatOfHeader: hdr.
+ totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
+ fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
+
+ self cCode: '  printf("fixedFields is %d\n", fixedFields); fflush(stdout)  '.
+ self cCode: '  printf("nSlots is %d\n", nSlots); fflush(stdout)  '.
+
+ desiredLength := fixedFields + nSlots.
+ deltaBytes := (totalLength - desiredLength) * self bytesPerWord.
+
+ self cCode: '  printf("desiredLength is %d\n", desiredLength); fflush(stdout)  '.
+ self cCode: '  printf("deltaBytes is %d\n", deltaBytes); fflush(stdout)  '.
+
+ self setSizeOfFree: obj + self baseHeaderSize + (desiredLength * self bytesPerWord)
+ to: deltaBytes.
+ (self headerType: obj) caseOf: {
+ [HeaderTypeSizeAndClass] ->
+ [
+ self cCode: '  printf("HeaderTypeSizeAndClass\n"); fflush(stdout)  '.
+
+ self longAt: obj put: hdr - deltaBytes].
+ [HeaderTypeClass] ->
+ [
+ self cCode: '  printf("HeaderTypeClass\n"); fflush(stdout)  '.
+
+ self longAt: obj put: ((hdr bitClear: self sizeMask) bitOr: (hdr bitAnd: self sizeMask) - deltaBytes)].
+ [HeaderTypeShort] ->
+ [
+ self cCode: '  printf("HeaderTypeShort\n"); fflush(stdout)  '.
+
+ self longAt: obj put: ((hdr bitClear: self sizeMask) bitOr: (hdr bitAnd: self sizeMask) - deltaBytes)] }.
+ ^obj!

Item was added:
+ ----- Method: NewObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
+ shorten: obj toIndexableSize: nSlots
+ "Currently this works for pointer objects only, and is almost certainly wrong for 64 bits."
+ | deltaBytes desiredLength fixedFields fmt hdr totalLength |
+ (self isPointersNonImm: obj) ifFalse:
+ [^obj].
+ hdr := self baseHeader: obj.
+ fmt := self formatOfHeader: hdr.
+ totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
+ fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
+ desiredLength := fixedFields + nSlots.
+ deltaBytes := (totalLength - desiredLength) * self bytesPerWord.
+ obj + self baseHeaderSize + (totalLength * self bytesPerWord) = freeStart
+ ifTrue: "Shortening the last object.  Need to reduce freeStart."
+ [self maybeFillWithAllocationCheckFillerFrom: obj + self baseHeaderSize + (desiredLength * self bytesPerWord) to: freeStart.
+ freeStart := obj + self baseHeaderSize + (desiredLength * self bytesPerWord)]
+ ifFalse: "Shortening some interior object.  Need to create a free block."
+ [self setSizeOfFree: obj + self baseHeaderSize + (desiredLength * self bytesPerWord)
+ to: deltaBytes].
+ (self headerType: obj) caseOf: {
+ [HeaderTypeSizeAndClass] ->
+ [self longAt: obj put: hdr - deltaBytes].
+ [HeaderTypeClass] ->
+ [self longAt: obj put: ((hdr bitClear: self sizeMask) bitOr: (hdr bitAnd: self sizeMask) - deltaBytes)].
+ [HeaderTypeShort] ->
+ [self longAt: obj put: ((hdr bitClear: self sizeMask) bitOr: (hdr bitAnd: self sizeMask) - deltaBytes)] }.
+ ^obj!

Item was added:
+ ----- Method: ObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
+ shorten: obj toIndexableSize: nSlots
+ "Shorten the length of a pointer object to nSlots, marking free memory and adjusting
+ end of memory as required."
+
+ self subclassResponsibility!

Item was added:
+ ----- Method: TAssignmentNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ variable nodesDo: aBlock parent: self.
+ expression nodesDo: aBlock parent: self.
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TAssignmentNode>>structTargetKindIn: (in category 'testing') -----
+ structTargetKindIn: aCodeGen
+ "Answer if the recever evaluates to a struct or struct pointer
+ and hence can be dereferenced using . or ->.  Answer any of
+ #struct #pointer or nil"
+ ^variable structTargetKindIn: aCodeGen!

Item was added:
+ TParseNode subclass: #TBraceCaseNode
+ instanceVariableNames: 'caseLabels cases'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Translation to C'!

Item was added:
+ ----- Method: TBraceCaseNode>>bindVariableUsesIn: (in category 'transformations') -----
+ bindVariableUsesIn: aDictionary
+
+ caseLabels := caseLabels collect: [:node| node bindVariableUsesIn: aDictionary].
+ cases := cases collect: [:node| node bindVariableUsesIn: aDictionary]!

Item was added:
+ ----- Method: TBraceCaseNode>>bindVariableUsesIn:andConstantFoldIf:in: (in category 'transformations') -----
+ bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen
+ "Answer either the receiver, if it contains no references to the given variables, or a new node with the given variables rebound."
+ | newCaseLabels newCases |
+ newCaseLabels := caseLabels collect: [:node| node bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen].
+ newCases := cases collect: [:node| node bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen].
+ ^(newCaseLabels = caseLabels
+   and: [newCases = cases])
+ ifTrue: [self]
+ ifFalse: [self shallowCopy
+ caseLabels: newCaseLabels;
+ cases: newCases;
+ yourself]!

Item was added:
+ ----- Method: TBraceCaseNode>>bindVariablesIn: (in category 'transformations') -----
+ bindVariablesIn: aDictionary
+
+ caseLabels := caseLabels collect: [:node| node bindVariablesIn: aDictionary].
+ cases := cases collect: [:node| node bindVariablesIn: aDictionary]!

Item was added:
+ ----- Method: TBraceCaseNode>>caseLabels (in category 'accessing') -----
+ caseLabels
+ "Answer the value of caseLabels"
+
+ ^ caseLabels!

Item was added:
+ ----- Method: TBraceCaseNode>>caseLabels: (in category 'accessing') -----
+ caseLabels: anObject
+ "Set the value of caseLabels"
+
+ caseLabels := anObject!

Item was added:
+ ----- Method: TBraceCaseNode>>cases (in category 'accessing') -----
+ cases
+ "Answer the value of cases"
+
+ ^ cases!

Item was added:
+ ----- Method: TBraceCaseNode>>cases: (in category 'accessing') -----
+ cases: anObject
+ "Set the value of cases"
+
+ cases := anObject!

Item was added:
+ ----- Method: TBraceCaseNode>>copyTree (in category 'copying') -----
+ copyTree
+
+ self flag: #FIXME. "adopt from oscog - get rid of copyTree,  use postCopy instead"
+ ^self copy
+ !

Item was added:
+ ----- Method: TBraceCaseNode>>nodesDo: (in category 'enumerating') -----
+ nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
+ caseLabels do:
+ [:node| node nodesDo: aBlock].
+ cases do:
+ [:node| node nodesDo: aBlock].
+ aBlock value: self!

Item was added:
+ ----- Method: TBraceCaseNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ caseLabels do:
+ [:node| node nodesDo: aBlock parent: self.].
+ cases do:
+ [:node| node nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TBraceCaseNode>>nodesDo:unless: (in category 'enumerating') -----
+ nodesDo: aBlock unless: cautionaryBlock
+
+ (cautionaryBlock value: self) ifTrue: [^self].
+ caseLabels do:
+ [:node| node nodesDo: aBlock unless: cautionaryBlock].
+ cases do:
+ [:node| node nodesDo: aBlock unless: cautionaryBlock].
+ aBlock value: self!

Item was added:
+ ----- Method: TBraceCaseNode>>replaceNodesIn: (in category 'enumerating') -----
+ replaceNodesIn: aDictionary
+
+ ^aDictionary at: self ifAbsent: [
+ caseLabels := caseLabels collect: [:node| node replaceNodesIn: aDictionary].
+ cases := cases collect: [:node| node replaceNodesIn: aDictionary].
+ self]!

Item was added:
+ ----- Method: TCaseStmtNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ expression nodesDo: aBlock parent: self.
+ cases do: [:c| c nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TConstantNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TGoToNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TLabeledCommentNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ aBlock value: self value: parent!

Item was changed:
  Object subclass: #TMethod
+ instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels possibleSideEffectsCache complete export static sharedLabel sharedCase comment definingClass globalStructureBuildMethodHasFoo canAsmLabel mustAsmLabel properties cascadeVariableNumber extraVariableNumber'
- instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels possibleSideEffectsCache complete export static sharedLabel sharedCase comment definingClass globalStructureBuildMethodHasFoo canAsmLabel mustAsmLabel properties cascadeVariableNumber'
  classVariableNames: 'CaseStatements'
  poolDictionaries: ''
  category: 'VMMaker-Translation to C'!
 
  !TMethod commentStamp: 'dtl 9/15/2008 09:06' prior: 0!
  A TMethod is a translation method, representing a MethodNode that is to be translated to C source. It has a parseTree of translation nodes that mirrors the parse tree of the corresponding Smalltalk method.!

Item was added:
+ ----- Method: TMethod>>buildSwitchStmt:parent: (in category 'transformations') -----
+ buildSwitchStmt: aSendNode parent: parentNode
+ "Build a switch statement node for the given send of caseOf: or caseOf:otherwise:."
+ | switch |
+ switch := TSwitchStmtNode new
+ expression: aSendNode receiver
+ cases: aSendNode args first
+ otherwiseOrNil: (aSendNode args at: 2 ifAbsent: [nil]).
+ (aSendNode receiver isVariable or: [parentNode isStmtList]) ifFalse:
+ [switch switchVariable: (locals add: (self extraVariableName: 'switch'))].
+ ^switch!

Item was changed:
+ ----- Method: TMethod>>endsWithReturn (in category 'testing') -----
- ----- Method: TMethod>>endsWithReturn (in category 'inlining support') -----
  endsWithReturn
  "Answer true if the last statement of this method is a return."
 
+ ^parseTree endsWithReturn!
- ^ parseTree statements last isReturn!

Item was added:
+ ----- Method: TMethod>>isStructAccessor (in category 'testing') -----
+ isStructAccessor
+ ^[definingClass isAccessor: selector]
+ on: MessageNotUnderstood
+ do: [:ex| false]!

Item was changed:
  ----- Method: TMethod>>prepareMethodIn: (in category 'transformations') -----
  prepareMethodIn: aCodeGen
  "Record sends of builtin operators, map sends of the special selector dispatchOn:in:
  with case statement nodes, and map sends of caseOf:[otherwise:] to switch statements.
- Note: Only replaces top-level sends of dispatchOn:in: et al and caseOf:[otherwise:].
- These must be top-level statements; they cannot appear in expressions.
  As a hack also update the types of variables introduced to implement cascades correctly.
+ This has to be done at the same time as this is done, so why not piggy back here?"
+ extraVariableNumber ifNotNil:
- This has to be done at teh same time as this is done, so why not piggy back here?"
- | replacements |.
- cascadeVariableNumber ifNotNil:
  [declarations keysAndValuesDo:
  [:varName :decl|
  decl isBlock ifTrue:
  [self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]).
  locals add: varName.
  self declarationAt: varName
  put: (decl value: self value: aCodeGen), ' ', varName]]].
- replacements := IdentityDictionary new.
  aCodeGen
  pushScope: declarations
+ while:"N.B.  nodesWithParentsDo: is bottom-up, hence replacement is destructive and conserved."
+ [parseTree nodesWithParentsDo:
+ [:node :parent|
- while:
- [parseTree nodesDo:
- [:node|
  node isSend ifTrue:
+ [(aCodeGen isBuiltinSelector: node selector)
- [(aCodeGen builtin: node selector)
  ifTrue:
  [node isBuiltinOperator: true.
  "If a to:by:do:'s limit has side-effects, declare the limit variable, otherwise delete it from the args"
  (node selector = #to:by:do:
   and: [node args size = 4]) ifTrue:
  [| limitExpr |
  limitExpr := node args first.
  (limitExpr anySatisfy:
  [:subNode|
  subNode isSend
+ and: [(aCodeGen isBuiltinSelector: subNode selector) not
+ and: [(subNode isStructSendIn: aCodeGen) not]]])
- and: [(aCodeGen builtin: subNode selector) not
- and: [(subNode isStructSend: aCodeGen) not]]])
  ifTrue: [ | limitVar |
  limitVar := node args last name.
  "n.b. Two loops in the same method may share the same variable
  for loop limit, so add the variable declaration only if not already
  declared by a previous loop. Assumes that the name of the loop
  limit variable (e.g. 'iLimiT') is unlikely to have been used as an actual
  instance variable elsewhere."
  (locals includes: limitVar) ifFalse: [locals add: limitVar]]
  ifFalse:
  [node arguments: node args allButLast]]]
  ifFalse:
  [(CaseStatements includes: node selector) ifTrue:
+ [parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildCaseStmt: node})].
- [replacements at: node put: (self buildCaseStmt: node)].
  (#(caseOf: #caseOf:otherwise:) includes: node selector) ifTrue:
+ [parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildSwitchStmt: node parent: parent })]]]]]!
- [replacements at: node put: (self buildSwitchStmt: node)]]].
- ((node isAssignment or: [node isReturn])
-  and: [node expression isSwitch]) ifTrue:
- [replacements at: node put: (self transformSwitchExpression: node)]]].
- replacements isEmpty ifFalse:
- [parseTree := parseTree replaceNodesIn: replacements]!

Item was added:
+ ----- Method: TParseNode>>endsWithReturn (in category 'testing') -----
+ endsWithReturn
+
+ ^false!

Item was added:
+ ----- Method: TParseNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ self subclassResponsibility!

Item was added:
+ ----- Method: TParseNode>>nodesWithParentsDo: (in category 'enumerating') -----
+ nodesWithParentsDo: aBlock
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ self nodesDo: aBlock parent: nil!

Item was added:
+ ----- Method: TParseNode>>structTargetKindIn: (in category 'testing') -----
+ structTargetKindIn: aCodeGen
+ "Answer if the recever evaluates to a struct or struct pointer
+ and hence can be dereferenced using . or ->.  Answer any of
+ #struct #pointer or nil"
+ ^nil!

Item was added:
+ ----- Method: TReturnNode>>endsWithReturn (in category 'testing') -----
+ endsWithReturn
+
+ ^true!

Item was added:
+ ----- Method: TReturnNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ expression nodesDo: aBlock parent: self.
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TSendNode>>endsWithReturn (in category 'testing') -----
+ endsWithReturn
+ ^self isReturningIf!

Item was added:
+ ----- Method: TSendNode>>isStructSendIn: (in category 'testing') -----
+ isStructSendIn: aCodeGen
+ "Answer if the recever is a send of a structure accessor.
+ This is tricky.  We want
+ foo bar => foo->bar
+ foo bar => foo.bar
+ foo bar: expr => foo->bar = expr
+ foo bar: expr => foo.bar = expr
+ depending on whether foo is a struct or a pointer to a struct,
+ but only if both foo is a struct type and bar is a field accessor.
+ The tricky cases are self-sends within struct class methods.  Here we need to
+ distinguish between self-sends of ordinary methods from self sends of accessors."
+ ^arguments size <= 1
+   and: [(receiver structTargetKindIn: aCodeGen) notNil
+   and: [(aCodeGen methodNamed: selector)
+ ifNil: [false]
+ ifNotNil: [:method| method isStructAccessor]]]!

Item was added:
+ ----- Method: TSendNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ receiver nodesDo: aBlock parent: self.
+ arguments do: [:arg| arg nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TSendNode>>structTargetKindIn: (in category 'testing') -----
+ structTargetKindIn: aCodeGen
+ "Answer if the recever evaluates to a struct or struct pointer
+ and hence can be dereferenced using . or ->.  Answer any of
+ #struct #pointer or nil.  Right now we don't need or support
+ structure return so this method answers either #pointer or nil."
+ selector == #cCoerceSimple:to: ifTrue:
+ [^(VMStructType isTypePointerToStruct: arguments last value) ifTrue:
+ [#pointer]].
+
+ selector == #addressOf: ifTrue:
+ [^#pointer].
+
+ selector == #at: ifTrue:
+ [receiver isVariable ifTrue:
+ [(aCodeGen typeOfVariable: receiver name) ifNotNil:
+ [:type| | derefType |
+ type last = $* ifFalse:
+ [^receiver structTargetKindIn: aCodeGen].
+ (VMStructType isTypeStruct: (aCodeGen
+ extractTypeFor: receiver name
+ fromDeclaration: type allButLast)) ifTrue:
+ [^#struct]]].
+ (receiver structTargetKindIn: aCodeGen) ifNotNil:
+ [:kind| ^kind]].
+
+ (aCodeGen selectorReturnsPointerToStruct: selector) ifTrue:
+ [^#pointer].
+
+ (aCodeGen selectorReturnsStruct: selector) ifTrue:
+ [^#struct].
+
+ ^nil!

Item was added:
+ ----- Method: TStmtListNode>>endsWithReturn (in category 'testing') -----
+ endsWithReturn
+ "Answer true if the last statement of this lock is a return."
+
+ ^statements last isReturn or: [statements last isReturningIf]!

Item was added:
+ ----- Method: TStmtListNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ statements do: [:s| s nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!

Item was added:
+ TParseNode subclass: #TSwitchStmtNode
+ instanceVariableNames: 'expression cases otherwiseOrNil switchVariable'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Translation to C'!
+
+ !TSwitchStmtNode commentStamp: '<historical>' prior: 0!
+ I implement a Smalltalk
+ foo caseOf: { [IntegerConstant | GlobalVariable] -> [expr] }
+ statement converting it into a C switch statement.  I make some effort to discover identical right-hand-side cases.!

Item was added:
+ ----- Method: TSwitchStmtNode>>bindVariableUsesIn: (in category 'transformations') -----
+ bindVariableUsesIn: aDictionary
+ expression := expression bindVariableUsesIn: aDictionary.
+ cases := (cases collect:
+ [:pair| "<Array with: <Array with: ParseTreeNode> with: TStmtListNode"
+ { pair first collect: [:labelNode| labelNode bindVariableUsesIn: aDictionary].
+   pair last bindVariableUsesIn: aDictionary }]).
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil := otherwiseOrNil bindVariableUsesIn: aDictionary]!

Item was added:
+ ----- Method: TSwitchStmtNode>>bindVariableUsesIn:andConstantFoldIf:in: (in category 'transformations') -----
+ bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen
+ "Answer either the receiver, if it contains no references to the given variables, or a new node with the given variables rebound."
+ | newExpression newCases newOtherwise |
+ newExpression := expression bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen.
+ newCases := cases collect:
+ [:pair| "<Array with: <Array with: ParseTreeNode> with: TStmtListNode"
+ { pair first collect: [:labelNode| labelNode bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen].
+   pair last bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen}].
+ newOtherwise := otherwiseOrNil ifNotNil:
+ [otherwiseOrNil bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen].
+ ^(newExpression = expression
+   and: [newCases = cases
+   and: [newOtherwise = otherwiseOrNil]])
+ ifTrue: [self]
+ ifFalse:
+ [self shallowCopy
+ expression: newExpression;
+ cases: newCases;
+ otherwiseOrNil: newOtherwise;
+ yourself]!

Item was added:
+ ----- Method: TSwitchStmtNode>>bindVariablesIn: (in category 'transformations') -----
+ bindVariablesIn: aDictionary
+ expression := expression bindVariablesIn: aDictionary.
+ cases := (cases collect:
+ [:pair| "<Array with: <Array with: ParseTreeNode> with: TStmtListNode"
+ { pair first collect: [:labelNode| labelNode bindVariablesIn: aDictionary].
+   pair last bindVariablesIn: aDictionary }]).
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil := otherwiseOrNil bindVariablesIn: aDictionary]!

Item was added:
+ ----- Method: TSwitchStmtNode>>cases (in category 'accessing') -----
+ cases
+ "Answer the value of cases"
+
+ ^ cases!

Item was added:
+ ----- Method: TSwitchStmtNode>>cases: (in category 'accessing') -----
+ cases: anObject
+ "Set the value of cases"
+
+ cases := anObject!

Item was added:
+ ----- Method: TSwitchStmtNode>>copyTree (in category 'copying') -----
+ copyTree
+
+ self flag: #FIXME. "adopt from oscog - get rid of copyTree,  use postCopy instead"
+ ^self copy
+ !

Item was added:
+ ----- Method: TSwitchStmtNode>>createCasesFromBraceNode: (in category 'instance initialization') -----
+ createCasesFromBraceNode: aTBraceNode
+ | casesToStrings stringsToLabels newCases |
+ casesToStrings := Dictionary new.
+ stringsToLabels := Dictionary new.
+ newCases := OrderedCollection new: aTBraceNode caseLabels size.
+ aTBraceNode caseLabels with: aTBraceNode cases do:
+ [:label :case| | printString |
+ printString := casesToStrings at: case put: case printString.
+ (stringsToLabels at: printString ifAbsentPut: [OrderedCollection new]) addLast: label].
+
+ aTBraceNode caseLabels with: aTBraceNode cases do:
+ [:label :case| | printString labels |
+ printString := casesToStrings at: case.
+ label = (labels := (stringsToLabels at: printString) asArray) first ifTrue:
+ [newCases addLast: { labels collect: [:ea| ea statements first]. case}]].
+
+ ^newCases!

Item was added:
+ ----- Method: TSwitchStmtNode>>emitCCodeAsExpressionOn:level:generator: (in category 'C code generation') -----
+ emitCCodeAsExpressionOn: aStream level: level generator: aCodeGen
+ "Emit the receiver as an if-the-else chain."
+ | varName n |
+ self assert: (expression isVariable or: [switchVariable notNil]).
+ aStream nextPut: $(.
+ switchVariable
+ ifNil: [varName := String streamContents: [:s| expression emitCCodeOn: s level: 0 generator: aCodeGen].
+ aStream nextPutAll: varName]
+ ifNotNil:
+ [varName := switchVariable.
+ aStream nextPut: $(; nextPutAll: varName; nextPutAll: ' = '.
+ expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen.
+ aStream nextPut: $)].
+ n := 0.
+ cases do:
+ [:tuple|
+ [:labels :case|
+  labels do:
+ [:label|
+ n > 0 ifTrue:
+ [aStream nextPutAll: varName].
+ aStream nextPutAll: ' == '.
+ label emitCCodeAsArgumentOn: aStream level: level + 1 generator: aCodeGen.
+ aStream nextPut: $).
+ aStream crtab: level + n + 1.
+ aStream nextPutAll: '? ('.
+ (TStmtListNode new setArguments: #() statements: case statements)
+ emitCCodeAsArgumentOn: aStream
+ level: level + 2
+ generator: aCodeGen.
+ aStream nextPut: $); crtab: level + n + 1; nextPutAll: ': ('.
+ n := n + 1]]
+ valueWithArguments: tuple].
+ otherwiseOrNil
+ ifNotNil: [otherwiseOrNil emitCCodeAsArgumentOn: aStream level: level + 1 generator: aCodeGen]
+ ifNil: [aStream nextPutAll: 'error("Case not found and no otherwise clause"), 0'].
+ aStream next: n - 1 put: $)!

Item was added:
+ ----- Method: TSwitchStmtNode>>emitCCodeOn:addToEndOfCases:level:generator: (in category 'C code generation') -----
+ emitCCodeOn: aStream addToEndOfCases: aNodeOrNil level: level generator: aCodeGen
+
+ aStream crtab: level.
+ aStream nextPutAll: 'switch ('.
+ expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen.
+ aStream nextPutAll: ') {'.
+ cases do:
+ [:tuple|
+ [:labels :case|
+  labels do:
+ [:label|
+ aStream
+ crtab: level;
+ nextPutAll: 'case '.
+ label emitCCodeAsArgumentOn: aStream level: level + 1 generator: aCodeGen.
+ aStream nextPut: $:].
+  aStream crtab: level + 1.
+  case emitCCodeOn: aStream prependToEnd: aNodeOrNil level: level + 1 generator: aCodeGen]
+ valueWithArguments: tuple.
+  (aNodeOrNil notNil and: [aNodeOrNil isReturn]) ifFalse:
+ [aStream crtab: level + 1; nextPutAll: 'break;']].
+ aStream
+ crtab: level;
+ nextPutAll: 'default:';
+ crtab: level + 1.
+ otherwiseOrNil
+ ifNotNil: [otherwiseOrNil emitCCodeOn: aStream prependToEnd: aNodeOrNil level: level + 1 generator: aCodeGen]
+ ifNil: [aStream nextPutAll: 'error("Case not found and no otherwise clause");'.
+   aNodeOrNil ifNotNil:
+ [aStream crtab: level + 1.
+ (aNodeOrNil copy setExpression: (TConstantNode new setValue: -1))
+ emitCCodeOn: aStream level: level generator: aCodeGen.
+ aStream nextPut: $;]].
+ aStream
+ crtab: level;
+ nextPut: $}!

Item was added:
+ ----- Method: TSwitchStmtNode>>emitCCodeOn:level:generator: (in category 'C code generation') -----
+ emitCCodeOn: aStream level: level generator: aCodeGen
+
+ aStream crtab: level.
+ aStream nextPutAll: 'switch ('.
+ expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen.
+ aStream nextPutAll: ') {'.
+ cases do:
+ [:tuple|
+ [:labels :case|
+  labels do:
+ [:label|
+ aStream
+ crtab: level;
+ nextPutAll: 'case '.
+ label emitCCodeAsArgumentOn: aStream level: level + 1 generator: aCodeGen.
+ aStream nextPut: $:].
+  aStream crtab: level + 1.
+  case emitCCodeOn: aStream level: level + 1 generator: aCodeGen.
+  case endsWithReturn ifFalse:
+ [aStream tab: level + 1; nextPutAll: 'break;']]
+ valueWithArguments: tuple].
+ aStream
+ crtab: level;
+ nextPutAll: 'default:';
+ crtab: level + 1.
+ otherwiseOrNil
+ ifNotNil:
+ [otherwiseOrNil emitCCodeOn: aStream level: level + 1 generator: aCodeGen]
+ ifNil: [aStream nextPutAll: 'error("Case not found and no otherwise clause");'].
+ aStream
+ crtab: level;
+ nextPut: $}!

Item was added:
+ ----- Method: TSwitchStmtNode>>expression (in category 'accessing') -----
+ expression
+ "Answer the value of expression"
+
+ ^ expression!

Item was added:
+ ----- Method: TSwitchStmtNode>>expression: (in category 'accessing') -----
+ expression: anObject
+ "Set the value of expression"
+
+ expression := anObject!

Item was added:
+ ----- Method: TSwitchStmtNode>>expression:cases:otherwiseOrNil: (in category 'instance initialization') -----
+ expression: expr cases: aTBraceNode otherwiseOrNil: otherwiseOrNilNode
+
+ self expression: expr.
+ self cases: (self createCasesFromBraceNode: aTBraceNode).
+ self otherwiseOrNil: otherwiseOrNilNode!

Item was added:
+ ----- Method: TSwitchStmtNode>>isSwitch (in category 'testing') -----
+ isSwitch
+ ^true!

Item was added:
+ ----- Method: TSwitchStmtNode>>nodesDo: (in category 'enumerating') -----
+ nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
+ expression nodesDo: aBlock.
+ cases do:
+ [:pair|
+ pair first do: [:node| node nodesDo: aBlock].
+ pair last nodesDo: aBlock].
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil nodesDo: aBlock].
+ aBlock value: self!

Item was added:
+ ----- Method: TSwitchStmtNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ expression nodesDo: aBlock parent: self..
+ cases do:
+ [:pair|
+ pair first do: [:node| node nodesDo: aBlock parent: self.].
+ pair last nodesDo: aBlock parent: self.].
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TSwitchStmtNode>>nodesDo:unless: (in category 'enumerating') -----
+ nodesDo: aBlock unless: cautionaryBlock
+
+ (cautionaryBlock value: self) ifTrue: [^self].
+ expression nodesDo: aBlock unless: cautionaryBlock.
+ cases do:
+ [:pair|
+ pair first do: [:node| node nodesDo: aBlock unless: cautionaryBlock].
+ pair last nodesDo: aBlock unless: cautionaryBlock].
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil nodesDo: aBlock unless: cautionaryBlock]!

Item was added:
+ ----- Method: TSwitchStmtNode>>otherwiseOrNil (in category 'accessing') -----
+ otherwiseOrNil
+ "Answer the value of otherwiseOrNil"
+
+ ^ otherwiseOrNil!

Item was added:
+ ----- Method: TSwitchStmtNode>>otherwiseOrNil: (in category 'accessing') -----
+ otherwiseOrNil: anObject
+ "Set the value of otherwiseOrNil"
+
+ otherwiseOrNil := anObject!

Item was added:
+ ----- Method: TSwitchStmtNode>>postCopy (in category 'copying') -----
+ postCopy
+ expression := expression copy.
+ cases := (cases collect:
+ [:pair| "<Array with: <Array with: ParseTreeNode> with: TStmtListNode"
+ { pair first collect: [:labelNode| labelNode copy].
+   pair last copy }]).
+ otherwiseOrNil := otherwiseOrNil copy!

Item was added:
+ ----- Method: TSwitchStmtNode>>printOn:level: (in category 'printing') -----
+ printOn: aStream level: level
+
+ aStream crtab: level.
+ aStream nextPutAll: 'switch ('.
+ expression printOn: aStream level: level.
+ aStream nextPutAll: ') {'.
+ cases do:
+ [:tuple|
+ [:labels :case|
+  labels do:
+ [:label|
+ aStream
+ crtab: level;
+ nextPutAll: 'case '.
+ label printOn: aStream level: level + 1.
+ aStream nextPut: $:].
+  aStream crtab: level + 1.
+  case printOn: aStream level: level + 1.
+  aStream crtab: level + 1; nextPutAll: 'break;']
+ valueWithArguments: tuple].
+ otherwiseOrNil ifNotNil:
+ [aStream
+ crtab: level;
+ nextPutAll: 'default:';
+ crtab: level + 1.
+ otherwiseOrNil printOn: aStream level: level + 1].
+ aStream
+ crtab: level;
+ nextPut: $}!

Item was added:
+ ----- Method: TSwitchStmtNode>>removeAssertions (in category 'transformations') -----
+ removeAssertions
+ expression removeAssertions.
+ cases do:
+ [:pair| "<Array with: <Array with: ParseTreeNode> with: TStmtListNode"
+ pair first do: [:labelNode| labelNode removeAssertions].
+ pair last removeAssertions].
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil removeAssertions]!

Item was added:
+ ----- Method: TSwitchStmtNode>>replaceNodesIn: (in category 'transformations') -----
+ replaceNodesIn: aDictionary
+ ^aDictionary
+ at: self
+ ifAbsent:
+ [expression := expression replaceNodesIn: aDictionary.
+ cases := (cases collect:
+ [:pair| "<Array with: <Array with: ParseTreeNode> with: TStmtListNode"
+ { pair first collect: [:labelNode| labelNode replaceNodesIn: aDictionary].
+   pair last replaceNodesIn: aDictionary }]).
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil := otherwiseOrNil replaceNodesIn: aDictionary].
+ self]!

Item was added:
+ ----- Method: TSwitchStmtNode>>switchVariable (in category 'accessing') -----
+ switchVariable
+ "Answer the value of switchVariable"
+
+ ^ switchVariable!

Item was added:
+ ----- Method: TSwitchStmtNode>>switchVariable: (in category 'accessing') -----
+ switchVariable: anObject
+ "Set the value of switchVariable"
+
+ switchVariable := anObject!

Item was added:
+ ----- Method: TVariableNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TVariableNode>>structTargetKindIn: (in category 'testing') -----
+ structTargetKindIn: aCodeGen
+ "Answer if the recever evaluates to a struct or struct pointer
+ and hence can be dereferenced using . or ->.  Answer any of
+ #struct #pointer or nil"
+ ^aCodeGen structTargetKindForVariableName: name!

Item was changed:
  ----- Method: VMMaker class>>versionString (in category 'version testing') -----
  versionString
 
  "VMMaker versionString"
 
+ ^'4.12.14'!
- ^'4.12.13'!