Smalltalk › Squeak › Squeak VM

VM Maker: VMMaker-dtl.419.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

VM Maker: VMMaker-dtl.419.mcz

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

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

Name: VMMaker-dtl.419
Author: dtl
Time: 22 November 2020, 11:52:26.748 am
UUID: 13a52440-38ce-414c-92a9-8a2ba438b91b
Ancestors: VMMaker-dtl.418

Extend image version compatibility.
For Squeak 6 alpha (current trunk):
Remove use of deprecated hideVScrollBarIndefinitely: with possible cosmetic impact on older image versions but otherwise harmless to remove.
Provide a compatibility method to handle the renaming of includesSubString: to includesSubstring:
Handle the removal of CrLfFileStream.
For circa Squeak 3.8:
Use ifNotNilDo: instead of ifNotNil: when passing a block argument.
Use ifNil:ifNotNilDo: instead of ifNil:ifNotNil: when passing a block argument.
Note, early images require Pragmatizer to undo pragma usage

=============== Diff against VMMaker-dtl.418 ===============

Item was changed:
----- Method: BalloonEngineBase class>>initialize (in category 'class initialization') -----
initialize
"BalloonEngineBase initialize"
"BalloonEnginePlugin translateDoInlining: true."
EdgeInitTable := self initializeEdgeInitTable.
EdgeStepTable := self initializeEdgeStepTable.
WideLineWidthTable := self initializeWideLineWidthTable.
WideLineFillTable := self initializeWideLineFillTable.
FillTable := self initializeFillTable.

+ (Smalltalk classNamed: #BalloonEngineConstants) ifNotNilDo:
- (Smalltalk classNamed: #BalloonEngineConstants) ifNotNil:
[:balloonEngineConstants|
(balloonEngineConstants classPool anySatisfy: [:classVarValue| classVarValue isNil]) ifTrue:
[balloonEngineConstants initialize]]!

Item was changed:
----- Method: BalloonEngineSimulation>>copyBitsFrom:to:at: (in category 'simulation') -----
copyBitsFrom: x0 to: x1 at: y
"Simulate the copyBits primitive"

| bb |
bbObj isInteger ifTrue:
["Create a proxy object to handle BitBlt calls"
bb := savedBBObj
ifNil: [BitBltSimulator new
initialiseModule;
setInterpreter: interpreterProxy;
yourself]
+ ifNotNilDo: [savedBBObj].
- ifNotNil: [savedBBObj].
(bb loadBitBltFrom: bbObj)
ifTrue: [bbObj := bb]
ifFalse: [^ self]].
bbObj copyBitsFrom: x0 to: x1 at: y.
"
interpreterProxy showDisplayBits: bbObj destForm
Left: bb affectedLeft Top: bb affectedTop
Right: bb affectedRight Bottom: bb affectedBottom.
"!

Item was changed:
----- Method: CCodeGenerator>>addMethodFor:selector: (in category 'utilities') -----
addMethodFor: aClass selector: selector
"Add the given method to the code base and answer its translation
or nil if it shouldn't be translated."

| method tmethod |
method := aClass compiledMethodAt: selector.
method requiresConcreteImplementation ifTrue: [abstractDeclarations add: selector].
method isAbstract ifTrue: [^nil].
(method pragmaAt: #doNotGenerate) ifNotNil: [^nil].
"process optional methods by interpreting the argument to the option: pragma as either
a Cogit class name or a class variable name or a variable name in VMBasicConstants."
+ (method pragmaAt: #option:) ifNotNilDo:
- (method pragmaAt: #option:) ifNotNil:
[:pragma| | key |
key := pragma argumentAt: 1.
"((Cogit withAllSubclasses anySatisfy: [:c| c name = key])
and: [VMClass getVMMaker cogitClassName ~= key]) ifTrue:
[^nil]."
+ (aClass bindingOf: key) ifNotNilDo:
- (aClass bindingOf: key) ifNotNil:
[:binding|
binding value ifFalse: [^nil]].
+ (VMBasicConstants bindingOf: key) ifNotNilDo:
- (VMBasicConstants bindingOf: key) ifNotNil:
[:binding|
binding value ifFalse: [^nil]]].
tmethod := self compileToTMethodSelector: selector in: aClass.
tmethod hasDoNotGenerateStatement ifTrue: [^nil].
self addMethod: tmethod.
"If the method has a macro then add the macro. But keep the method
for analysis purposes (e.g. its variable accesses)."
+ (method pragmaAt: #cmacro:) ifNotNilDo:
- (method pragmaAt: #cmacro:) ifNotNil:
[:pragma|
self addMacro: (pragma argumentAt: 1) for: selector].
+ (method propertyValueAt: #cmacro:) ifNotNilDo:
- (method propertyValueAt: #cmacro:) ifNotNil:
[:macro|
self addMacro: macro for: selector].
^tmethod!

Item was changed:
----- Method: CCodeGenerator>>addStructMethodFor:selector: (in category 'utilities') -----
addStructMethodFor: aClass selector: selector
"Add the given struct method to the code base and answer its translation
or nil if it shouldn't be translated."
+ ^(self addMethodFor: aClass selector: selector) ifNotNilDo:
- ^(self addMethodFor: aClass selector: selector) ifNotNil:
[:tmethod|
tmethod transformToStructClassMethodFor: self.
tmethod]!

Item was changed:
----- Method: CCodeGenerator>>declToType: (in category 'public') -----
declToType: decl
"Extracts the type from a C declaration string"

| strs r |
decl isNil ifFalse: [
(decl indexOf: $=) > 0 ifTrue:
[ strs := (decl copyFrom: 1 to: ((decl indexOf: $=) - 1)) ]
ifFalse: [ strs := decl ].
strs := (strs withoutTrailingBlanks) subStrings: ' '.
strs size == 1 ifTrue: [ ^ strs first ]
ifFalse:
[
| asterisks |
r := ''.
strs allButLastDo: [ :s | r := r,s,' ' ].
"Bit of a hack to get 'type *'"
asterisks := (strs last copyFrom: 1 to: (strs last lastIndexOf: $*)).
asterisks size > 0 ifTrue: [ r := r,' ',asterisks ].
r := r withoutTrailingBlanks.
+ (((r indexOf: $( ) > 0) or: [ (r indexOf: $) ) > 0 ] ) ifTrue: [ ^nil ].
- (((r indexOf: $() > 0) or: ((r indexOf: $)) > 0)) ifTrue: [ ^nil ].
^r withoutTrailingBlanks
].
] ifTrue: [ ^nil ].!

Item was changed:
----- Method: CCodeGenerator>>extractTypeFor:fromDeclaration: (in category 'utilities') -----
extractTypeFor: aVariable fromDeclaration: aVariableDeclaration
"Eliminate inessentials from aVariableDeclaration to answer a C type without the variable,
or initializations etc"
| decl |
decl := aVariableDeclaration.
(decl beginsWith: 'static') ifTrue:
[decl := decl allButFirst: 6].
+ (decl indexOf: $= ifAbsent: []) ifNotNilDo:
- (decl indexOf: $= ifAbsent: []) ifNotNil:
[:index| decl := decl copyFrom: 1 to: index - 1].
decl := decl copyReplaceAll: aVariable with: '' tokenish: [:ch| ch = $_ or: [ch isAlphaNumeric]].
^self baseTypeForType: decl!

Item was changed:
----- Method: CCodeGenerator>>generateIfFalse:on:indent: (in category 'C translation') -----
generateIfFalse: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPutAll: 'if (!!('.
msgNode receiver emitCCodeAsExpressionOn: aStream level: level + 1 generator: self.
aStream nextPutAll: ')) {'; cr.
msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
level timesRepeat: [aStream tab].
aStream nextPut: $}]
+ ifNotNilDo:
- ifNotNil:
[:const |
const ifFalse:
[msgNode args first emitCCodeOn: aStream level: level generator: self]]!

Item was changed:
----- Method: CCodeGenerator>>generateIfFalseAsArgument:on:indent: (in category 'C translation') -----
generateIfFalseAsArgument: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPutAll: '(!!('.
msgNode receiver emitCCodeAsArgumentOn: aStream level: 0 generator: self.
aStream nextPut: $); crtab: level + 1; nextPut: $?; space.
msgNode args last emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
aStream crtab: level + 1; nextPutAll: ': 0)']
+ ifNotNilDo:
- ifNotNil:
[:const|
const ifFalse:
[msgNode args first emitCCodeAsArgumentOn: aStream level: level generator: self]]!

Item was changed:
----- Method: CCodeGenerator>>generateIfFalseIfTrue:on:indent: (in category 'C translation') -----
generateIfFalseIfTrue: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPutAll: 'if ('.
msgNode receiver emitCCodeAsExpressionOn: aStream level: level generator: self.
aStream nextPutAll: ') {'; cr.
msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
aStream tab: level; nextPut: $}; nextPutAll: ' else {'; cr.
msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
aStream tab: level; nextPut: $}]
+ ifNotNilDo:
- ifNotNil:
[:const |
(const ifTrue: [msgNode args last] ifFalse: [msgNode args first])
emitCCodeOn: aStream level: level generator: self]!

Item was changed:
----- Method: CCodeGenerator>>generateIfFalseIfTrueAsArgument:on:indent: (in category 'C translation') -----
generateIfFalseIfTrueAsArgument: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPut: $(.
msgNode receiver emitCCodeAsArgumentOn: aStream level: level generator: self.
aStream crtab: level + 1; nextPut: $?; space.
msgNode args last emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
aStream crtab: level + 1; nextPut: $:; space.
msgNode args first emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
aStream nextPut: $)]
+ ifNotNilDo:
- ifNotNil:
[:const|
(const
ifTrue: [msgNode args last]
ifFalse: [msgNode args first])
emitCCodeAsArgumentOn: aStream level: level generator: self]!

Item was changed:
----- Method: CCodeGenerator>>generateIfTrue:on:indent: (in category 'C translation') -----
generateIfTrue: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPutAll: 'if ('.
msgNode receiver emitCCodeAsExpressionOn: aStream level: level generator: self.
aStream nextPutAll: ') {'; cr.
msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
level timesRepeat: [ aStream tab ].
aStream nextPut: $}]
+ ifNotNilDo:
- ifNotNil:
[:const |
const ifTrue:
[msgNode args first emitCCodeOn: aStream level: level generator: self]]!

Item was changed:
----- Method: CCodeGenerator>>generateIfTrueAsArgument:on:indent: (in category 'C translation') -----
generateIfTrueAsArgument: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPut: $(.
msgNode receiver emitCCodeAsArgumentOn: aStream level: level generator: self.
aStream crtab: level + 1; nextPut: $?; space.
msgNode args first emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
aStream crtab: level + 1; nextPutAll: ': 0)']
+ ifNotNilDo:
- ifNotNil:
[:const|
const ifTrue:
[msgNode args first emitCCodeAsArgumentOn: aStream level: level generator: self]]!

Item was changed:
----- Method: CCodeGenerator>>generateIfTrueIfFalse:on:indent: (in category 'C translation') -----
generateIfTrueIfFalse: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPutAll: 'if ('.
msgNode receiver emitCCodeAsExpressionOn: aStream level: level generator: self.
aStream nextPutAll: ') {'; cr.
msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
aStream tab: level; nextPut: $}; nextPutAll: ' else {'; cr.
msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
aStream tab: level; nextPut: $}]
+ ifNotNilDo:
- ifNotNil:
[:const |
(const ifTrue: [msgNode args first] ifFalse: [msgNode args last])
emitCCodeOn: aStream level: level generator: self]!

Item was changed:
----- Method: CCodeGenerator>>generateIfTrueIfFalseAsArgument:on:indent: (in category 'C translation') -----
generateIfTrueIfFalseAsArgument: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."

(self nilOrBooleanConstantReceiverOf: msgNode)
ifNil:
[aStream nextPut: $(.
msgNode receiver emitCCodeAsArgumentOn: aStream level: level generator: self.
aStream crtab: level + 1; nextPut: $?; space.
msgNode args first emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
aStream crtab: level + 1; nextPut: $:; space.
msgNode args last emitCCodeAsArgumentOn: aStream level: level + 2 generator: self.
aStream nextPut: $)]
+ ifNotNilDo:
- ifNotNil:
[:const|
(const ifTrue: [msgNode args first] ifFalse: [msgNode args last])
emitCCodeAsArgumentOn: aStream level: level generator: self]!

Item was changed:
----- Method: CCodeGenerator>>generateValue:on:indent: (in category 'C translation') -----
generateValue: aTSendNode on: aStream indent: level
"Reduce [:formal ... :formalN| body ] value: actual ... value: actualN
to body with formals substituted for by actuals."
| substitution substitutionDict newLabels |
self assert: aTSendNode receiver isStmtList.
self assert: aTSendNode receiver args size = aTSendNode args size.
substitution := aTSendNode receiver copy.
substitution renameLabelsForInliningInto: currentMethod.
substitutionDict := Dictionary new: aTSendNode args size * 2.
aTSendNode receiver args with: aTSendNode args do:
[ :argName :exprNode |
substitutionDict at: argName put: exprNode].
substitution
bindVariablesIn: substitutionDict;
emitCCodeOn: aStream level: level generator: self.
newLabels := Set withAll: currentMethod labels.
substitution nodesDo:
+ [:node| node isLabel ifTrue: [node label ifNotNilDo: [:label| newLabels add: label]]].
- [:node| node isLabel ifTrue: [node label ifNotNil: [:label| newLabels add: label]]].
"now add the new labels so that a subsequent inline of
the same block will be renamed with different labels."
currentMethod labels: newLabels!

Item was changed:
----- Method: CCodeGenerator>>generateValueAsArgument:on:indent: (in category 'C translation') -----
generateValueAsArgument: aTSendNode on: aStream indent: level
"Reduce [:formal ... :formalN| body ] value: actual ... value: actualN
to body with formals substituted for by actuals."
| substitution substitutionDict newLabels |
self assert: aTSendNode receiver isStmtList.
self assert: aTSendNode receiver args size = aTSendNode args size.
substitution := aTSendNode receiver copy.
substitution renameLabelsForInliningInto: currentMethod.
substitutionDict := Dictionary new: aTSendNode args size * 2.
aTSendNode receiver args with: aTSendNode args do:
[ :argName :exprNode |
substitutionDict at: argName put: exprNode].
substitution
bindVariablesIn: substitutionDict;
emitCCodeAsArgumentOn: aStream level: level generator: self.
newLabels := Set withAll: currentMethod labels.
substitution nodesDo:
+ [:node| node isLabel ifTrue: [node label ifNotNilDo: [:label| newLabels add: label]]].
- [:node| node isLabel ifTrue: [node label ifNotNil: [:label| newLabels add: label]]].
"now add the new labels so that a subsequent inline of
the same block will be renamed with different labels."
currentMethod labels: newLabels!

Item was changed:
----- Method: CCodeGenerator>>storeCodeOnFile:doInlining:doAssertions: (in category 'public') -----
storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: assertionFlag
"Store C code for this code base on the given file."

| stream |
+ stream := VMMaker forceNewFileNamed: fileName.
- stream := CrLfFileStream forceNewFileNamed: fileName.
stream ifNil: [Error signal: 'Could not open C code file: ', fileName].
self emitCCodeOn: stream doInlining: inlineFlag doAssertions: assertionFlag.
stream close!

Item was changed:
----- Method: CCodeGenerator>>storeHeaderFor:onFile: (in category 'public') -----
storeHeaderFor: interpreterClassName onFile: fileName
"Store C header code for this interpreter on the given file."

| aStream |
+ aStream := VMMaker forceNewFileNamed: fileName.
- aStream := CrLfFileStream forceNewFileNamed: fileName.
aStream ifNil: [Error signal: 'Could not open C header file: ', fileName].
aStream
nextPutAll: '/* ';
nextPutAll: VMMaker headerNotice;
nextPutAll: ' */'; cr; cr;
nextPutAll: (self fileHeaderVersionStampForSourceClass: nil); cr; cr;
nextPutAll: '#ifndef HAVE_INTERP_H'; cr;
nextPutAll: '# define HAVE_INTERP_H'; cr;
nextPutAll: '#endif'; cr; cr.
self emitVmmVersionOn: aStream.
(Smalltalk classNamed: interpreterClassName)
emitInterpreterProxyVersionOn: aStream.
self emitDefineBytesPerWordOn: aStream.
aStream cr.
aStream close
!

Item was changed:
----- Method: CCodeGenerator>>var:declareC: (in category 'public') -----
var: varName declareC: declarationString
"Record the given C declaration for a global variable."

+ (self string: declarationString includesSubstring: varName) ifFalse:
- (declarationString includesSubString: varName) ifFalse:
[self error: 'declaration omits variable name. probably an error. use e.g. var:type:'].
variableDeclarations at: varName asString put: declarationString.!

Item was changed:
----- Method: ContextInterpreter>>primitiveMemorySnapshotBytesWithHeader (in category 'snapshot utility primitives') -----
primitiveMemorySnapshotBytesWithHeader
"Primitive. Answer an array with a snapshot copy of the object memory as
of the point of entry to this primitive, and with the header information for
the image at the point of the snapshot.

The memory snapshot is a ByteArray copy of the object memory, and the header
information is an array of the values that would be stored in an image file
header if the image was being saved to disk. The header state information
along with memory snapshot are sufficient to initialize an an image to be run
in an interpreter."

- <export: true>
"pop rcvr. A resuming image will see this primitive answering true, otherwise
it will answer the expected value of a two element array. Test for result equal
to true to determine if the image is being resumed from a saved snapshot.."
| result |
+ <export: true>
self pop: argumentCount + 1.
self push: objectMemory getTrueObj. "resuming image will see this"
result := self
headerAndSnapshotOfSize: self prepareForSnapshot
class: objectMemory classByteArray.
self pop: 1. "restore stack"
self push: result. "normal sender will see this"
!

Item was changed:
----- Method: ContextInterpreter>>primitiveMemorySnapshotWithHeader (in category 'snapshot utility primitives') -----
primitiveMemorySnapshotWithHeader
"Primitive. Answer an array with a snapshot copy of the object memory as
of the point of entry to this primitive, and with the header information for
the image at the point of the snapshot.

The memory snapshot is a Bitmap copy of the object memory, and the header
information is an array of the values that would be stored in an image file
header if the image was being saved to disk. The header state information
along with memory snapshot are sufficient to initialize an an image to be run
in an interpreter."

- <export: true>
"pop rcvr. A resuming image will see this primitive answering true, otherwise
it will answer the expected value of a two element array. Test for result equal
to true to determine if the image is being resumed from a saved snapshot.."
| result |
+ <export: true>
self pop: argumentCount + 1.
+ self push: objectMemory getTrueObj. "resuming image will see this"
- self push: objectMemory getTrueObj. "resuming image will see this"
result := self
headerAndSnapshotOfSize: self prepareForSnapshot
class: objectMemory classBitmap.
self pop: 1. "restore stack"
self push: result. "normal sender will see this"
!

Item was changed:
----- Method: ContextInterpreter>>primitiveResumeFromSnapshot (in category 'snapshot utility primitives') -----
primitiveResumeFromSnapshot
"Discard the current object memory and resume interpreter execution
in the provided snapshot."

- <export: true>
| expectedArraySize snapshotValues size newMemoryBytesOrBitmap bigEndian snapshotImageFormat snapshotStartOfMemory snapshotSpecialObjectsOop snapshotLastHash screenSizePoint headerSize imageBytes imageHeaderFlags snapshotExtraVMMemory swapBytes snapshotFullScreen defaultHeapSize desiredHeapSize |
+ <export: true>
expectedArraySize := 11. "ImageSnapshot new asValues size => 11"
argumentCount == 1
ifFalse: [ ^self primitiveFailFor: PrimErrBadNumArgs].
snapshotValues := self stackObjectValue: 0.
self assertClassOf: snapshotValues is: (objectMemory splObj: ClassArray).
self successful
ifFalse: [ ^self primitiveFailFor: PrimErrBadArgument].
size := objectMemory numSlotsOf: snapshotValues.
size < expectedArraySize ifTrue: [ ^self primitiveFailFor: PrimErrBadArgument].
newMemoryBytesOrBitmap := objectMemory fetchPointer: 0 ofObject: snapshotValues.
bigEndian := (objectMemory fetchPointer: 1 ofObject: snapshotValues) = objectMemory trueObject.
snapshotImageFormat := objectMemory integerValueOf: (objectMemory fetchPointer: 2 ofObject: snapshotValues)..
(self readableFormat: snapshotImageFormat)
ifFalse: [ ^self primitiveFailFor: PrimErrInappropriate ].
headerSize := objectMemory integerValueOf: (objectMemory fetchPointer: 3 ofObject: snapshotValues)..
imageBytes := self positive32BitValueOf: (objectMemory fetchPointer: 4 ofObject: snapshotValues).. "good for up to 2GB image"
snapshotStartOfMemory := objectMemory integerValueOf: (objectMemory fetchPointer: 5 ofObject: snapshotValues)..
snapshotSpecialObjectsOop := objectMemory integerValueOf: (objectMemory fetchPointer: 6 ofObject: snapshotValues)..
snapshotLastHash := objectMemory integerValueOf: (objectMemory fetchPointer: 7 ofObject: snapshotValues)..
screenSizePoint := objectMemory fetchPointer: 8 ofObject: snapshotValues..
self assertClassOf: screenSizePoint is: (objectMemory splObj: ClassPoint).
self successful
ifFalse: [ ^self primitiveFailFor: PrimErrBadArgument].
imageHeaderFlags := objectMemory integerValueOf: (objectMemory fetchPointer: 9 ofObject: snapshotValues)..
snapshotExtraVMMemory := objectMemory integerValueOf: (objectMemory fetchPointer: 10 ofObject: snapshotValues)..

swapBytes := bigEndian ~= self isBigEnder.
snapshotFullScreen := false. "FIXME"

"From sqUnixMain.c
#define DefaultHeapSize 20
megabytes BEYOND actual image size"
defaultHeapSize := 20 * 1000 * 1000.
desiredHeapSize := defaultHeapSize + imageBytes.

self
snapshotResume: newMemoryBytesOrBitmap
heapSize: desiredHeapSize
swapBytes: swapBytes
oldBaseAddr: snapshotStartOfMemory
specialObjectsOop: snapshotSpecialObjectsOop
lastHash: snapshotLastHash
savedWindowSize: screenSizePoint
fullScreenFlag: snapshotFullScreen
extraVMMemory: snapshotExtraVMMemory.

self pop: 1 thenPush: newMemoryBytesOrBitmap.

!

Item was changed:
----- Method: InterpreterPlugin class>>storeString:onFileNamed: (in category 'translation') -----
storeString: s onFileNamed: fileName
"Store the given string in a file of the given name."

| f |
+ f := VMMaker forceNewFileNamed: fileName.
- f := CrLfFileStream forceNewFileNamed: fileName.
f nextPutAll: s.
f close.!

Item was changed:
----- Method: NewObjectMemorySimulator>>lookupAddress: (in category 'memory access') -----
lookupAddress: address
"If address appears to be that of a Symbol or a few well-known objects (such as classes) answer it, otherwise answer nil.
For code disassembly"
<doNotGenerate>
| fmt size string class classSize maybeThisClass classNameIndex thisClassIndex |
(self addressCouldBeObj: address) ifFalse:
[^nil].
fmt := self formatOf: address.
size := self lengthOf: address baseHeader: (self baseHeader: address) format: fmt.
size = 0 ifTrue:
[^address caseOf: { [nilObj] -> ['nil']. [trueObj] -> ['true']. [falseObj] -> ['false'] } otherwise: []].
((fmt between: 8 and: 11) "indexable byte fields"
and: [(size between: 1 and: 64)
and: [Scanner isLiteralSymbol: (string := (0 to: size - 1) collect: [:i| Character value: (self fetchByte: i ofObject: address)])]]) ifTrue:
[^'#', (ByteString withAll: string)].
class := self fetchClassOfNonInt: address.
((self addressCouldBeObj: class)
and: [(self headerType: class) ~= HeaderTypeShort]) ifFalse:
[^nil].
"address is either a class or a metaclass, or an instance of a class or invalid. determine which."
classNameIndex := coInterpreter classNameIndex.
thisClassIndex := coInterpreter thisClassIndex.
((classSize := self lengthOf: class baseHeader: (self baseHeader: address) format: fmt) <= (classNameIndex max: thisClassIndex)
or: [classSize > 255]) ifTrue:
[^nil].
"Address could be a class or a metaclass"
(fmt = 1 and: [size >= classNameIndex]) ifTrue:
["Is address a class? If so class's thisClass is address."
+ (self lookupAddress: (self fetchPointer: classNameIndex ofObject: address)) ifNotNilDo:
- (self lookupAddress: (self fetchPointer: classNameIndex ofObject: address)) ifNotNil:
[:maybeClassName|
(self fetchPointer: thisClassIndex ofObject: class) = address ifTrue:
[^maybeClassName allButFirst]].
"Is address a Metaclass? If so class's name is Metaclass and address's thisClass holds the class name"
((self isBytes: (self fetchPointer: classNameIndex ofObject: class))
and: [(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) = '#Metaclass'
and: [size >= thisClassIndex]]) ifTrue:
[maybeThisClass := self fetchPointer: thisClassIndex ofObject: address.
(self lookupAddress: (self fetchPointer: classNameIndex ofObject: maybeThisClass)) ifNotNil:
[:maybeThisClassName| ^maybeThisClassName allButFirst, ' class']]].
^(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) ifNotNil:
[:maybeClassName| 'a(n) ', maybeClassName allButFirst]!

Item was added:
+ ----- Method: Object>>string:includesSubstring: (in category '*VMMaker-translation support') -----
+ string: aString includesSubstring: substring
+ "Backward compatibility for a method that was renamed but needs to
+ remain functional for VMMaker across a range of images."
+
+ ^ (aString respondsTo: #includesSubstring: )
+ ifTrue: [aString perform: #includesSubstring: with: substring]
+ ifFalse: [aString perform: #includesSubString: with: substring]
+ !

Item was changed:
----- Method: SlangTest>>testInterpDeclareStatic (in category 'testing interpreter') -----
testInterpDeclareStatic
"A static directive should cause the generated function to be declared static."

| stssi m1 p1 m2 p2 |
stssi := SlangTestSupportInterpreter inline: false.
m1 := (stssi asCString: #declareStaticTrueByMethod)
copyReplaceAll: 'declareStaticTrueByMethod'
with: 'methodName'.
p1 := (stssi asCString: #declareStaticTrueByPragma)
copyReplaceAll: 'declareStaticTrueByPragma'
with: 'methodName'.
self assert: m1 = p1.

m2 := (stssi asCString: #declareStaticFalseByMethod)
copyReplaceAll: 'declareStaticFalseByMethod'
with: 'methodName'.
p2 := (stssi asCString: #declareStaticFalseByPragma)
copyReplaceAll: 'declareStaticFalseByPragma'
with: 'methodName'.
self assert: m2 = p2.

"verify that the keyword 'static appears in the generated C source"
+ self assert: (self string: m1 includesSubstring: 'static').
+ self assert: (self string: p1 includesSubstring: 'static').
+ self deny: (self string: m2 includesSubstring: 'static').
+ self deny: (self string: p2 includesSubstring: 'static')
- self assert: (m1 includesSubString: 'static').
- self assert: (p1 includesSubString: 'static').
- self deny: (m2 includesSubString: 'static').
- self deny: (p2 includesSubString: 'static')
!

Item was changed:
----- Method: SlangTest>>testInterpDoNotdoNotGenerateByMethod (in category 'testing interpreter') -----
testInterpDoNotdoNotGenerateByMethod
"A doNotdoNotGenerate statement should prevent code generation"

"(SlangTest selector: #testInterpDoNotdoNotGenerateByMethod) debug"

| stssi m |
stssi := SlangTestSupportInterpreter inline: false.
self assert: (SlangTestSupportInterpreter canUnderstand: #doNotGenerateByMethod).
m := stssi asCString: #doNotGenerateByMethod.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stssi asCString includesSubstring: 'doNotGenerateByMethod').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stssi asCString includesSubString: 'doNotGenerateByMethod').
self assert: (stssi doNotGenerateByMethod = 4)

!

Item was changed:
----- Method: SlangTest>>testInterpDoNotdoNotGenerateByPragma (in category 'testing interpreter') -----
testInterpDoNotdoNotGenerateByPragma
"A <doNotdoNotGenerate> declaration should prevent code generation"

| stssi m |
stssi := SlangTestSupportInterpreter inline: false.
self assert: (SlangTestSupportInterpreter canUnderstand: #doNotGenerateByPragma).
m := stssi asCString: #doNotGenerateByPragma.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stssi asCString includesSubstring: 'doNotGenerateByPragma').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stssi asCString includesSubString: 'doNotGenerateByPragma').
self assert: (stssi doNotGenerateByPragma = 4)
!

Item was changed:
----- Method: SlangTest>>testInterpDoNotdoNotGenerateSubclassResponsibility (in category 'testing interpreter') -----
testInterpDoNotdoNotGenerateSubclassResponsibility
"If a method contains self subclassResponsibility, assume it is not meant for translation."

| stssi m |
stssi := SlangTestSupportInterpreter inline: false.
self assert: (SlangTestSupportInterpreter canUnderstand: #anAbstractMethod).
m := stssi asCString: #anAbstractMethod.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stssi asCString includesSubstring: 'anAbstractMethod').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stssi asCString includesSubString: 'anAbstractMethod').
self should: [stssi anAbstractMethod]
raise: Error

!

Item was changed:
----- Method: SlangTest>>testInterpMixedMethodAndPragmaDeclarations (in category 'testing interpreter') -----
testInterpMixedMethodAndPragmaDeclarations
"Pragmas and method declarations should coexist"

| stssi s |
stssi := SlangTestSupportInterpreter inline: false.
s := (stssi asCString: #varDefByMethodAndPragma)
copyReplaceAll: 'varDefByMethod'
with: 'methodName'.
+ self assert: (self string: s includesSubstring: 'unsigned int * bar').
+ self assert: (self string: s includesSubstring: 'char *foo').
+ self assert: (self string: s includesSubstring: 'float baz').
+ self assert: (self string: s includesSubstring: 'double fum').
- self assert: (s includesSubString: 'unsigned int * bar').
- self assert: (s includesSubString: 'char *foo').
- self assert: (s includesSubString: 'float baz').
- self assert: (s includesSubString: 'double fum').
!

Item was changed:
----- Method: SlangTest>>testIvarShouldNotBeRedeclaredAsLocal (in category 'testing variable declaration') -----
testIvarShouldNotBeRedeclaredAsLocal
"Document a bug in some versions of the code generator. If an instance variable is
referenced in the generated code, that variable should not be declared as a local
in the function."

| stssi s |
stssi := SlangTestSupportInterpreter inline: false.
s := stssi asCString: #setBreakSelector: .
+ self deny: (self string: s includesSubstring: 'sqInt breakSelector;')
- self deny: (s includesSubString: 'sqInt breakSelector;')
!

Item was changed:
----- Method: SlangTest>>testLiteralName (in category 'testing variable declaration') -----
testLiteralName
"sizeOf: #Foo should translated to C function call sizeof(Foo), where Foo is a literal, not a string"

| stssi s |
stssi := SlangTestSupportInterpreter inline: false.
s := stssi asCString: #sizeOfFoo .
+ self assert: (self string: s includesSubstring: 'sizeOf(Foo)').
+ self deny: (self string: s includesSubstring: 'sizeOf("Foo")').
- self assert: (s includesSubString: 'sizeOf(Foo)').
- self deny: (s includesSubString: 'sizeOf("Foo")').

!

Item was changed:
----- Method: SlangTest>>testLocalizeGlobalVariables (in category 'testing variable declaration') -----
testLocalizeGlobalVariables
"CCodeGenerator>>localizeGlobalVariables performs an optimization
that may be misleading when introducing a new method. This test
documents that optimization.

If a method makes reference to an instance variable, and if this is the
only method containing a reference to that variable, then the C translator
will produce a local variable declaration in the generated function, and no
global declaration will appear in the generated source file. This optimization
is applied after inlining has been performed, so there are legitimate cases
where a variable must be an instance variable referenced by two methods,
but can be made local if those methods are inlined into a single method
and only one method reference to the variable remains. See
ObjectMemory>>markAndSweep: for an example."

| stssi s |
stssi := SlangTestSupportInterpreter inline: false.
s := stssi asCString: #methodWithReferenceToVariables .
"variable with one method reference is promoted to a local method variable"
+ self assert: (self string: s includesSubstring: 'sqInt aVarWithOneReference;').
- self assert: (s includesSubString: 'sqInt aVarWithOneReference;').
"normal expected behavior, the variable is global in the generated source module."
+ self deny: (self string: s includesSubstring: 'sqInt aVarWithTwoReferences;')
- self deny: (s includesSubString: 'sqInt aVarWithTwoReferences;')
!

Item was changed:
----- Method: SlangTest>>testPluginDeclareStatic (in category 'testing base plugins') -----
testPluginDeclareStatic
"A static directive should cause the generated function to be declared static."

| stsp m1 p1 m2 p2 |
stsp := SlangTestSupportPlugin inline: false.
m1 := (stsp asCString: #declareStaticTrueByMethod)
copyReplaceAll: 'declareStaticTrueByMethod'
with: 'methodName'.
p1 := (stsp asCString: #declareStaticTrueByPragma)
copyReplaceAll: 'declareStaticTrueByPragma'
with: 'methodName'.
self assert: m1 = p1.

m2 := (stsp asCString: #declareStaticFalseByMethod)
copyReplaceAll: 'declareStaticFalseByMethod'
with: 'methodName'.
p2 := (stsp asCString: #declareStaticFalseByPragma)
copyReplaceAll: 'declareStaticFalseByPragma'
with: 'methodName'.
self assert: m2 = p2.

"verify that the keyword 'static appears in the generated C source"
+ self assert: (self string: m1 includesSubstring: 'static').
+ self assert: (self string: p1 includesSubstring: 'static').
+ self deny: (self string: m2 includesSubstring: 'static').
+ self deny: (self string: p2 includesSubstring: 'static')
- self assert: (m1 includesSubString: 'static').
- self assert: (p1 includesSubString: 'static').
- self deny: (m2 includesSubString: 'static').
- self deny: (p2 includesSubString: 'static')
!

Item was changed:
----- Method: SlangTest>>testPluginDoNotGenerateByMethod (in category 'testing base plugins') -----
testPluginDoNotGenerateByMethod
"A doNotdoNotGenerate statement should prevent code generation"

| stsp m |
stsp := SlangTestSupportPlugin inline: false.
self assert: (SlangTestSupportPlugin canUnderstand: #doNotGenerateByMethod).
m := stsp asCString: #doNotGenerateByMethod.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stsp asCString includesSubstring: 'doNotGenerateByMethod').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stsp asCString includesSubString: 'doNotGenerateByMethod').
self assert: (stsp doNotGenerateByMethod = 4)
!

Item was changed:
----- Method: SlangTest>>testPluginDoNotGenerateByPragma (in category 'testing base plugins') -----
testPluginDoNotGenerateByPragma
"A <doNotdoNotGenerate> declaration should prevent code generation"

| stsp m |
stsp := SlangTestSupportPlugin inline: false.
self assert: (SlangTestSupportPlugin canUnderstand: #doNotGenerateByPragma).
m := stsp asCString: #doNotGenerateByPragma.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stsp asCString includesSubstring: 'doNotGenerateByPragma').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stsp asCString includesSubString: 'doNotGenerateByPragma').
self assert: (stsp doNotGenerateByPragma = 4)
!

Item was changed:
----- Method: SlangTest>>testPluginDoNotGenerateSubclassResponsibility (in category 'testing base plugins') -----
testPluginDoNotGenerateSubclassResponsibility
"If a method contains self subclassResponsibility, assume it is not meant for translation."

| stsp m |
stsp := SlangTestSupportPlugin inline: false.
self assert: (SlangTestSupportPlugin canUnderstand: #anAbstractMethod).
m := stsp asCString: #anAbstractMethod.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stsp asCString includesSubstring: 'anAbstractMethod').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stsp asCString includesSubString: 'anAbstractMethod').
self should: [stsp anAbstractMethod]
raise: Error
!

Item was changed:
----- Method: SlangTest>>testPluginMixedMethodAndPragmaDeclarations (in category 'testing base plugins') -----
testPluginMixedMethodAndPragmaDeclarations
"Pragmas and method declarations should coexist"

| stsp s |
stsp := SlangTestSupportPlugin inline: false.
s := (stsp asCString: #varDefByMethodAndPragma)
copyReplaceAll: 'varDefByMethod'
with: 'methodName'.
+ self assert: (self string: s includesSubstring: 'unsigned int * bar').
+ self assert: (self string: s includesSubstring: 'char *foo').
+ self assert: (self string: s includesSubstring: 'float baz').
+ self assert: (self string: s includesSubstring: 'double fum').
- self assert: (s includesSubString: 'unsigned int * bar').
- self assert: (s includesSubString: 'char *foo').
- self assert: (s includesSubString: 'float baz').
- self assert: (s includesSubString: 'double fum').
!

Item was changed:
----- Method: SlangTest>>testSSIPDeclareStatic (in category 'testing ssip plugins') -----
testSSIPDeclareStatic
"A static directive should cause the generated function to be declared static."

| stss m1 p1 m2 p2 |
stss := SlangTestSupportSSIP inline: false.
m1 := (stss asCString: #declareStaticTrueByMethod)
copyReplaceAll: 'declareStaticTrueByMethod'
with: 'methodName'.
p1 := (stss asCString: #declareStaticTrueByPragma)
copyReplaceAll: 'declareStaticTrueByPragma'
with: 'methodName'.
self assert: m1 = p1.

m2 := (stss asCString: #declareStaticFalseByMethod)
copyReplaceAll: 'declareStaticFalseByMethod'
with: 'methodName'.
p2 := (stss asCString: #declareStaticFalseByPragma)
copyReplaceAll: 'declareStaticFalseByPragma'
with: 'methodName'.
self assert: m2 = p2.

"verify that the keyword 'static appears in the generated C source"
+ self assert: (self string: m1 includesSubstring: 'static').
+ self assert: (self string: p1 includesSubstring: 'static').
+ self deny: (self string: m2 includesSubstring: 'static').
+ self deny: (self string: p2 includesSubstring: 'static')
- self assert: (m1 includesSubString: 'static').
- self assert: (p1 includesSubString: 'static').
- self deny: (m2 includesSubString: 'static').
- self deny: (p2 includesSubString: 'static')
!

Item was changed:
----- Method: SlangTest>>testSSIPDoNotGenerateByMethod (in category 'testing ssip plugins') -----
testSSIPDoNotGenerateByMethod
"A doNotdoNotGenerate statement should prevent code generation"

| stss m |
stss := SlangTestSupportSSIP inline: false.
self assert: (SlangTestSupportSSIP canUnderstand: #doNotGenerateByMethod).
m := stss asCString: #doNotGenerateByMethod.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stss asCString includesSubstring: 'doNotGenerateByMethod').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stss asCString includesSubString: 'doNotGenerateByMethod').
self assert: (stss doNotGenerateByMethod = 4)!

Item was changed:
----- Method: SlangTest>>testSSIPDoNotGenerateByPragma (in category 'testing ssip plugins') -----
testSSIPDoNotGenerateByPragma
"A <doNotdoNotGenerate> declaration should prevent code generation"

| stss m |
stss := SlangTestSupportSSIP inline: false.
self assert: (SlangTestSupportSSIP canUnderstand: #doNotGenerateByPragma).
m := stss asCString: #doNotGenerateByPragma.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stss asCString includesSubstring: 'doNotGenerateByPragma').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stss asCString includesSubString: 'doNotGenerateByPragma').
self assert: (stss doNotGenerateByPragma = 4)
!

Item was changed:
----- Method: SlangTest>>testSSIPDoNotGenerateSubclassResponsibility (in category 'testing ssip plugins') -----
testSSIPDoNotGenerateSubclassResponsibility
"If a method contains self subclassResponsibility, assume it is not meant for translation."

| stss m |
stss := SlangTestSupportSSIP inline: false.
self assert: (SlangTestSupportSSIP canUnderstand: #anAbstractMethod).
m := stss asCString: #anAbstractMethod.
+ self assert: (self string: m includesSubstring: 'No source has been generated').
+ self deny: (self string: stss asCString includesSubstring: 'anAbstractMethod').
- self assert: (m includesSubString: 'No source has been generated').
- self deny: (stss asCString includesSubString: 'anAbstractMethod').
self should: [stss anAbstractMethod]
raise: Error
!

Item was changed:
----- Method: SlangTest>>testSSIPMixedMethodAndPragmaDeclarations (in category 'testing ssip plugins') -----
testSSIPMixedMethodAndPragmaDeclarations
"Pragmas and method declarations should coexist"

| stss s |
stss := SlangTestSupportSSIP inline: false.
s := (stss asCString: #varDefByMethodAndPragma)
copyReplaceAll: 'varDefByMethod'
with: 'methodName'.
+ self assert: (self string: s includesSubstring: 'unsigned int * bar').
+ self assert: (self string: s includesSubstring: 'char *foo').
+ self assert: (self string: s includesSubstring: 'float baz').
+ self assert: (self string: s includesSubstring: 'double fum').
- self assert: (s includesSubString: 'unsigned int * bar').
- self assert: (s includesSubString: 'char *foo').
- self assert: (s includesSubString: 'float baz').
- self assert: (s includesSubString: 'double fum').
!

Item was changed:
----- Method: SlangTest>>testSetInstanceVariableWithAnAccessorMethod (in category 'testing intermediate variable removal') -----
testSetInstanceVariableWithAnAccessorMethod
"Intermediate variable from parameter of accessor method should be removed.
This is an existing limitation of the inliner, and could be improved for better code
generation. It is not a bug."

| stssi s |
stssi := SlangTestSupportInterpreter inline: true.
s := (stssi asCString: #setInstanceVariableWithAnAccessorMethod)
copyReplaceAll: 'setInstanceVariableWithAnAccessorMethod'
with: 'methodName'.
+ self deny: (self string: s includesSubstring: 'sqInt oop').
+ self assert: (self string: s includesSubstring: 'aVariable = remap(').
- self deny: (s includesSubString: 'sqInt oop').
- self assert: (s includesSubString: 'aVariable = remap(').

"Should be translated to something similar to this:
aVariable = remap(objectMemory, nilObj);

Not like this:
oop = remap(objectMemory, nilObj);
aVariable = oop;"
!

Item was changed:
----- Method: SmartSyntaxPluginSimulator>>computeSignatureFor:from: (in category 'initialize') -----
computeSignatureFor: selector from: tuple
| signature |
self assert: tuple first == #forMap.
signature := tuple third collect:
[:className|
(Smalltalk classNamed: className)
ifNil: [self error: 'Argument class' , className, ' does not exist']
+ ifNotNilDo:
- ifNotNil:
[:argClass|
argClass
ccg: self
prolog: true
expr: [interpreterProxy primitiveFail]
index: nil]].
^signatureMap
at: tuple second asSymbol
put: { selector.
signature.
tuple fourth
ifNil: [[:oop| oop]]
+ ifNotNilDo:
- ifNotNil:
[:rcvrClassSymbol|
(Smalltalk classNamed: rcvrClassSymbol)
ifNil: [self error: 'Receiver class' , rcvrClassSymbol, ' does not exist']
+ ifNotNilDo:
- ifNotNil:
[:rcvrClass|
rcvrClass
ccg: self
prolog: false
expr: [interpreterProxy primitiveFail]
index: nil]] }!

Item was changed:
----- Method: SmartSyntaxPluginSimulator>>computeSignatureMap (in category 'initialize') -----
computeSignatureMap
forMap := true. "true only while we compute the signatureMap"
signatureMap := Dictionary new.
actualPlugin class selectorsAndMethodsDo:
[:s :m|
(m messages includesAnyOf: #(primitive:parameters: primitive:parameters:receiver:))
ifTrue: [self getPrimitiveSignatureFor: s]
ifFalse:
+ [(m pragmaAt: #export:) ifNotNilDo:
- [(m pragmaAt: #export:) ifNotNil:
[:exportPragma|
(exportPragma argumentAt: 1) ifTrue:
[self computeSignatureFor: s from: { #forMap. s. #(). nil }]]]].
forMap := false!

Item was changed:
----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses"
aCCodeGenerator
addHeaderFile:'<stddef.h> /* for e.g. alloca */';
addHeaderFile:'<setjmp.h>';
addHeaderFile:'"vmCallback.h"'.
self declareInterpreterVersionIn: aCCodeGenerator
defaultName: 'Stack'.
aCCodeGenerator
var: #interpreterProxy type: #'struct VirtualMachine*'.
aCCodeGenerator
declareVar: #sendTrace type: 'volatile int';
declareVar: #byteCount type: 'unsigned long'.
"These need to be pointers or unsigned."
self declareC: #(instructionPointer method newMethod)
as: #usqInt
in: aCCodeGenerator.
"These are all pointers; char * because Slang has no support for C pointer arithmetic."
self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit stackMemory)
as: #'char *'
in: aCCodeGenerator.
self declareC: #(stackPage overflowedPage)
as: #'StackPage *'
in: aCCodeGenerator.
aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code."
aCCodeGenerator
var: #methodCache
declareC: 'long methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
aCCodeGenerator
var: #atCache
declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'.
self primitiveTable do:
[:symbolOrNot|
(symbolOrNot isSymbol
and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
+ [(aCCodeGenerator methodNamed: symbolOrNot) ifNotNilDo:
- [(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
[:tMethod| tMethod returnType: #void]]].
aCCodeGenerator
var: #primitiveFunctionPointer
declareC: 'void (*primitiveFunctionPointer)()'.
aCCodeGenerator var: #showSurfaceFn type: #'void *'.
aCCodeGenerator
var: #jmpBuf
declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedCallbacks
declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedMethods
declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #interruptCheckChain
declareC: 'void (*interruptCheckChain)(void) = 0'.
aCCodeGenerator
var: #breakSelector type: #'char *';
var: #breakSelectorLength
declareC: 'sqInt breakSelectorLength = -1'.

self declareC: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs
longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs)
as: #usqLong
in: aCCodeGenerator.
aCCodeGenerator var: #nextProfileTick type: #sqLong.

aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[' , (MaxPrimitiveIndex + 2) printString , '] )(void)= ' , self primitiveTableString.
aCCodeGenerator var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'.
!

Item was changed:
----- Method: StackInterpreter class>>table:from: (in category 'initialization') -----
table: anArray from: specArray
"SpecArray is an array of one of (index selector) or (index1
index2 selector) or (index nil) or (index1 index2 nil). If selector
then the entry is the selector, but if nil the entry is the index."
| contiguous |
contiguous := 0.
specArray do:
[:spec |
(spec at: 1) = contiguous ifFalse:
[self error: 'Non-contiguous table entry'].
spec size = 2
ifTrue:
[anArray
at: (spec at: 1) + 1
+ put: ((spec at: 2) ifNil: [spec at: 1] ifNotNilDo: [:sym| sym]).
- put: ((spec at: 2) ifNil: [spec at: 1] ifNotNil: [:sym| sym]).
contiguous := contiguous + 1]
ifFalse:
[(spec at: 1) to: (spec at: 2) do:
+ [:i | anArray at: i + 1 put: ((spec at: 3) ifNil: [i] ifNotNilDo: [:sym| sym])].
- [:i | anArray at: i + 1 put: ((spec at: 3) ifNil: [i] ifNotNil: [:sym| sym])].
contiguous := contiguous + ((spec at: 2) - (spec at: 1)) + 1]]!

Item was changed:
----- Method: StackInterpreterSimulator>>run (in category 'testing') -----
run
"Just run"
quitBlock := [([transcript dependents anyOne outermostMorphThat: [:m| m isSystemWindow]]
on: Error
do: [:ex| nil])
+ ifNotNilDo: [:window| (UIManager default confirm: 'close?') ifTrue: [window delete]].
- ifNotNil: [:window| (UIManager default confirm: 'close?') ifTrue: [window delete]].
^self].
self initStackPages.
self loadInitialContext.
self internalizeIPandSP.
self fetchNextBytecode.
[true] whileTrue:
[self assertValidExecutionPointers.
atEachStepBlock value. "N.B. may be nil"
self dispatchOn: currentBytecode in: BytecodeTable.
self incrementByteCount].
localIP := localIP - 1.
"undo the pre-increment of IP before returning"
self externalizeIPandSP!

Item was changed:
----- Method: StackInterpreterSimulator>>runWithBreakCount: (in category 'testing') -----
runWithBreakCount: theBreakCount
"Just run, halting when byteCount is reached"
quitBlock := [(displayView notNil
and: [UIManager default confirm: 'close?']) ifTrue:
+ [(displayView outermostMorphThat: [:m| m isSystemWindow]) ifNotNilDo:
- [(displayView outermostMorphThat: [:m| m isSystemWindow]) ifNotNil:
[:topWindow| topWindow delete]].
^self].
breakCount := theBreakCount.
self initStackPages.
self loadInitialContext.
self internalizeIPandSP.
self fetchNextBytecode.
[true] whileTrue:
[self assertValidExecutionPointers.
self dispatchOn: currentBytecode in: BytecodeTable.
self incrementByteCount].
localIP := localIP - 1.
"undo the pre-increment of IP before returning"
self externalizeIPandSP!

Item was changed:
----- Method: StackInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
utilitiesMenu: aMenuMorph
aMenuMorph
add: 'toggle transcript' action: #toggleTranscript;
addLine;
add: 'print ext head frame' action: #printExternalHeadFrame;
add: 'print int head frame' action: #printHeadFrame;
add: 'short print frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
add: 'long print frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer];
+ add: 'print frame...' target: self action: [(self promptHex: 'print frame') ifNotNilDo: [:fp| self printFrame: fp]];
- add: 'print frame...' target: self action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]];
add: 'print call stack' action: #printCallStack;
+ add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNilDo: [:oop| self printOop: oop]];
- add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
addLine;
add: 'inspect object memory' target: objectMemory action: #inspect;
add: 'inspect cointerpreter' action: #inspect;
addLine;
add: 'set break count...' action: #setBreakCount;
add: (printSends
ifTrue: ['no print sends']
ifFalse: ['print sends'])
action: [self ensureDebugAtEachStepBlock.
printSends := printSends not];
"currently printReturns does nothing"
"add: (printReturns
ifTrue: ['no print returns']
ifFalse: ['print returns'])
action: [self ensureDebugAtEachStepBlock.
printReturns := printReturns not];"
add: (printBytecodeAtEachStep
ifTrue: ['no print bytecode each bytecode']
ifFalse: ['print bytecode each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printBytecodeAtEachStep := printBytecodeAtEachStep not];
add: (printFrameAtEachStep
ifTrue: ['no print frame each bytecode']
ifFalse: ['print frame each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printFrameAtEachStep := printFrameAtEachStep not].
^aMenuMorph!

Item was changed:
----- Method: TCaseStmtNode>>assumesCurrentBytecodeMatchesCaseValue: (in category 'as yet unclassified') -----
assumesCurrentBytecodeMatchesCaseValue: statementList
"Test for the special case of certain methods that rely on the value of
the currentBytecode variable to be expanded to a constant. This is a
performance optimization that permits the next bytecode to be fetched
early while not affecting the prior value of currentBytecode, which
will have been translated to a constant.

See senders of #'requires currentBytecode to be expanded to a constant'
for methods that rely on this behavior."

| trickySelectors commentString firstLine |
trickySelectors := {
#pushLiteralConstantBytecode .
#pushLiteralVariableBytecode .
#pushReceiverVariableBytecode .
#pushTemporaryVariableBytecode .
#storeAndPopTemporaryVariableBytecode .
#storeAndPopReceiverVariableBytecode
}.
firstLine := statementList statements first.
firstLine isComment ifTrue: [
commentString := firstLine asString.
+ trickySelectors detect: [:e | self string: commentString includesSubstring: e]
- trickySelectors detect: [:e | commentString includesSubString: e]
ifNone: [^ false].
^ true].
^ false!

Item was changed:
----- Method: TMethod>>addTypeForSelf (in category 'utilities') -----
addTypeForSelf
"If self should be typed then add a suitable type declaration.
Preserve the flagging of an implicit self using the #implicit symbol as the fake type."
+ self typeForSelf ifNotNilDo:
- self typeForSelf ifNotNil:
[:typeForSelf|
self declarationAt: 'self'
put: (typeForSelf == #implicit
ifTrue: [typeForSelf]
ifFalse: [typeForSelf, ' self'])]!

Item was changed:
----- Method: TMethod>>argConversionExprFor:stackIndex: (in category 'primitive compilation') -----
argConversionExprFor: varName stackIndex: stackIndex
"Return the parse tree for an expression that fetches and converts the
primitive argument at the given stack offset."
| exprList decl stmtList |
exprList := OrderedCollection new.
(declarations includesKey: varName) ifTrue:[
decl := declarations at: varName.
(decl includes: $*) ifTrue:["array"
+ (self string: decl includesSubstring: 'char') ifTrue:[ | expr |
- (decl includesSubString: 'char') ifTrue:[ | expr |
expr := '(interpreterProxy isBytes: (interpreterProxy stackValue: (stackIndex))) ifFalse:[^interpreterProxy primitiveFail].'.
expr := expr copyReplaceAll: 'interpreterProxy' with: self vmNameString.
expr := expr copyReplaceAll: 'stackIndex' with: stackIndex printString.
exprList add: expr.
].
exprList add: varName , ' := ', self vmNameString, ' arrayValueOf: (', self vmNameString, ' stackValue: (' , stackIndex printString , '))'.
exprList add: varName , ' := ' , varName , ' - 1'.
] ifFalse:["must be a double"
(decl findString: 'double' startingAt: 1) = 0 ifTrue: [
self error: 'unsupported type declaration in a primitive method'
].
exprList add: varName , ' := ', self vmNameString, ' stackFloatValue: ' , stackIndex printString.
]
] ifFalse: ["undeclared variables are taken to be integer"
exprList add: varName , ' := ', self vmNameString, ' stackIntegerValue: ' , stackIndex printString
].
stmtList := OrderedCollection new.
exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)].
^ stmtList!

Item was changed:
----- Method: TMethod>>emitCFunctionPrototype:generator:newlineBeforeName: (in category 'C code generation') -----
emitCFunctionPrototype: aStream generator: aCodeGen newlineBeforeName: newlineBeforeName "<Boolean>"
"Emit a C function header for this method onto the given stream."

export
ifTrue:[aStream nextPutAll: 'EXPORT('; nextPutAll: returnType; nextPut: $)]
ifFalse:[(self isStaticIn: aCodeGen) ifTrue:[aStream nextPutAll: 'static '].
aStream nextPutAll: returnType].
newlineBeforeName ifTrue: [aStream cr] ifFalse: [aStream space].
(returnType last = $)
+ and: [self string: returnType includesSubstring: (aCodeGen cFunctionNameFor: self selectorForCodeGeneration)]) ifTrue:
- and: [returnType includesSubString: (aCodeGen cFunctionNameFor: self selectorForCodeGeneration)]) ifTrue:
["Hack fix for e.g. <returnTypeC: 'void (*setInterruptCheckChain(void (*aFunction)(void)))()'>"
^self].
aStream
nextPutAll: (aCodeGen cFunctionNameFor: self selectorForCodeGeneration);
nextPut: $(.
args isEmpty
ifTrue: [aStream nextPutAll: #void]
ifFalse:
[args
do: [:arg| aStream nextPutAll: (self declarationAt: arg)]
separatedBy: [ aStream nextPutAll: ', ' ]].
aStream nextPut: $)!

Item was changed:
----- Method: TMethod>>extractDirective:valueBlock:default: (in category 'transformations') -----
extractDirective: theSelector valueBlock: aBlock default: defaultResult
"Find a pragma of the form:

<theSelector[args]>

Answer the result of evaluating aBock with a TSendNode corresponding
to the pragma node, or defaultResult if there is no matching pragma."

| result found newStatements |
+ (properties at: theSelector ifAbsent: []) ifNotNilDo:
- (properties at: theSelector ifAbsent: []) ifNotNil:
[:pragma|
^aBlock value: (TSendNode new
setSelector: pragma keyword
receiver: (TVariableNode new setName: 'self')
arguments: (pragma arguments collect: [:const| TConstantNode new setValue: const]))].
"Pre-pragma backward compatibility:
Scan the top-level statements for a labelling directive of the form:

self theSelector[args]

and remove the directive from the method body if found.
Answer the result of evaluating aBock with the send node,
or defaultResult if there is no labelling directive." result := defaultResult.
found := false.
newStatements := OrderedCollection new: parseTree statements size.
parseTree statements do:
[ :stmt |
(stmt isSend
and: [stmt selector = theSelector])
ifTrue:
[found := true.
result := aBlock value: stmt]
ifFalse:
[newStatements add: stmt]].
^found
ifTrue:
[parseTree setStatements: newStatements asArray.
result]
ifFalse: [defaultResult]!

Item was changed:
----- Method: TMethod>>maybeBreakFor:in: (in category 'inlining') -----
maybeBreakFor: aNode in: aCodeGen
"convenient for debugging..."
(aNode isSend
and: [(aCodeGen breakSrcInlineSelector notNil or: [aCodeGen breakDestInlineSelector notNil])
+ and: [(aCodeGen breakSrcInlineSelector ifNil: [true] ifNotNilDo: [:srcSel| srcSel = aNode selector])
+ and: [aCodeGen breakDestInlineSelector ifNil: [true] ifNotNilDo: [:dstSel| dstSel = selector]]]]) ifTrue:
- and: [(aCodeGen breakSrcInlineSelector ifNil: [true] ifNotNil: [:srcSel| srcSel = aNode selector])
- and: [aCodeGen breakDestInlineSelector ifNil: [true] ifNotNil: [:dstSel| dstSel = selector]]]]) ifTrue:
[self halt: selector]!

Item was changed:
----- Method: TMethod>>superExpansionNodeFor:args: (in category 'inlining') -----
superExpansionNodeFor: aSelector args: argumentNodes
"Answer the expansion of a super send. Merge the super expansion's
locals, properties and comment into this method's properties."
(definingClass superclass lookupSelector: aSelector)
ifNil: [self error: 'superclass does not define super method']
+ ifNotNilDo:
- ifNotNil:
[:superMethod| | superTMethod commonVars varMap |
superTMethod := superMethod methodNode asTranslationMethodOfClass: self class.
((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode])
and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse:
[self error: definingClass name, '>>',selector, ' args ~= ',
superTMethod definingClass name, '>>', aSelector,
(String with: $. with: Character cr),
'For super expansions to be translated correctly each argument must be a variable with the same name as the corresponding argument in the super method.'].
self mergePropertiesOfSuperMethod: superTMethod.
(commonVars := superTMethod locals intersection: self locals) notEmpty ifTrue:
[varMap := Dictionary new.
commonVars do:
[:k| varMap at: k put: (superTMethod unusedNamePrefixedBy: k avoiding: self allLocals)].
superTMethod renameVariablesUsing: varMap].
self assert: (superTMethod locals allSatisfy: [:var| (self locals includes: var) not]).
locals addAll: superTMethod locals.
superTMethod declarations keysAndValuesDo:
[:var :decl|
self declarationAt: var put: decl].
+ superTMethod comment ifNotNilDo:
- superTMethod comment ifNotNil:
[:superComment|
comment := comment
ifNil: [superComment]
+ ifNotNilDo: [superComment, comment]].
+ superTMethod extraVariableNumber ifNotNilDo:
- ifNotNil: [superComment, comment]].
- superTMethod extraVariableNumber ifNotNil:
[:scvn|
extraVariableNumber := extraVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]].
superTMethod elideAnyFinalReturn.
^superTMethod parseTree]!

Item was changed:
----- Method: TMethod>>tryToInlineMethodsIn: (in category 'inlining') -----
tryToInlineMethodsIn: aCodeGen
"Expand any (complete) inline methods called by this method. Set the complete bit when all inlining has been done. Return true if something was inlined."

| stmtLists didSomething newStatements sendsToInline |
self definedAsMacro ifTrue:
[complete := true.
^false].
didSomething := false.
sendsToInline := Dictionary new: 100.
parseTree
nodesDo:
[:node|
(self inlineableFunctionCall: node in: aCodeGen) ifTrue:
[sendsToInline at: node put: (self inlineFunctionCall: node in: aCodeGen)]]
unless: "Don't inline the arguments to asserts to keep the asserts readable"
[:node|
node isSend
and: [aCodeGen isAssertSelector: node selector]].

sendsToInline isEmpty ifFalse:
[didSomething := true.
self removeUnreferencedDeclarations.
parseTree := parseTree replaceNodesIn: sendsToInline].

didSomething ifTrue:
[writtenToGlobalVarsCache := nil.
^didSomething].

stmtLists := self statementsListsForInliningIn: aCodeGen.
stmtLists do:
[:stmtList|
newStatements := OrderedCollection new: 100.
stmtList statements do:
[:stmt|
(self inlineCodeOrNilForStatement: stmt in: aCodeGen)
ifNil: [newStatements addLast: stmt]
+ ifNotNilDo: [:inlinedStmts|
- ifNotNil: [:inlinedStmts|
didSomething := true.
newStatements addAllLast: inlinedStmts]].
stmtList setStatements: newStatements asArray].

didSomething ifTrue:
[writtenToGlobalVarsCache := nil.
^didSomething].

complete ifFalse:
[self checkForCompleteness: stmtLists in: aCodeGen.
complete ifTrue: [ didSomething := true ]]. "marking a method complete is progress"
^didSomething!

Item was changed:
----- Method: TSendNode>>isStructSend: (in category 'testing') -----
isStructSend: 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 structTargetKind: aCodeGen) notNil
and: [(aCodeGen methodNamed: selector)
ifNil: [false]
+ ifNotNilDo: [:method| method isStructAccessor]]]!
- ifNotNil: [:method| method isStructAccessor]]]!

Item was changed:
----- 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]
+ ifNotNilDo: [:method| method isStructAccessor]]]!
- ifNotNil: [:method| method isStructAccessor]]]!

Item was changed:
----- 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) ifNotNilDo:
- [(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) ifNotNilDo:
- (receiver structTargetKindIn: aCodeGen) ifNotNil:
[:kind| ^kind]].

(aCodeGen selectorReturnsPointerToStruct: selector) ifTrue:
[^#pointer].

(aCodeGen selectorReturnsStruct: selector) ifTrue:
[^#struct].

^nil!

Item was changed:
----- Method: VMMaker class>>forceNewFileNamed: (in category 'utilities') -----
+ forceNewFileNamed: fileName
+ "Use CrLfFileStream for older images such as Squeak 3.6, or MultiByteFileStream
+ if CrLfFileStream is no longer present. LrLfFileStream is first choice because
+ forceNewFileNamed: was a late addition to MultiByteFileStream."
- forceNewFileNamed: aFilename
- "Always output files in unix lf format.
- A single format is friendlier to e.g. external version control systems.
- The Microsoft and old MacOS classic C compilers all accept lf format files."

+ (Smalltalk classNamed: 'CrLfFileStream')
+ ifNotNilDo: [ :crlf | ^ crlf forceNewFileNamed: fileName ].
+ (Smalltalk classNamed: 'MultiByteFileStream')
+ ifNotNilDo: [ :cls | ^ ((cls forceNewFileNamed: fileName) lineEndConvention: #lf; yourself) ].
+ !
- ^(MultiByteFileStream forceNewFileNamed: aFilename)
- lineEndConvention: #lf;
- yourself!

Item was changed:
----- Method: VMMakerTool>>entryRowWithLabel:labelWidth:balloonText:getFieldText:setFieldText:buttonLabel:buttonAction:buttonBalloonText: (in category 'window construction') -----
entryRowWithLabel: label labelWidth: lWidth balloonText: balloonText getFieldText: getTextSelector setFieldText: setTextSelector buttonLabel: buttonLabel buttonAction: buttonAction buttonBalloonText: buttonBalloonText
| row tm |
row := Morph new color: Color transparent;
hResizing: #spaceFill;
vResizing: #spaceFill;
extent: 550 @ 40;
layoutPolicy: ProportionalLayout new;
borderWidth: 2;
setBalloonText: balloonText translated;
yourself.
row
addMorph: (TextMorph new contents: label translated asText allBold) lock
fullFrame: (LayoutFrame
fractions: (0 @ 0 corner: 0 @ 1)
offsets: (3 @ 3 corner: lWidth @ -3)).
row
addMorph: ((tm := PluggableTextMorph
on: self
text: getTextSelector
+ accept: setTextSelector) acceptOnCR: true)
- accept: setTextSelector) hideVScrollBarIndefinitely: true;
- acceptOnCR: true)
fullFrame: (LayoutFrame
fractions: (0 @ 0 corner: 1 @ 1)
offsets: (lWidth + 10 @ 0 corner: (lWidth / 1.8 + 10) negated @ 0)).
"Make the background a solid color so that eventual bleed from the labels doesn't make the entire input field unreadable. Happens when the bold font is significantly wider than the non-bold font or when the spacing of the font doesn't match the guess above"
tm color: (Color gray: 0.9).
buttonAction
ifNotNil: [row
addMorph: (SimpleButtonMorph new target: self;
label: buttonLabel translated;
actionSelector: buttonAction;
hResizing: #spaceFill;
setBalloonText: buttonBalloonText translated)
fullFrame: (LayoutFrame
fractions: (1 @ 0 corner: 1 @ 1)
offsets: ((lWidth / 1.8 + 5) negated @ 3 corner: -5 @ -3))].
^ row!

Item was changed:
----- Method: VMStructType class>>checkGenerateFieldAccessors:bitPosition:in: (in category 'code generation') -----
checkGenerateFieldAccessors: fieldSpecs bitPosition: firstBitPosition in: surrogateClass
| bitPosition alignedByteSize |
bitPosition := firstBitPosition.
fieldSpecs do:
[:spec| | code |
"If the accessor is already defined in a superclass don't redefine it in the subclass.
We assume it is correctly defined in the superclass."
(spec first ~= #unused
and: [(surrogateClass whichClassIncludesSelector: spec first asSymbol)
ifNil: [true]
+ ifNotNilDo: [:implementingClass|
- ifNotNil: [:implementingClass|
self assert: (implementingClass inheritsFrom: Object).
implementingClass == surrogateClass]]) ifTrue:
[code := self getter: spec first
bitPosition: bitPosition
bitWidth: spec second
bool: (spec at: 3 ifAbsent: []) = #Boolean.
code ~= (surrogateClass sourceCodeAt: spec first asSymbol ifAbsent: ['']) asString ifTrue:
[surrogateClass compile: code classified: #accessing].
code := self setter: spec first
bitPosition: bitPosition
bitWidth: spec second
bool: (spec at: 3 ifAbsent: []) = #Boolean.
code ~= (surrogateClass sourceCodeAt: (spec first, ':') asSymbol ifAbsent: ['']) asString ifTrue:
[surrogateClass compile: code classified: #accessing]].
bitPosition := bitPosition + spec second].
alignedByteSize := bitPosition / 8.
self assert: alignedByteSize isInteger.
alignedByteSize ~= surrogateClass alignedByteSize ifTrue:
[surrogateClass class
compile: 'alignedByteSize'
, (String with: Character cr with: Character tab with: $^)
, alignedByteSize printString
classified: #accessing]!

Item was changed:
----- Method: VMStructType class>>needsTypeTag (in category 'translation') -----
needsTypeTag
self instVarNamesAndTypesForTranslationDo:
[:ivn :type|
+ (self string: (type isArray ifTrue: [type first] ifFalse: [type]) includesSubstring: self structTagName) ifTrue:
- ((type isArray ifTrue: [type first] ifFalse: [type]) includesSubString: self structTagName) ifTrue:
[^true]].
^false!