[Vm-dev] VM Maker: VMMaker.oscog-eem.597.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jan 31 00:36:31 UTC 2014
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.597.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.597
Author: eem
Time: 30 January 2014, 4:31:41.523 pm
UUID: c9a71dd4-c394-4a8f-aa4d-a6d4dc3ff220
Ancestors: VMMaker.oscog-eem.596
Fix markAndTraceStackPage: for Spur. Stack references to
forwarders must be followed before calling markAndTrace:.
Fix eliminateAndFreeForwarders; it assumed that no forwarder can
reference a new object after scavenge. That's not true due to
transitive references.
Fix SpurMemoryManager>>become:with:twoWay:copyHash: to follow
the specialObjectsOop if it has been forwarded.
Plugins (and the form print prim):
Fix some egregious oop + 4 and oop + 8 references with the correct
oop + BaseHeaderSize.
Reduce the use of isIntegerObject:. isWords:, isBytes:
et al fail for immediates anyway.
Use var:type: where appropriate and use symbols for 'char *' et al.
Replace some uses of cCode: 'aFunction(args)' with a send of the
equivalent albeit non-existent selector. This may allow simulation
at some point in the future.
=============== Diff against VMMaker.oscog-eem.596 ===============
Item was changed:
----- Method: AsynchFilePlugin>>asyncFileValueOf: (in category 'primitives') -----
asyncFileValueOf: oop
+ "Answer a pointer to the first byte of the async file record within the given Smalltalk bytes object, or nil if oop is not an async file record."
- "Return a pointer to the first byte of the async file record within the given Smalltalk bytes object, or nil if oop is not an async file record."
<returnTypeC: 'AsyncFile *'>
interpreterProxy success:
+ ((interpreterProxy isBytes: oop)
+ and: [(interpreterProxy slotSizeOf: oop) = (self cCode: 'sizeof(AsyncFile)')]).
+ ^interpreterProxy failed
+ ifTrue: [nil]
+ ifFalse: [self cCoerceSimple: (interpreterProxy firstIndexableField: oop) to: 'AsyncFile *']!
- ((interpreterProxy isIntegerObject: oop) not and:
- [(interpreterProxy isBytes: oop) and:
- [(interpreterProxy slotSizeOf: oop) = (self cCode: 'sizeof(AsyncFile)')]]).
- interpreterProxy failed ifTrue: [^ nil].
- ^ self cCode: '(AsyncFile *) (oop + 4)'
- !
Item was changed:
----- Method: B3DAcceleratorPlugin>>stackLightArrayValue: (in category 'primitive support') -----
stackLightArrayValue: stackIndex
"Load an Array of B3DPrimitiveLights from the given stack index"
| oop array arraySize |
<inline: false>
array := interpreterProxy stackObjectValue: stackIndex.
+ array = nil ifTrue:[^nil]. "really??"
- array = nil ifTrue:[^nil].
array = interpreterProxy nilObject ifTrue:[^nil].
+ (interpreterProxy isArray: array)
- (interpreterProxy fetchClassOf: array) = interpreterProxy classArray
ifFalse:[^interpreterProxy primitiveFail].
arraySize := interpreterProxy slotSizeOf: array.
0 to: arraySize-1 do:[:i|
oop := interpreterProxy fetchPointer: i ofObject: array.
- (interpreterProxy isIntegerObject: oop)
- ifTrue:[^interpreterProxy primitiveFail].
((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = 32])
ifFalse:[^interpreterProxy primitiveFail].
].
^array!
Item was changed:
----- Method: BalloonEngineBase>>loadFormsFrom: (in category 'loading state') -----
loadFormsFrom: arrayOop
"Check all the forms from arrayOop."
| formOop bmBits bmBitsSize bmWidth bmHeight bmDepth ppw bmRaster |
(interpreterProxy isArray: arrayOop) ifFalse:[^false].
formArray := arrayOop.
0 to: (interpreterProxy slotSizeOf: formArray) - 1 do:[:i|
formOop := interpreterProxy fetchPointer: i ofObject: formArray.
- (interpreterProxy isIntegerObject: formOop) ifTrue:[^false].
(interpreterProxy isPointers: formOop) ifFalse:[^false].
(interpreterProxy slotSizeOf: formOop) < 5 ifTrue:[^false].
bmBits := interpreterProxy fetchPointer: 0 ofObject: formOop.
+ (interpreterProxy fetchClassOf: bmBits) = interpreterProxy classBitmap
- (interpreterProxy fetchClassOf: bmBits) == interpreterProxy classBitmap
ifFalse:[^false].
bmBitsSize := interpreterProxy slotSizeOf: bmBits.
bmWidth := interpreterProxy fetchInteger: 1 ofObject: formOop.
bmHeight := interpreterProxy fetchInteger: 2 ofObject: formOop.
bmDepth := interpreterProxy fetchInteger: 3 ofObject: formOop.
interpreterProxy failed ifTrue:[^false].
(bmWidth >= 0 and:[bmHeight >= 0]) ifFalse:[^false].
ppw := 32 // bmDepth.
bmRaster := bmWidth + (ppw-1) // ppw.
bmBitsSize = (bmRaster * bmHeight)
ifFalse:[^false].
].
^true!
Item was changed:
----- Method: BalloonEngineBase>>primitiveGetFailureReason (in category 'primitives-access') -----
primitiveGetFailureReason
"Return the reason why the last operation failed."
<export: true>
<inline: false>
| failCode |
interpreterProxy methodArgumentCount = 0
ifFalse:[^interpreterProxy primitiveFailFor: PrimErrBadNumArgs].
engine := interpreterProxy stackValue: 0.
"Note -- don't call loadEngineFrom here because this will override the stopReason with Zero"
+ (interpreterProxy isImmediate: engine) ifTrue:[^interpreterProxy primitiveFailFor: GEFEngineIsInteger].
- (interpreterProxy isIntegerObject: engine) ifTrue:[^interpreterProxy primitiveFailFor: GEFEngineIsInteger].
(interpreterProxy isPointers: engine) ifFalse:[^interpreterProxy primitiveFailFor: GEFEngineIsWords].
(interpreterProxy slotSizeOf: engine) < BEBalloonEngineSize ifTrue:[^interpreterProxy primitiveFailFor: GEFEngineTooSmall].
(failCode := self loadWorkBufferFrom:
(interpreterProxy fetchPointer: BEWorkBufferIndex ofObject: engine)) = 0
ifFalse:[^interpreterProxy primitiveFailFor: failCode].
interpreterProxy pop: 1.
interpreterProxy pushInteger: self stopReasonGet.!
Item was changed:
----- Method: BalloonEnginePlugin>>loadBitmapFill:colormap:tile:from:along:normal:xIndex: (in category 'fills-bitmaps') -----
loadBitmapFill: formOop colormap: cmOop tile: tileFlag from: point1 along: point2 normal: point3 xIndex: xIndex
"Load the bitmap fill."
| bmFill cmSize cmBits bmBits bmBitsSize bmWidth bmHeight bmDepth ppw bmRaster |
+ <var: #cmBits type: #'int *'>
+ <var: #point1 type: #'int *'>
+ <var: #point2 type: #'int *'>
+ <var: #point3 type: #'int *'>
- <var: #cmBits type:'int *'>
- <var: #point1 type:'int *'>
- <var: #point2 type:'int *'>
- <var: #point3 type:'int *'>
cmOop == interpreterProxy nilObject ifTrue:[
cmSize := 0.
cmBits := nil.
] ifFalse:[
+ (interpreterProxy fetchClassOf: cmOop) = interpreterProxy classBitmap
- (interpreterProxy fetchClassOf: cmOop) == interpreterProxy classBitmap
ifFalse:[^interpreterProxy primitiveFail].
cmSize := interpreterProxy slotSizeOf: cmOop.
cmBits := interpreterProxy firstIndexableField: cmOop.
].
- (interpreterProxy isIntegerObject: formOop)
- ifTrue:[^interpreterProxy primitiveFail].
(interpreterProxy isPointers: formOop)
ifFalse:[^interpreterProxy primitiveFail].
(interpreterProxy slotSizeOf: formOop) < 5
ifTrue:[^interpreterProxy primitiveFail].
bmBits := interpreterProxy fetchPointer: 0 ofObject: formOop.
+ (interpreterProxy fetchClassOf: bmBits) = interpreterProxy classBitmap
- (interpreterProxy fetchClassOf: bmBits) == interpreterProxy classBitmap
ifFalse:[^interpreterProxy primitiveFail].
bmBitsSize := interpreterProxy slotSizeOf: bmBits.
bmWidth := interpreterProxy fetchInteger: 1 ofObject: formOop.
bmHeight := interpreterProxy fetchInteger: 2 ofObject: formOop.
bmDepth := interpreterProxy fetchInteger: 3 ofObject: formOop.
interpreterProxy failed ifTrue:[^nil].
(bmWidth >= 0 and:[bmHeight >= 0]) ifFalse:[^interpreterProxy primitiveFail].
(bmDepth = 32) | (bmDepth = 8) | (bmDepth = 16) |
(bmDepth = 1) | (bmDepth = 2) | (bmDepth = 4)
ifFalse:[^interpreterProxy primitiveFail].
(cmSize = 0 or:[cmSize = (1 << bmDepth)])
ifFalse:[^interpreterProxy primitiveFail].
ppw := 32 // bmDepth.
bmRaster := bmWidth + (ppw-1) // ppw.
bmBitsSize = (bmRaster * bmHeight)
ifFalse:[^interpreterProxy primitiveFail].
bmFill := self allocateBitmapFill: cmSize colormap: cmBits.
engineStopped ifTrue:[^nil].
self bitmapWidthOf: bmFill put: bmWidth.
self bitmapHeightOf: bmFill put: bmHeight.
self bitmapDepthOf: bmFill put: bmDepth.
self bitmapRasterOf: bmFill put: bmRaster.
self bitmapSizeOf: bmFill put: bmBitsSize.
self bitmapTileFlagOf: bmFill put: tileFlag.
self objectIndexOf: bmFill put: xIndex.
self loadFillOrientation: bmFill
from: point1 along: point2 normal: point3
width: bmWidth height: bmHeight.
^bmFill!
Item was changed:
----- Method: CameraPlugin>>primGetFrame (in category 'primitives') -----
primGetFrame
"Copy a camera frame into the given Bitmap. The Bitmap should be for a Form of depth 32 that is the same width and height as the current camera frame. Fail if the camera is not open or if the bitmap is not the right size. If successful, answer the number of frames received from the camera since the last call. If this is zero, then there has been no change."
| cameraNum bitmapOop bitmap pixCount result |
<export: true>
+ <var: 'bitmap' type: #'unsigned char *'>
- <var: 'bitmap' declareC: 'unsigned char *bitmap'>
cameraNum := interpreterProxy stackIntegerValue: 1.
bitmapOop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isWords: bitmapOop).
+ interpreterProxy failed ifTrue:
+ [^ 0].
+ bitmap := self cCoerce: (interpreterProxy firstIndexableField: bitmapOop) to: #'unsigned char *'.
- ((interpreterProxy isIntegerObject: bitmapOop) or:
- [(interpreterProxy isWords: bitmapOop) not]) ifTrue: [
- interpreterProxy success: false.
- ^ 0].
- bitmap := self cCoerce: (interpreterProxy firstIndexableField: bitmapOop) to: 'unsigned char *'.
pixCount := interpreterProxy stSizeOf: bitmapOop.
+ result := self Camera: cameraNum Get: bitmap Frame: pixCount.
- result := self cCode: 'CameraGetFrame(cameraNum, bitmap, pixCount)'.
result < 0 ifTrue: [
interpreterProxy success: false.
^ 0].
interpreterProxy pop: 3 thenPush: (interpreterProxy integerObjectOf: result). "pop rcvr & args, push int result"
^ 0
!
Item was changed:
----- Method: CoInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
self assert: thePage trace ~= StackPageTraced.
thePage trace: StackPageTraced.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
+ (objectMemory isOopForwarded: oop) ifTrue:
+ [oop := objectMemory followForwarded: oop.
+ stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
(self isMachineCodeFrame: theFP)
ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)]
ifFalse: [objectMemory markAndTrace: (self iframeMethod: theFP)].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP + BytesPerWord. "caller ip is ceBaseReturnPC"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
+ (objectMemory isOopForwarded: oop) ifTrue:
+ [oop := objectMemory followForwarded: oop.
+ stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
Item was changed:
----- Method: DeflatePlugin>>loadDeflateStreamFrom: (in category 'primitive support') -----
loadDeflateStreamFrom: rcvr
| oop |
<inline: false>
+ ((interpreterProxy isPointers: rcvr)
+ and: [(interpreterProxy slotSizeOf: rcvr) >= 15]) ifFalse:
+ [^false].
- ((interpreterProxy isPointers: rcvr) and:[
- (interpreterProxy slotSizeOf: rcvr) >= 15]) ifFalse:[^false].
oop := interpreterProxy fetchPointer: 0 ofObject: rcvr.
+ (interpreterProxy isBytes: oop) ifFalse:
+ [^false].
- (interpreterProxy isIntegerObject: oop)
- ifTrue:[^false].
- (interpreterProxy isBytes: oop)
- ifFalse:[^false].
zipCollection := interpreterProxy firstIndexableField: oop.
zipCollectionSize := interpreterProxy byteSizeOf: oop.
zipPosition := interpreterProxy fetchInteger: 1 ofObject: rcvr.
zipReadLimit := interpreterProxy fetchInteger: 2 ofObject: rcvr.
"zipWriteLimit := interpreterProxy fetchInteger: 3 ofObject: rcvr."
oop := interpreterProxy fetchPointer: 4 ofObject: rcvr.
+ ((interpreterProxy isWords: oop)
+ and: [(interpreterProxy slotSizeOf: oop) = DeflateHashTableSize]) ifFalse:
+ [^false].
- ((interpreterProxy isIntegerObject: oop) or:[
- (interpreterProxy isWords: oop) not]) ifTrue:[^false].
- (interpreterProxy slotSizeOf: oop) = DeflateHashTableSize ifFalse:[^false].
zipHashHead := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 5 ofObject: rcvr.
+ ((interpreterProxy isWords: oop)
+ and: [(interpreterProxy slotSizeOf: oop) = DeflateWindowSize]) ifFalse:
+ [^false].
- ((interpreterProxy isIntegerObject: oop) or:[
- (interpreterProxy isWords: oop) not]) ifTrue:[^false].
- (interpreterProxy slotSizeOf: oop) = DeflateWindowSize ifFalse:[^false].
zipHashTail := interpreterProxy firstIndexableField: oop.
zipHashValue := interpreterProxy fetchInteger: 6 ofObject: rcvr.
zipBlockPos := interpreterProxy fetchInteger: 7 ofObject: rcvr.
"zipBlockStart := interpreterProxy fetchInteger: 8 ofObject: rcvr."
oop := interpreterProxy fetchPointer: 9 ofObject: rcvr.
+ (interpreterProxy isBytes: oop) ifFalse:
+ [^false].
- ((interpreterProxy isIntegerObject: oop) or:[
- (interpreterProxy isBytes: oop) not]) ifTrue:[^false].
zipLiteralSize := interpreterProxy slotSizeOf: oop.
zipLiterals := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 10 ofObject: rcvr.
+ ((interpreterProxy isWords: oop)
+ and: [(interpreterProxy slotSizeOf: oop) >= zipLiteralSize]) ifFalse:
+ [^false].
- ((interpreterProxy isIntegerObject: oop) or:[
- (interpreterProxy isWords: oop) not]) ifTrue:[^false].
- (interpreterProxy slotSizeOf: oop) < zipLiteralSize ifTrue:[^false].
zipDistances := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 11 ofObject: rcvr.
+ ((interpreterProxy isWords: oop)
+ and: [(interpreterProxy slotSizeOf: oop) = DeflateMaxLiteralCodes]) ifFalse:
+ [^false].
- ((interpreterProxy isIntegerObject: oop) or:[
- (interpreterProxy isWords: oop) not]) ifTrue:[^false].
- (interpreterProxy slotSizeOf: oop) = DeflateMaxLiteralCodes ifFalse:[^false].
zipLiteralFreq := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 12 ofObject: rcvr.
+ ((interpreterProxy isWords: oop)
+ and: [(interpreterProxy slotSizeOf: oop) = DeflateMaxDistanceCodes]) ifFalse:
+ [^false].
- ((interpreterProxy isIntegerObject: oop) or:[
- (interpreterProxy isWords: oop) not]) ifTrue:[^false].
- (interpreterProxy slotSizeOf: oop) = DeflateMaxDistanceCodes ifFalse:[^false].
zipDistanceFreq := interpreterProxy firstIndexableField: oop.
zipLiteralCount := interpreterProxy fetchInteger: 13 ofObject: rcvr.
zipMatchCount := interpreterProxy fetchInteger: 14 ofObject: rcvr.
^interpreterProxy failed not!
Item was changed:
----- Method: DeflatePlugin>>loadZipEncoderFrom: (in category 'primitive support') -----
loadZipEncoderFrom: rcvr
| oop |
<inline: false>
+ ((interpreterProxy isPointers: rcvr)
+ and: [(interpreterProxy slotSizeOf: rcvr) >= 6]) ifFalse:
+ [^false].
- ((interpreterProxy isPointers: rcvr) and:[
- (interpreterProxy slotSizeOf: rcvr) >= 6]) ifFalse:[^false].
oop := interpreterProxy fetchPointer: 0 ofObject: rcvr.
+ (interpreterProxy isBytes: oop) ifFalse:
+ [^interpreterProxy primitiveFail].
- (interpreterProxy isIntegerObject: oop)
- ifTrue:[^interpreterProxy primitiveFail].
- (interpreterProxy isBytes: oop)
- ifFalse:[^interpreterProxy primitiveFail].
zipCollection := interpreterProxy firstIndexableField: oop.
zipCollectionSize := interpreterProxy byteSizeOf: oop.
zipPosition := interpreterProxy fetchInteger: 1 ofObject: rcvr.
zipReadLimit := interpreterProxy fetchInteger: 2 ofObject: rcvr.
"zipWriteLimit := interpreterProxy fetchInteger: 3 ofObject: rcvr."
zipBitBuf := interpreterProxy fetchInteger: 4 ofObject: rcvr.
zipBitPos := interpreterProxy fetchInteger: 5 ofObject: rcvr.
^interpreterProxy failed not!
Item was changed:
----- Method: DeflatePlugin>>sendBlock:with:with:with: (in category 'encoding') -----
sendBlock: literalStream with: distanceStream with: litTree with: distTree
"Require:
zipCollection, zipCollectionSize, zipPosition,
zipBitBuf, zipBitPos.
"
| oop litPos litLimit litArray distArray lit dist sum llBitLengths llCodes distBitLengths distCodes code extra litBlCount distBlCount |
+ <var: #litArray type: #'unsigned char *'>
+ <var: #distArray type: #'unsigned int *'>
+ <var: #llBitLengths type: #'unsigned int *'>
+ <var: #llCodes type: #'unsigned int *'>
+ <var: #distBitLengths type: #'unsigned int *'>
+ <var: #distCodes type: #'unsigned int *'>
- <var: #litArray type:'unsigned char *'>
- <var: #distArray type:'unsigned int *'>
- <var: #llBitLengths type:'unsigned int *'>
- <var: #llCodes type:'unsigned int *'>
- <var: #distBitLengths type:'unsigned int *'>
- <var: #distCodes type:'unsigned int *'>
oop := interpreterProxy fetchPointer: 0 ofObject: literalStream.
litPos := interpreterProxy fetchInteger: 1 ofObject: literalStream.
litLimit := interpreterProxy fetchInteger: 2 ofObject: literalStream.
+ (litPos <= litLimit
+ and: [(interpreterProxy isBytes: oop)
+ and: [litLimit <= (interpreterProxy byteSizeOf: oop)]]) ifFalse:
+ [^interpreterProxy primitiveFail].
- ((interpreterProxy isIntegerObject: oop) not and:[litPos <= litLimit and:[
- litLimit <= (interpreterProxy byteSizeOf: oop) and:[interpreterProxy isBytes: oop]]])
- ifFalse:[^interpreterProxy primitiveFail].
litArray := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 0 ofObject: distanceStream.
+ ((interpreterProxy isWords: oop)
+ and: [litLimit <= (interpreterProxy slotSizeOf: oop)
+ and: [(interpreterProxy fetchInteger: 1 ofObject: distanceStream) = litPos
+ and: [(interpreterProxy fetchInteger: 2 ofObject: distanceStream) = litLimit]]]) ifFalse:
+ [^interpreterProxy primitiveFail].
- ((interpreterProxy isIntegerObject: oop) not and:[
- (interpreterProxy fetchInteger: 1 ofObject: distanceStream) = litPos and:[
- (interpreterProxy fetchInteger: 2 ofObject: distanceStream) = litLimit]])
- ifFalse:[^interpreterProxy primitiveFail].
- ((interpreterProxy isWords: oop) and:[
- litLimit <= (interpreterProxy slotSizeOf: oop)])
- ifFalse:[^interpreterProxy primitiveFail].
distArray := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 0 ofObject: litTree.
+ (interpreterProxy isWords: oop) ifFalse:
+ [^interpreterProxy primitiveFail].
- ((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
- ifFalse:[^interpreterProxy primitiveFail].
litBlCount := interpreterProxy slotSizeOf: oop.
llBitLengths := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 1 ofObject: litTree.
+ ((interpreterProxy isWords: oop)
+ and: [litBlCount = (interpreterProxy slotSizeOf: oop)]) ifFalse:
+ [^interpreterProxy primitiveFail].
- ((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
- ifFalse:[^interpreterProxy primitiveFail].
- (litBlCount = (interpreterProxy slotSizeOf: oop))
- ifFalse:[^interpreterProxy primitiveFail].
llCodes := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 0 ofObject: distTree.
+ (interpreterProxy isWords: oop) ifFalse:
+ [^interpreterProxy primitiveFail].
- ((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
- ifFalse:[^interpreterProxy primitiveFail].
distBlCount := interpreterProxy slotSizeOf: oop.
distBitLengths := interpreterProxy firstIndexableField: oop.
oop := interpreterProxy fetchPointer: 1 ofObject: distTree.
+ ((interpreterProxy isWords: oop)
+ and: [distBlCount = (interpreterProxy slotSizeOf: oop)]) ifFalse:
+ [^interpreterProxy primitiveFail].
- ((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
- ifFalse:[^interpreterProxy primitiveFail].
- (distBlCount = (interpreterProxy slotSizeOf: oop))
- ifFalse:[^interpreterProxy primitiveFail].
distCodes := interpreterProxy firstIndexableField: oop.
- interpreterProxy failed ifTrue:[^nil].
-
self nextZipBits: 0 put: 0. "Flush pending bits if necessary"
sum := 0.
[litPos < litLimit and:[zipPosition + 4 < zipCollectionSize]] whileTrue:[
lit := litArray at: litPos.
dist := distArray at: litPos.
litPos := litPos + 1.
dist = 0 ifTrue:["literal"
sum := sum + 1.
lit < litBlCount ifFalse:[^interpreterProxy primitiveFail].
self nextZipBits: (llBitLengths at: lit) put: (llCodes at: lit).
] ifFalse:["match"
sum := sum + lit + DeflateMinMatch.
lit < 256 ifFalse:[^interpreterProxy primitiveFail].
code := zipMatchLengthCodes at: lit.
code < litBlCount ifFalse:[^interpreterProxy primitiveFail].
self nextZipBits: (llBitLengths at: code) put: (llCodes at: code).
extra := zipExtraLengthBits at: code - 257.
extra = 0 ifFalse:[
lit := lit - (zipBaseLength at: code - 257).
self nextZipBits: extra put: lit].
dist := dist - 1.
dist < 16r8000 ifFalse:[^interpreterProxy primitiveFail].
dist < 256
ifTrue:[code := zipDistanceCodes at: dist]
ifFalse:[code := zipDistanceCodes at: 256 + (dist >> 7)].
code < distBlCount ifFalse:[^interpreterProxy primitiveFail].
self nextZipBits: (distBitLengths at: code) put: (distCodes at: code).
extra := zipExtraDistanceBits at: code.
extra = 0 ifFalse:[
dist := dist - (zipBaseDistance at: code).
self nextZipBits: extra put: dist].
].
].
interpreterProxy failed ifTrue:[^nil].
interpreterProxy storeInteger: 1 ofObject: literalStream withValue: litPos.
interpreterProxy storeInteger: 1 ofObject: distanceStream withValue: litPos.
^sum!
Item was changed:
----- Method: FFIPlugin>>ffiArgument:Spec:Class: (in category 'callout support') -----
ffiArgument: oop Spec: argSpec Class: argClass
"Callout support. Prepare the given oop as argument.
argSpec defines the compiled spec for the argument.
argClass (if non-nil) defines the required (super)class for the argument."
| valueOop oopClass isStruct nilOop |
<inline: false>
oopClass := interpreterProxy fetchClassOf: oop. "Prefetch class (we'll need it)"
nilOop := interpreterProxy nilObject.
"Do the necessary type checks"
argClass == nilOop ifFalse:[
"Type check 1:
Is the required class of the argument a subclass of ExternalStructure?"
(interpreterProxy includesBehavior: argClass
ThatOf: interpreterProxy classExternalStructure)
ifFalse:[^self ffiFail: FFIErrorWrongType]. "Nope. Fail."
"Type check 2:
Is the class of the argument a subclass of required class?"
((nilOop == oop) or:[interpreterProxy includesBehavior: oopClass ThatOf: argClass])
ifFalse:[^self ffiFail: FFIErrorCoercionFailed]. "Nope. Fail."
"Okay, we've passed the type check (so far)"
].
"Check if oopClass is a subclass of ExternalStructure.
If this is the case we'll work on it's handle and not the actual oop."
isStruct := false.
+ ((interpreterProxy isImmediate: oop) or:[oop == nilOop]) ifFalse:[
+ "#isPointers: will fail if oop is immediate so don't even attempt to use it"
- ((interpreterProxy isIntegerObject: oop) or:[oop == nilOop]) ifFalse:[
- "#isPointers: will fail if oop is SmallInteger so don't even attempt to use it"
(interpreterProxy isPointers: oop)
ifTrue:[isStruct := interpreterProxy includesBehavior: oopClass
ThatOf: interpreterProxy classExternalStructure.
(argClass == nilOop or:[isStruct])
ifFalse:[^self ffiFail: FFIErrorCoercionFailed]].
"note: the test for #isPointers: above should speed up execution since no pointer type ST objects are allowed in external calls and thus if #isPointers: is true then the arg must be ExternalStructure to work. If it isn't then the code fails anyways so speed isn't an issue"
].
"Determine valueOop (e.g., the actual oop to pass as argument)"
isStruct
ifTrue:[valueOop := interpreterProxy fetchPointer: 0 ofObject: oop]
ifFalse:[valueOop := oop].
"Fetch and check the contents of the compiled spec"
- (interpreterProxy isIntegerObject: argSpec)
- ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
(interpreterProxy isWords: argSpec)
ifFalse:[self ffiFail: FFIErrorWrongType. ^nil].
ffiArgSpecSize := interpreterProxy slotSizeOf: argSpec.
ffiArgSpecSize = 0 ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
ffiArgSpec := self cCoerce: (interpreterProxy firstIndexableField: argSpec) to: 'int'.
ffiArgHeader := interpreterProxy longAt: ffiArgSpec.
"Do the actual preparation of the argument"
"Note: Order is important since FFIFlagStructure + FFIFlagPointer is used to represent 'typedef void* VoidPointer' and VoidPointer really is *struct* not pointer."
(ffiArgHeader anyMask: FFIFlagStructure) ifTrue:[
"argument must be ExternalStructure"
isStruct ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
(ffiArgHeader anyMask: FFIFlagAtomic)
ifTrue:[^self ffiFail: FFIErrorWrongType]. "bad combination"
^self ffiPushStructureContentsOf: valueOop].
(ffiArgHeader anyMask: FFIFlagPointer) ifTrue:[
+ "no integers (or characters) for pointers please"
+ (interpreterProxy isImmediate: oop)
- "no integers for pointers please"
- (interpreterProxy isIntegerObject: oop)
ifTrue:[^self ffiFail: FFIErrorIntAsPointer].
"but allow passing nil pointer for any pointer type"
oop == interpreterProxy nilObject ifTrue:[^self ffiPushPointer: nil].
"argument is reference to either atomic or structure type"
(ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
isStruct "e.g., ExternalData"
ifTrue:[^self ffiAtomicStructByReference: oop Class: oopClass]
ifFalse:[^self ffiAtomicArgByReference: oop Class: oopClass].
"********* NOTE: The above uses 'oop' not 'valueOop' (for ExternalData) ******"
].
"Needs to be external structure here"
isStruct ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
^self ffiPushPointerContentsOf: valueOop].
(ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
"argument is atomic value"
self ffiArgByValue: valueOop.
^0].
"None of the above - bad spec"
^self ffiFail: FFIErrorWrongType!
Item was changed:
----- Method: FFIPlugin>>ffiCheckReturn:With: (in category 'callout support') -----
ffiCheckReturn: retSpec With: retClass
"Make sure we can return an object of the given type"
<inline: true>
retClass == interpreterProxy nilObject ifFalse:[
(interpreterProxy includesBehavior: retClass
ThatOf: interpreterProxy classExternalStructure)
ifFalse:[^self ffiFail: FFIErrorBadReturn]].
ffiRetClass := retClass.
- (interpreterProxy isIntegerObject: retSpec)
- ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
(interpreterProxy isWords: retSpec)
ifFalse:[self ffiFail: FFIErrorWrongType. ^nil].
ffiRetSpecSize := interpreterProxy slotSizeOf: retSpec.
ffiRetSpecSize = 0 ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
ffiRetSpec := self cCoerce: (interpreterProxy firstIndexableField: retSpec) to: 'int'.
ffiRetHeader := interpreterProxy longAt: ffiRetSpec.
(self isAtomicType: ffiRetHeader) ifFalse:[
(ffiRetClass == interpreterProxy nilObject)
ifTrue:[^self ffiFail: FFIErrorBadReturn]].
(self ffiCan: (self cCoerce: ffiRetSpec to:'int*') Return: ffiRetSpecSize)
ifFalse:[self ffiFail: FFIErrorBadReturn]. "cannot return this type"
^0!
Item was changed:
----- Method: FFIPlugin>>ffiContentsOfHandle:errCode: (in category 'callout support') -----
ffiContentsOfHandle: oop errCode: errCode
"Make sure that the given oop is a valid external handle"
<inline: true>
- (interpreterProxy isIntegerObject: oop)
- ifTrue:[^self ffiFail: errCode].
(interpreterProxy isBytes: oop)
ifFalse:[^self ffiFail: errCode].
((interpreterProxy byteSizeOf: oop) == 4)
ifFalse:[^self ffiFail: errCode].
^interpreterProxy fetchPointer: 0 ofObject: oop!
Item was changed:
----- Method: FFIPlugin>>ffiIntegerValueOf: (in category 'callout support') -----
ffiIntegerValueOf: oop
"Support for generic callout. Return an integer value that is coerced as C would do."
| oopClass |
<inline: true>
(interpreterProxy isIntegerObject: oop) ifTrue:[^interpreterProxy integerValueOf: oop].
oop == interpreterProxy nilObject ifTrue:[^0]. "@@: should we really allow this????"
oop == interpreterProxy falseObject ifTrue:[^0].
oop == interpreterProxy trueObject ifTrue:[^1].
oopClass := interpreterProxy fetchClassOf: oop.
oopClass == interpreterProxy classFloat
ifTrue:[^(interpreterProxy floatValueOf: oop) asInteger].
oopClass == interpreterProxy classCharacter
+ ifTrue:[^interpreterProxy characterValueOf: oop].
- ifTrue:[^interpreterProxy fetchInteger: 0 ofObject: oop].
oopClass == interpreterProxy classLargePositiveInteger
ifTrue:[^interpreterProxy positive32BitValueOf: oop].
^interpreterProxy signed32BitValueOf: oop "<- will fail if not integer"!
Item was changed:
----- Method: FFIPlugin>>ffiValidateExternalData:AtomicType: (in category 'callout support') -----
ffiValidateExternalData: oop AtomicType: atomicType
"Validate if the given oop (an instance of ExternalData) can be passed as a pointer to the given atomic type."
| ptrType specOop spec specType |
<inline: true>
ptrType := interpreterProxy fetchPointer: 1 ofObject: oop.
- (interpreterProxy isIntegerObject: ptrType)
- ifTrue:[^self ffiFail: FFIErrorWrongType].
(interpreterProxy isPointers: ptrType)
ifFalse:[^self ffiFail: FFIErrorWrongType].
(interpreterProxy slotSizeOf: ptrType) < 2
ifTrue:[^self ffiFail: FFIErrorWrongType].
specOop := interpreterProxy fetchPointer: 0 ofObject: ptrType.
- (interpreterProxy isIntegerObject: specOop)
- ifTrue:[^self ffiFail: FFIErrorWrongType].
(interpreterProxy isWords: specOop)
ifFalse:[^self ffiFail: FFIErrorWrongType].
(interpreterProxy slotSizeOf: specOop) = 0
ifTrue:[^self ffiFail: FFIErrorWrongType].
spec := interpreterProxy fetchPointer: 0 ofObject: specOop.
(self isAtomicType: spec)
ifFalse:[^self ffiFail: FFIErrorWrongType].
specType := self atomicTypeOf: spec.
specType ~= atomicType ifTrue:[
"allow for signed/unsigned conversion but nothing else"
(atomicType > FFITypeBool and:[atomicType < FFITypeSingleFloat])
ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
((atomicType >> 1) = (specType >> 1))
ifFalse:[^self ffiFail: FFIErrorCoercionFailed]].
^0!
Item was changed:
----- Method: Interpreter>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
successFlag ifTrue: [
((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
ifFalse: [self success: false]].
successFlag ifTrue: [
bitsArray := self fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
ifTrue: [
bitsArraySize := self byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
successFlag ifTrue: [
+ ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'.
- BytesPerWord = 8
- ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
- ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
self success: ok].
successFlag ifTrue: [
self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
+ ((objectMemory isPointers: rcvr)
+ and: [(objectMemory lengthOf: rcvr) >= 4]) ifFalse:
+ [self success: false].
+ self successful ifTrue:
+ [bitsArray := objectMemory fetchPointer: 0 ofObject: rcvr.
- (rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
- self successful ifTrue: [
- ((objectMemory isPointers: rcvr) and: [(objectMemory lengthOf: rcvr) >= 4])
- ifFalse: [self success: false]].
- self successful ifTrue: [
- bitsArray := objectMemory fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
+ (objectMemory isWordsOrBytes: bitsArray)
+ ifTrue:
+ [bitsArraySize := objectMemory byteLengthOf: bitsArray.
- ((rcvr isIntegerObject: rcvr) not and: [objectMemory isWordsOrBytes: bitsArray])
- ifTrue: [
- bitsArraySize := objectMemory byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
+ self successful ifTrue:
+ [ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'.
- self successful ifTrue: [
- BytesPerWord = 8
- ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
- ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
self success: ok].
+ self successful ifTrue:
+ [self pop: 3] "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"!
- self successful ifTrue: [
- self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"!
Item was changed:
----- Method: InterpreterProxy>>isArray: (in category 'testing') -----
isArray: oop
+ ^(self isNonImmediate: oop) and: [oop class instSpec = 2]!
- ^(self isIntegerObject: oop) not and:[(oop class format bitAnd: 15) = 2]
- !
Item was changed:
----- Method: InterpreterProxy>>stackObjectValue: (in category 'stack access') -----
stackObjectValue: offset
| oop |
oop := self stackValue: offset.
+ (self isImmediate: oop) ifTrue: [self primitiveFail. ^ nil].
- (self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
^oop!
Item was changed:
----- Method: JPEGReaderPlugin>>colorComponent:from: (in category 'decoding') -----
colorComponent: aColorComponent from: oop
<var: #aColorComponent type: 'int *'>
- (interpreterProxy isIntegerObject: oop) ifTrue:[^false].
(interpreterProxy isPointers: oop) ifFalse:[^false].
(interpreterProxy slotSizeOf: oop) < MinComponentSize ifTrue:[^false].
aColorComponent at: CurrentXIndex put:
(interpreterProxy fetchInteger: CurrentXIndex ofObject: oop).
aColorComponent at: CurrentYIndex put:
(interpreterProxy fetchInteger: CurrentYIndex ofObject: oop).
aColorComponent at: HScaleIndex put:
(interpreterProxy fetchInteger: HScaleIndex ofObject: oop).
aColorComponent at: VScaleIndex put:
(interpreterProxy fetchInteger: VScaleIndex ofObject: oop).
aColorComponent at: BlockWidthIndex put:
(interpreterProxy fetchInteger: BlockWidthIndex ofObject: oop).
aColorComponent at: MCUWidthIndex put:
(interpreterProxy fetchInteger: MCUWidthIndex ofObject: oop).
aColorComponent at: PriorDCValueIndex put:
(interpreterProxy fetchInteger: PriorDCValueIndex ofObject: oop).
^interpreterProxy failed not!
Item was changed:
----- Method: JPEGReaderPlugin>>colorComponentBlocks:from: (in category 'decoding') -----
colorComponentBlocks: blocks from: oop
| arrayOop max blockOop |
<var: #blocks type: 'int **'>
- (interpreterProxy isIntegerObject: oop) ifTrue:[^false].
(interpreterProxy isPointers: oop) ifFalse:[^false].
(interpreterProxy slotSizeOf: oop) < MinComponentSize ifTrue:[^false].
arrayOop := interpreterProxy fetchPointer: MCUBlockIndex ofObject: oop.
- (interpreterProxy isIntegerObject: arrayOop) ifTrue:[^false].
(interpreterProxy isPointers: arrayOop) ifFalse:[^false].
max := interpreterProxy slotSizeOf: arrayOop.
max > MaxMCUBlocks ifTrue:[^false].
0 to: max-1 do:[:i|
blockOop := interpreterProxy fetchPointer: i ofObject: arrayOop.
- (interpreterProxy isIntegerObject: blockOop) ifTrue:[^false].
(interpreterProxy isWords: blockOop) ifFalse:[^false].
(interpreterProxy slotSizeOf: blockOop) = DCTSize2 ifFalse:[^false].
blocks at: i put: (interpreterProxy firstIndexableField: blockOop).
].
^interpreterProxy failed not!
Item was changed:
----- Method: JPEGReaderPlugin>>loadJPEGStreamFrom: (in category 'stream support') -----
loadJPEGStreamFrom: streamOop
| oop sz |
- (interpreterProxy slotSizeOf: streamOop) < 5 ifTrue:[^false].
(interpreterProxy isPointers: streamOop) ifFalse:[^false].
+ (interpreterProxy slotSizeOf: streamOop) < 5 ifTrue:[^false].
oop := interpreterProxy fetchPointer: 0 ofObject: streamOop.
- (interpreterProxy isIntegerObject: oop) ifTrue:[^false].
(interpreterProxy isBytes: oop) ifFalse:[^false].
jsCollection := interpreterProxy firstIndexableField: oop.
sz := interpreterProxy byteSizeOf: oop.
jsPosition := interpreterProxy fetchInteger: 1 ofObject: streamOop.
jsReadLimit := interpreterProxy fetchInteger: 2 ofObject: streamOop.
jsBitBuffer := interpreterProxy fetchInteger: 3 ofObject: streamOop.
jsBitCount := interpreterProxy fetchInteger: 4 ofObject: streamOop.
interpreterProxy failed ifTrue:[^false].
sz < jsReadLimit ifTrue:[^false].
(jsPosition < 0 or:[jsPosition >= jsReadLimit]) ifTrue:[^false].
^true!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
self successful ifTrue: [
((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
ifFalse: [self success: false]].
self successful ifTrue: [
bitsArray := self fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
ifTrue: [
bitsArraySize := self byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
self successful ifTrue: [
+ ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'.
- BytesPerWord = 8
- ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
- ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
self success: ok].
self successful ifTrue: [
self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
!
Item was changed:
----- Method: ScratchPlugin>>primOpenPortNamed (in category 'serial port') -----
primOpenPortNamed
"Open the port with the given name and baud rate."
| nameStr src nameOop baudRate count portNum |
<export: true>
<var: 'nameStr' declareC: 'char nameStr[1000]'>
+ <var: 'src' type: #'char *'>
- <var: 'src' declareC: 'char * src'>
nameOop := interpreterProxy stackValue: 1.
baudRate := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy success: (interpreterProxy isBytes: nameOop).
- ((interpreterProxy isIntegerObject: nameOop) or:
- [(interpreterProxy isBytes: nameOop) not]) ifTrue: [
- interpreterProxy success: false.
- ^ 0].
interpreterProxy failed ifTrue: [^ 0].
+ src := self cCoerce: (interpreterProxy firstIndexableField: nameOop) to: #'char *'.
- src := self cCoerce: (interpreterProxy firstIndexableField: nameOop) to: 'char *'.
count := interpreterProxy stSizeOf: nameOop.
0 to: count - 1 do: [:i | nameStr at: i put: (src at: i)].
nameStr at: count put: 0.
+ portNum := self SerialPortOpen: nameStr PortNamed: baudRate.
- portNum := self cCode: 'SerialPortOpenPortNamed(nameStr, baudRate)'.
portNum = -1 ifTrue: [interpreterProxy success: false. ^ 0].
interpreterProxy "pop args and rcvr, push result"
pop: 3
thenPush: (interpreterProxy integerObjectOf: portNum).
^ 0
!
Item was changed:
----- Method: ScratchPlugin>>primRead (in category 'serial port') -----
primRead
"Read data from the given serial port into the given buffer (a ByteArray or String). Answer the number of bytes read."
+ | portNum bufOop bytesRead |
- | portNum bufOop bufPtr bufSize bytesRead |
<export: true>
- <var: 'bufPtr' declareC: 'char *bufPtr'>
portNum := interpreterProxy stackIntegerValue: 1.
bufOop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isBytes: bufOop).
+ interpreterProxy failed ifTrue: [^ 0].
- ((interpreterProxy isIntegerObject: bufOop) or:
- [(interpreterProxy isBytes: bufOop) not]) ifTrue: [
- interpreterProxy success: false.
- ^ 0].
- bufPtr := self cCoerce: (interpreterProxy firstIndexableField: bufOop) to: 'char *'.
- bufSize := interpreterProxy stSizeOf: bufOop.
- interpreterProxy failed ifTrue: [^ nil].
+ bytesRead := self Serial: portNum
+ Port: (self cCoerce: (interpreterProxy firstIndexableField: bufOop) to: 'char *')
+ Read: (interpreterProxy stSizeOf: bufOop).
- bytesRead := self cCode: 'SerialPortRead(portNum, bufPtr, bufSize)'.
interpreterProxy pop: 3. "pop args and rcvr"
interpreterProxy pushInteger: bytesRead. "push result"
+ ^ 0!
- ^ 0
- !
Item was changed:
----- Method: ScratchPlugin>>primWrite (in category 'serial port') -----
primWrite
"Write data to the given serial port from the given buffer (a ByteArray or String). Answer the number of bytes written."
+ | portNum bufOop bytesWritten |
- | portNum bufOop bufPtr bufSize bytesWritten |
<export: true>
- <var: 'bufPtr' declareC: 'char *bufPtr'>
portNum := interpreterProxy stackIntegerValue: 1.
bufOop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isBytes: bufOop).
+ interpreterProxy failed ifTrue: [^ 0].
- ((interpreterProxy isIntegerObject: bufOop) or:
- [(interpreterProxy isBytes: bufOop) not]) ifTrue: [
- interpreterProxy success: false.
- ^ 0].
- bufPtr := self cCoerce: (interpreterProxy firstIndexableField: bufOop) to: 'char *'.
- bufSize := interpreterProxy stSizeOf: bufOop.
- interpreterProxy failed ifTrue: [^ nil].
+ bytesWritten := self Serial: portNum
+ Port: (self cCoerce: (interpreterProxy firstIndexableField: bufOop) to: 'char *')
+ Write: (interpreterProxy stSizeOf: bufOop).
- bytesWritten := self cCode: 'SerialPortWrite(portNum, bufPtr, bufSize)'.
+ interpreterProxy pop: 3. "pop args and rcvr"
- interpreterProxy pop: 3. "pop args and rcvr"
interpreterProxy pushInteger: bytesWritten. "push result"
+ ^ 0!
- ^ 0
- !
Item was changed:
----- Method: ScratchPlugin>>primitiveIsHidden (in category 'os functions') -----
primitiveIsHidden
"Answer true if the file or folder with the given path should be hidden from the user. On Windows, this is the value of the 'hidden' file property."
| pathOop src count fullPath result |
<export: true>
<var: 'fullPath' declareC: 'char fullPath[1000]'>
+ <var: 'src' type: #'char *'>
- <var: 'src' declareC: 'char * src'>
pathOop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isBytes: pathOop).
- ((interpreterProxy isIntegerObject: pathOop) or:
- [(interpreterProxy isBytes: pathOop) not]) ifTrue: [
- interpreterProxy success: false].
interpreterProxy failed ifTrue: [^ 0].
+ src := self cCoerce: (interpreterProxy firstIndexableField: pathOop) to: #'char *'.
- src := self cCoerce: (interpreterProxy firstIndexableField: pathOop) to: 'char *'.
count := interpreterProxy stSizeOf: pathOop.
count >= 1000 ifTrue: [interpreterProxy success: false. ^ 0].
0 to: count - 1 do: [:i | fullPath at: i put: (src at: i)].
fullPath at: count put: 0.
+ result := self IsFileOrFolderHidden: fullPath.
- result := self cCode: 'IsFileOrFolderHidden(fullPath)'.
interpreterProxy pop: 2. "pop arg and rcvr"
interpreterProxy pushBool: result ~= 0. "push result"
+ ^ 0!
- ^ 0
-
- !
Item was changed:
----- Method: ScratchPlugin>>primitiveOpenURL (in category 'os functions') -----
primitiveOpenURL
"Open a web browser on the given URL."
| urlStr src urlOop count |
<export: true>
<var: 'urlStr' declareC: 'char urlStr[2000]'>
+ <var: 'src' type: #'char *'>
- <var: 'src' declareC: 'char * src'>
urlOop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isBytes: urlOop).
- ((interpreterProxy isIntegerObject: urlOop) or:
- [(interpreterProxy isBytes: urlOop) not]) ifTrue: [
- interpreterProxy success: false].
interpreterProxy failed ifTrue: [^ 0].
+ src := self cCoerce: (interpreterProxy firstIndexableField: urlOop) to: #'char *'.
- src := self cCoerce: (interpreterProxy firstIndexableField: urlOop) to: 'char *'.
count := interpreterProxy stSizeOf: urlOop.
count >= 2000 ifTrue: [interpreterProxy success: false. ^ 0].
0 to: count - 1 do: [:i | urlStr at: i put: (src at: i)].
urlStr at: count put: 0.
+ self OpenURL: urlStr.
- self cCode: 'OpenURL(urlStr)'.
interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0!
- ^ 0
-
- !
Item was changed:
----- Method: ScratchPlugin>>primitiveSetUnicodePasteBuffer (in category 'os functions') -----
primitiveSetUnicodePasteBuffer
"Set the Mac OS X Unicode paste buffer."
| utf16 strOop count |
<export: true>
+ <var: 'utf16' declareC: 'short *utf16'>
- <var: 'utf16' declareC: 'short int *utf16'>
strOop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isBytes: strOop).
- ((interpreterProxy isIntegerObject: strOop) or:
- [(interpreterProxy isBytes: strOop) not]) ifTrue: [
- interpreterProxy success: false].
interpreterProxy failed ifTrue: [^ 0].
+ utf16 := self cCoerce: (interpreterProxy firstIndexableField: strOop) to: #'short *'.
- utf16 := self cCoerce: (interpreterProxy firstIndexableField: strOop) to: 'short int *'.
count := interpreterProxy stSizeOf: strOop.
+ self SetUnicodePaste: utf16 Buffer: count.
- self cCode: 'SetUnicodePasteBuffer(utf16, count)'.
interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0!
- ^ 0
-
- !
Item was changed:
----- Method: ScratchPlugin>>primitiveSetWindowTitle (in category 'os functions') -----
primitiveSetWindowTitle
"Set the title of the Scratch window."
| titleStr src titleOop count |
<export: true>
<var: 'titleStr' declareC: 'char titleStr[1000]'>
+ <var: 'src' type: #'char *'>
- <var: 'src' declareC: 'char * src'>
titleOop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isBytes: titleOop).
- ((interpreterProxy isIntegerObject: titleOop) or:
- [(interpreterProxy isBytes: titleOop) not]) ifTrue: [
- interpreterProxy success: false].
interpreterProxy failed ifTrue: [^ 0].
+ src := self cCoerce: (interpreterProxy firstIndexableField: titleOop) to: #'char *'.
- src := self cCoerce: (interpreterProxy firstIndexableField: titleOop) to: 'char *'.
count := interpreterProxy stSizeOf: titleOop.
count >= 1000 ifTrue: [interpreterProxy success: false. ^ 0].
0 to: count - 1 do: [:i | titleStr at: i put: (src at: i)].
titleStr at: count put: 0.
+ self SetScratchWindowTitle: titleStr.
- self cCode: 'SetScratchWindowTitle(titleStr)'.
interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0!
- ^ 0
-
- !
Item was changed:
----- Method: ScratchPlugin>>primitiveShortToLongPath (in category 'os functions') -----
primitiveShortToLongPath
"On Windows, convert a short file/path name into a long one. Fail on other platforms."
| shortPath longPath ptr shortPathOop result count resultOop |
<export: true>
<var: 'shortPath' declareC: 'char shortPath[1000]'>
<var: 'longPath' declareC: 'char longPath[1000]'>
+ <var: 'ptr' type: #'char *'>
- <var: 'ptr' declareC: 'char * ptr'>
shortPathOop := interpreterProxy stackValue: 0.
+ (interpreterProxy isBytes: shortPathOop) ifFalse:
+ [interpreterProxy success: false. ^ 0].
- ((interpreterProxy isIntegerObject: shortPathOop) or:
- [(interpreterProxy isBytes: shortPathOop) not]) ifTrue: [
- interpreterProxy success: false. ^ 0].
+ ptr := self cCoerce: (interpreterProxy firstIndexableField: shortPathOop) to: #'char *'.
- ptr := self cCoerce: (interpreterProxy firstIndexableField: shortPathOop) to: 'char *'.
count := interpreterProxy stSizeOf: shortPathOop.
count >= 1000 ifTrue: [interpreterProxy success: false. ^ 0].
0 to: count - 1 do: [:i | shortPath at: i put: (ptr at: i)].
shortPath at: count put: 0.
result := self cCode: 'WinShortToLongPath(shortPath, longPath, 1000)'.
result = -1 ifTrue: [interpreterProxy success: false. ^ 0].
+ count := self strlen: longPath.
- count := self cCode: 'strlen(longPath)'.
resultOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: count.
+ ptr := self cCoerce: (interpreterProxy firstIndexableField: resultOop) to: #'char *'.
- ptr := self cCoerce: (interpreterProxy firstIndexableField: resultOop) to: 'char *'.
0 to: count - 1 do: [:i | ptr at: i put: (longPath at: i)].
interpreterProxy pop: 2 thenPush: resultOop. "pop arg and rcvr, push result"
+ ^ 0!
- ^ 0
- !
Item was changed:
----- Method: SoundCodecPlugin>>primitiveGSMDecode (in category 'gsm 6.10 codec') -----
primitiveGSMDecode
| dstIndex dst srcIndex src frameCount state srcSize dstSize result srcDelta dstDelta |
<export: true>
dstIndex := interpreterProxy stackIntegerValue: 0.
+ dst := interpreterProxy stackValue: 1.
- dst := interpreterProxy stackObjectValue: 1.
srcIndex := interpreterProxy stackIntegerValue: 2.
+ src := interpreterProxy stackValue: 3.
- src := interpreterProxy stackObjectValue: 3.
frameCount := interpreterProxy stackIntegerValue: 4.
+ state := interpreterProxy stackValue: 5.
- state := interpreterProxy stackObjectValue: 5.
interpreterProxy success: (interpreterProxy isWords: dst).
interpreterProxy success: (interpreterProxy isBytes: src).
interpreterProxy success: (interpreterProxy isBytes: state).
interpreterProxy failed ifTrue:[^ nil].
srcSize := interpreterProxy slotSizeOf: src.
dstSize := (interpreterProxy slotSizeOf: dst) * 2.
+ self cCode: 'gsmDecode(state + BaseHeaderSize, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
- self cCode: 'gsmDecode(state + 4, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
interpreterProxy failed ifTrue:[^ nil].
result := interpreterProxy makePointwithxValue: srcDelta yValue: dstDelta.
interpreterProxy failed ifTrue:[^ nil].
+ interpreterProxy pop: 6 thenPush: result!
- interpreterProxy pop: 6.
- interpreterProxy push: result.
- !
Item was changed:
----- Method: SoundCodecPlugin>>primitiveGSMEncode (in category 'gsm 6.10 codec') -----
primitiveGSMEncode
| dstIndex dst srcIndex src frameCount state srcSize dstSize result srcDelta dstDelta |
<export: true>
dstIndex := interpreterProxy stackIntegerValue: 0.
+ dst := interpreterProxy stackValue: 1.
- dst := interpreterProxy stackObjectValue: 1.
srcIndex := interpreterProxy stackIntegerValue: 2.
+ src := interpreterProxy stackValue: 3.
- src := interpreterProxy stackObjectValue: 3.
frameCount := interpreterProxy stackIntegerValue: 4.
+ state := interpreterProxy stackValue: 5.
- state := interpreterProxy stackObjectValue: 5.
interpreterProxy success: (interpreterProxy isBytes: dst).
interpreterProxy success: (interpreterProxy isWords: src).
interpreterProxy success: (interpreterProxy isBytes: state).
interpreterProxy failed ifTrue:[^ nil].
srcSize := (interpreterProxy slotSizeOf: src) * 2.
dstSize := interpreterProxy slotSizeOf: dst.
+ self cCode: 'gsmEncode(state + BaseHeaderSize, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
- self cCode: 'gsmEncode(state + 4, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
interpreterProxy failed ifTrue:[^ nil].
result := interpreterProxy makePointwithxValue: srcDelta yValue: dstDelta.
interpreterProxy failed ifTrue:[^ nil].
+ interpreterProxy pop: 6 thenPush: result!
- interpreterProxy pop: 6.
- interpreterProxy push: result.
- !
Item was changed:
----- Method: SoundCodecPlugin>>primitiveGSMNewState (in category 'gsm 6.10 codec') -----
primitiveGSMNewState
+ | state |
- | stateBytes state |
<export: true>
- stateBytes := self cCode: 'gsmStateBytes()'.
state := interpreterProxy
+ instantiateClass: interpreterProxy classByteArray
+ indexableSize: self gsmStateBytes.
+ self gsmInitState: state + BaseHeaderSize.
+ interpreterProxy pop: 1 thenPush: state!
- instantiateClass: interpreterProxy classByteArray
- indexableSize: stateBytes.
- self cCode: 'gsmInitState(state + 4)'.
- interpreterProxy pop: 1.
- interpreterProxy push: state.
- !
Item was changed:
----- Method: SpurMemoryManager>>become:with:twoWay:copyHash: (in category 'become api') -----
become: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag
"All references to each object in array1 are swapped with all references to the
corresponding object in array2. That is, all pointers to one object are replaced
with with pointers to the other. The arguments must be arrays of the same length.
Answers PrimNoErr if the primitive succeeds, otherwise a relevant error code."
"Implementation: Uses lazy forwarding to defer updating references until message send."
| ec |
self assert: becomeEffectsFlags = 0.
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
(self isArray: array1) ifFalse:
[^PrimErrBadReceiver].
((self isArray: array2)
and: [(self numSlotsOf: array1) = (self numSlotsOf: array2)]) ifFalse:
[^PrimErrBadArgument].
(twoWayFlag or: [copyHashFlag])
ifTrue:
[ec := self containsOnlyValidBecomeObjects: array1 and: array2]
ifFalse:
[self followForwardedObjectFields: array2 toDepth: 0.
ec := self containsOnlyValidBecomeObjects: array1].
ec ~= 0 ifTrue: [^ec].
coInterpreter preBecomeAction.
twoWayFlag
ifTrue:
[self innerBecomeObjectsIn: array1 and: array2 copyHash: copyHashFlag]
ifFalse:
[self innerBecomeObjectsIn: array1 to: array2 copyHash: copyHashFlag].
self postBecomeScanClassTable.
+ self followSpecialObjectsOop.
coInterpreter postBecomeAction: becomeEffectsFlags.
becomeEffectsFlags := 0.
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
^PrimNoErr "success"!
Item was changed:
----- Method: SpurMemoryManager>>eliminateAndFreeForwarders (in category 'gc - global') -----
eliminateAndFreeForwarders
"As the final phase of global garbage collect, sweep the heap to follow
forwarders, then free forwarders, coalescing with free space as we go."
| lowestFree firstFree lastFree |
<inline: false>
self flag: 'this might be unnecessary. if we were to track firstFreeChunk we might be able to repeat the freeUnmarkedObjectsAndSortAndCoalesceFreeSpace; compact cycle until firstFreeChunk reaches a fixed point'.
self assert: (self isForwarded: nilObj) not.
self assert: (self isForwarded: falseObj) not.
self assert: (self isForwarded: trueObj) not.
self assert: (self isForwarded: self freeListsObj) not.
self assert: (self isForwarded: hiddenRootsObj) not.
self assert: (self isForwarded: classTableFirstPage) not.
+ self followSpecialObjectsOop.
- (self isForwarded: specialObjectsOop) ifTrue:
- [specialObjectsOop := self followForwarded: specialObjectsOop].
"N.B. we don't have to explicitly do mapInterpreterOops
since the scavenge below will do it."
self followForwardedObjStacks.
scavenger followRememberedForwardersAndForgetFreeObjects.
self doScavenge: DontTenureButDoUnmark.
self checkFreeSpace.
lowestFree := 0.
"sweep, following forwarders in all live objects, and finding the first forwarder."
self allOldSpaceEntitiesDo:
[:o|
((self isFreeObject: o) or: [self isForwarded: o])
ifTrue:
[lowestFree = 0 ifTrue:
[lowestFree := o]]
ifFalse:
[0 to: (self numPointerSlotsOf: o) - 1 do:
[:i| | f |
f := self fetchPointer: i ofObject: o.
(self isOopForwarded: f) ifTrue:
[f := self followForwarded: f.
+ self storePointer: i ofObject: o withValue: f]]]].
- self assert: (self isYoung: f) not.
- self storePointerUnchecked: i ofObject: o withValue: f]]]].
self checkFreeSpace.
lowestFree = 0 ifTrue: "yeah, right..."
[^self].
firstFree := lastFree := 0.
"Sweep from lowest forwarder, coalescing runs of forwarders and free objects."
self allOldSpaceEntitiesFrom: lowestFree do:
[:o|
(self isFreeObject: o)
ifTrue: "two cases, isolated, in which case leave alone, or adjacent,
in which case, remove from free set prior to coalesce."
[| next |
next := self objectAfter: o limit: endOfMemory.
self assert: (next = endOfMemory or: [(self isFreeObject: next) not]). "free chunks have already been coalesced"
(firstFree ~= 0
or: [next ~= endOfMemory and: [self isForwarded: next]]) ifTrue:
[firstFree = 0 ifTrue:
[firstFree := o].
lastFree := o.
self detachFreeObject: o.
self checkFreeSpace]]
ifFalse:
[(self isForwarded: o)
ifTrue:
[firstFree = 0 ifTrue:
[firstFree := o].
lastFree := o]
ifFalse:
[firstFree ~= 0 ifTrue:
[| start bytes |
start := self startOfObject: firstFree.
bytes := (self addressAfter: lastFree) - start.
self addFreeChunkWithBytes: bytes at: start.
self checkFreeSpace].
firstFree := 0]]].
firstFree ~= 0 ifTrue:
[| start bytes |
start := self startOfObject: firstFree.
bytes := (self addressAfter: lastFree) - start.
self addFreeChunkWithBytes: bytes at: start].
self checkFreeSpace!
Item was added:
+ ----- Method: SpurMemoryManager>>followSpecialObjectsOop (in category 'become implementation') -----
+ followSpecialObjectsOop
+ (self isForwarded: specialObjectsOop) ifTrue:
+ [specialObjectsOop := self followForwarded: specialObjectsOop]!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
self assert: thePage trace ~= StackPageTraced.
thePage trace: StackPageTraced.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
+ (objectMemory isOopForwarded: oop) ifTrue:
+ [oop := objectMemory followForwarded: oop.
+ stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
objectMemory markAndTrace: (self iframeMethod: theFP).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
+ (objectMemory isOopForwarded: oop) ifTrue:
+ [oop := objectMemory followForwarded: oop.
+ stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiArgument:Spec:Class:in: (in category 'callout support') -----
ffiArgument: oop Spec: argSpec Class: argClass in: calloutState
"Callout support. Prepare the given oop as argument.
argSpec defines the compiled spec for the argument.
argClass (if non-nil) defines the required (super)class for the argument."
<var: #calloutState type: #'CalloutState *'>
| valueOop oopClass isStruct nilOop |
<inline: false>
oopClass := interpreterProxy fetchClassOf: oop. "Prefetch class (we'll need it)"
nilOop := interpreterProxy nilObject.
"Do the necessary type checks"
argClass = nilOop ifFalse:[
"Type check 1:
Is the required class of the argument a subclass of ExternalStructure?"
(interpreterProxy includesBehavior: argClass
ThatOf: interpreterProxy classExternalStructure)
ifFalse:[^FFIErrorWrongType]. "Nope. Fail."
"Type check 2:
Is the class of the argument a subclass of required class?"
((nilOop = oop) or:[interpreterProxy includesBehavior: oopClass ThatOf: argClass])
ifFalse:[^FFIErrorCoercionFailed]. "Nope. Fail."
"Okay, we've passed the type check (so far)"
].
"Check if oopClass is a subclass of ExternalStructure.
If this is the case we'll work on it's handle and not the actual oop."
isStruct := false.
+ ((interpreterProxy isImmediate: oop) or:[oop = nilOop]) ifFalse:[
+ "#isPointers: will fail if oop is immediate so don't even attempt to use it"
- ((interpreterProxy isIntegerObject: oop) or:[oop = nilOop]) ifFalse:[
- "#isPointers: will fail if oop is SmallInteger so don't even attempt to use it"
(interpreterProxy isPointers: oop)
ifTrue:[isStruct := interpreterProxy includesBehavior: oopClass
ThatOf: interpreterProxy classExternalStructure.
(argClass = nilOop or:[isStruct])
ifFalse:[^FFIErrorCoercionFailed]].
"note: the test for #isPointers: above should speed up execution since no pointer type ST objects are allowed in external calls and thus if #isPointers: is true then the arg must be ExternalStructure to work. If it isn't then the code fails anyways so speed isn't an issue"
].
"Determine valueOop (e.g., the actual oop to pass as argument)"
isStruct
ifTrue:[valueOop := interpreterProxy fetchPointer: 0 ofObject: oop]
ifFalse:[valueOop := oop].
"Fetch and check the contents of the compiled spec"
- (interpreterProxy isIntegerObject: argSpec)
- ifTrue:[^FFIErrorWrongType].
(interpreterProxy isWords: argSpec)
ifFalse:[^FFIErrorWrongType].
calloutState ffiArgSpecSize: (interpreterProxy slotSizeOf: argSpec).
calloutState ffiArgSpecSize = 0 ifTrue:[^FFIErrorWrongType].
calloutState ffiArgSpec: (interpreterProxy firstIndexableField: argSpec).
calloutState ffiArgHeader: (interpreterProxy longAt: calloutState ffiArgSpec).
"Do the actual preparation of the argument"
"Note: Order is important since FFIFlagStructure + FFIFlagPointer is used to represent 'typedef void* VoidPointer' and VoidPointer really is *struct* not pointer."
(calloutState ffiArgHeader anyMask: FFIFlagStructure) ifTrue:[
"argument must be ExternalStructure"
isStruct ifFalse:[^FFIErrorCoercionFailed].
(calloutState ffiArgHeader anyMask: FFIFlagAtomic)
ifTrue:[^FFIErrorWrongType]. "bad combination"
^self ffiPushStructureContentsOf: valueOop in: calloutState].
(calloutState ffiArgHeader anyMask: FFIFlagPointer) ifTrue:[
+ "no integers (or characters) for pointers please"
+ (interpreterProxy isImmediate: oop)
- "no integers for pointers please"
- (interpreterProxy isIntegerObject: oop)
ifTrue:[^FFIErrorIntAsPointer].
"but allow passing nil pointer for any pointer type"
oop = nilOop ifTrue:[^self ffiPushPointer: nil in: calloutState].
"argument is reference to either atomic or structure type"
(calloutState ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
isStruct "e.g., ExternalData"
ifTrue:[^self ffiAtomicStructByReference: oop Class: oopClass in: calloutState]
ifFalse:[^self ffiAtomicArgByReference: oop Class: oopClass in: calloutState].
"********* NOTE: The above uses 'oop' not 'valueOop' (for ExternalData) ******"
].
"Needs to be external structure here"
isStruct ifFalse:[^FFIErrorCoercionFailed].
^self ffiPushPointerContentsOf: valueOop in: calloutState].
(calloutState ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
"argument is atomic value"
^self ffiArgByValue: valueOop in: calloutState].
"None of the above - bad spec"
^FFIErrorWrongType!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiContentsOfHandle:errCode: (in category 'callout support') -----
ffiContentsOfHandle: oop errCode: errCode
"Make sure that the given oop is a valid external handle"
<inline: true>
+ ((interpreterProxy isBytes: oop)
+ and: [(interpreterProxy byteSizeOf: oop) = 4]) ifFalse:
+ [^self ffiFail: errCode].
- (interpreterProxy isIntegerObject: oop)
- ifTrue:[^self ffiFail: errCode].
- (interpreterProxy isBytes: oop)
- ifFalse:[^self ffiFail: errCode].
- ((interpreterProxy byteSizeOf: oop) == 4)
- ifFalse:[^self ffiFail: errCode].
^interpreterProxy fetchPointer: 0 ofObject: oop!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiIntegerValueOf: (in category 'callout support') -----
ffiIntegerValueOf: oop
"Support for generic callout. Return an integer value that is coerced as C would do."
| oopClass |
<inline: true>
+ (interpreterProxy isIntegerObject: oop) ifTrue:
+ [^interpreterProxy integerValueOf: oop].
+ oop = interpreterProxy nilObject ifTrue: [^0]. "@@: should we really allow this????"
+ oop = interpreterProxy falseObject ifTrue: [^0].
+ oop = interpreterProxy trueObject ifTrue: [^1].
- (interpreterProxy isIntegerObject: oop) ifTrue:[^interpreterProxy integerValueOf: oop].
- oop = interpreterProxy nilObject ifTrue:[^0]. "@@: should we really allow this????"
- oop = interpreterProxy falseObject ifTrue:[^0].
- oop = interpreterProxy trueObject ifTrue:[^1].
oopClass := interpreterProxy fetchClassOf: oop.
+ oopClass = interpreterProxy classFloat ifTrue:
+ [^(interpreterProxy floatValueOf: oop) asInteger].
+ oopClass = interpreterProxy classCharacter ifTrue:
+ [^interpreterProxy characterValueOf: oop].
+ oopClass = interpreterProxy classLargePositiveInteger ifTrue:
+ [^interpreterProxy positive32BitValueOf: oop].
+ ^interpreterProxy signedMachineIntegerValueOf: oop "<- will fail if not integer"!
- oopClass = interpreterProxy classFloat
- ifTrue:[^(interpreterProxy floatValueOf: oop) asInteger].
- oopClass = interpreterProxy classCharacter
- ifTrue:[^interpreterProxy fetchInteger: 0 ofObject: oop].
- oopClass = interpreterProxy classLargePositiveInteger
- ifTrue:[^interpreterProxy positive32BitValueOf: oop].
- ^interpreterProxy signed32BitValueOf: oop "<- will fail if not integer"!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiValidateExternalData:AtomicType: (in category 'callout support') -----
ffiValidateExternalData: oop AtomicType: atomicType
"Validate if the given oop (an instance of ExternalData) can be passed as a pointer to the given atomic type."
| ptrType specOop spec specType |
<inline: true>
ptrType := interpreterProxy fetchPointer: 1 ofObject: oop.
+ ((interpreterProxy isPointers: ptrType)
+ and: [(interpreterProxy slotSizeOf: ptrType) >= 2]) ifFalse:
+ [^FFIErrorWrongType].
- (interpreterProxy isIntegerObject: ptrType)
- ifTrue:[^FFIErrorWrongType].
- (interpreterProxy isPointers: ptrType)
- ifFalse:[^FFIErrorWrongType].
- (interpreterProxy slotSizeOf: ptrType) < 2
- ifTrue:[^FFIErrorWrongType].
specOop := interpreterProxy fetchPointer: 0 ofObject: ptrType.
+ ((interpreterProxy isWords: specOop)
+ and: [(interpreterProxy slotSizeOf: specOop) > 0]) ifFalse:
+ [^FFIErrorWrongType].
- (interpreterProxy isIntegerObject: specOop)
- ifTrue:[^FFIErrorWrongType].
- (interpreterProxy isWords: specOop)
- ifFalse:[^FFIErrorWrongType].
- (interpreterProxy slotSizeOf: specOop) = 0
- ifTrue:[^FFIErrorWrongType].
spec := interpreterProxy fetchPointer: 0 ofObject: specOop.
+ (self isAtomicType: spec) ifFalse:
+ [^FFIErrorWrongType].
- (self isAtomicType: spec)
- ifFalse:[^FFIErrorWrongType].
specType := self atomicTypeOf: spec.
+ specType ~= atomicType ifTrue:
+ "Allow for signed/unsigned conversion but nothing else.
+ See FFIConstants class>>#initializeTypeConstants"
+ [(atomicType >= FFITypeUnsignedByte
+ and: [atomicType <= FFITypeSignedChar
+ and: [(atomicType >> 1) = (specType >> 1)]]) ifFalse:
+ [^FFIErrorCoercionFailed]].
- specType ~= atomicType ifTrue:[
- "allow for signed/unsigned conversion but nothing else"
- (atomicType > FFITypeBool and:[atomicType < FFITypeSingleFloat])
- ifFalse:[^FFIErrorCoercionFailed].
- ((atomicType >> 1) = (specType >> 1))
- ifFalse:[^FFIErrorCoercionFailed]].
^0!
Item was changed:
----- Method: UnicodePlugin>>asCString: (in category 'utility') -----
asCString: stringOop
"Return a C char * pointer into the given Squeak string object."
"Warning: A Squeak string is not necessarily null-terminated."
"Warning: the resulting pointer may become invalid after the next garbage collection and should only be using during the current primitive call."
+ <returnTypeC: #'char *'>
- <inline: false>
- <returnTypeC: 'char *'>
+ interpreterProxy success: (interpreterProxy isBytes: stringOop).
- ((interpreterProxy isIntegerObject: stringOop) or:
- [(interpreterProxy isBytes: stringOop) not]) ifTrue: [
- interpreterProxy success: false.
- ^ 0].
+ ^interpreterProxy failed
+ ifTrue: [0]
+ ifFalse: [self cCoerce: (interpreterProxy firstIndexableField: stringOop) to: #'char *']!
- ^ self cCoerce: (interpreterProxy firstIndexableField: stringOop) to: 'char *'
- !
Item was changed:
----- Method: UnicodePlugin>>cWordsPtr:minSize: (in category 'utility') -----
cWordsPtr: oop minSize: minSize
"Return a C pointer to the first indexable field of oop, which must be a words object of at least the given size."
"Warning: the resulting pointer may become invalid after the next garbage collection and should only be using during the current primitive call."
+ <returnTypeC: #'void *'>
- <inline: false>
- <returnTypeC: 'void *'>
interpreterProxy success:
+ ((interpreterProxy isWords: oop)
+ and: [(interpreterProxy stSizeOf: oop) >= minSize]).
+ ^interpreterProxy failed
+ ifTrue: [0]
+ ifFalse: [self cCoerce: (interpreterProxy firstIndexableField: oop) to: #'void *']!
- ((interpreterProxy isIntegerObject: oop) not and:
- [(interpreterProxy isWords: oop) and:
- [(interpreterProxy stSizeOf: oop) >= minSize]]).
- interpreterProxy failed ifTrue: [^ 0].
- ^ self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'void *'
- !
Item was changed:
----- Method: UnicodePlugin>>copyString:into:max: (in category 'utility') -----
copyString: stringOop into: stringPtr max: maxChars
"Copy the Squeak string into a temporary buffer and add a terminating null byte. Fail if there is not sufficent space in the buffer."
| srcPtr count |
<inline: false>
+ <var: 'stringPtr' type: #'char *'>
+ <var: 'srcPtr' type: #'char *'>
- <var: 'stringPtr' declareC: 'char *stringPtr'>
- <var: 'srcPtr' declareC: 'char *srcPtr'>
+ ((interpreterProxy isBytes: stringOop)
+ and: [(count := interpreterProxy stSizeOf: stringOop) < maxChars]) ifFalse:
+ [interpreterProxy success: false.
- ((interpreterProxy isIntegerObject: stringOop) or:
- [(interpreterProxy isBytes: stringOop) not]) ifTrue: [
- interpreterProxy success: false.
^ 0].
+ srcPtr := self cCoerce: (interpreterProxy firstIndexableField: stringOop) to: #'char *'.
- count := interpreterProxy stSizeOf: stringOop.
- count < maxChars ifFalse: [
- interpreterProxy success: false.
- ^ 0].
-
- srcPtr := self cCoerce: (interpreterProxy firstIndexableField: stringOop) to: 'char *'.
1 to: count do: [:i | self cCode: '*stringPtr++ = *srcPtr++'].
self cCode: '*stringPtr = 0'.
+ ^ 0!
- ^ 0
- !
Item was changed:
----- Method: UnicodePlugin>>primitiveClipboardGet (in category 'primitives') -----
primitiveClipboardGet
"Read the clipboard into the given UTF16 string.."
| utf16Oop utf16 utf16Length count |
<export: true>
+ <var: 'utf16' type: #'unsigned short *'>
- <var: 'utf16' declareC: 'unsigned short *utf16'>
utf16Oop := interpreterProxy stackValue: 0.
+ interpreterProxy success: (interpreterProxy isWords: utf16Oop).
- ((interpreterProxy isIntegerObject: utf16Oop) or:
- [(interpreterProxy isWords: utf16Oop) not]) ifTrue: [
- interpreterProxy success: false].
interpreterProxy failed ifTrue: [^ 0].
+ utf16 := self cCoerce: (interpreterProxy firstIndexableField: utf16Oop) to: #'unsigned short *'.
- utf16 := self cCoerce: (interpreterProxy firstIndexableField: utf16Oop) to: 'unsigned short *'.
utf16Length := 2 * (interpreterProxy stSizeOf: utf16Oop).
+ count := self unicodeClipboard: utf16 Get: utf16Length.
- count := self cCode: 'unicodeClipboardGet(utf16, utf16Length)'.
interpreterProxy pop: 2
thenPush: (interpreterProxy integerObjectOf: count).
+ ^ 0!
- ^ 0
- !
Item was changed:
----- Method: UnicodePlugin>>primitiveClipboardPut (in category 'primitives') -----
primitiveClipboardPut
"Set the clipboard to a UTF16 string.."
| strOop count utf16 utf16Length |
<export: true>
+ <var: 'utf16' type: #'unsigned short *'>
- <var: 'utf16' declareC: 'unsigned short *utf16'>
strOop := interpreterProxy stackValue: 1.
count := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy success: (interpreterProxy isWords: strOop).
- ((interpreterProxy isIntegerObject: strOop) or:
- [(interpreterProxy isWords: strOop) not]) ifTrue: [
- interpreterProxy success: false].
interpreterProxy failed ifTrue: [^ 0].
+ utf16 := self cCoerce: (interpreterProxy firstIndexableField: strOop) to: #'unsigned short *'.
- utf16 := self cCoerce: (interpreterProxy firstIndexableField: strOop) to: 'unsigned short *'.
utf16Length := 2 * (interpreterProxy stSizeOf: strOop).
((count >= 0) & (count < utf16Length)) ifTrue: [utf16Length := count].
+ self unicodeClipboard: utf16 Put: utf16Length.
- self cCode: 'unicodeClipboardPut(utf16, utf16Length)'.
interpreterProxy pop: 2. "pop args, leave rcvr on stack"
+ ^ 0!
- ^ 0
- !
Item was changed:
----- Method: WeDoPlugin>>primRead (in category 'translated prims') -----
primRead
"Read data from the WeDo port into the given buffer (a ByteArray or String). Answer the number of bytes read."
| bufOop bufPtr bufSize byteCount |
<export: true>
<var: 'bufPtr' declareC: 'char *bufPtr'>
bufOop := interpreterProxy stackValue: 0.
+ (interpreterProxy isBytes: bufOop) ifFalse: [
- ((interpreterProxy isIntegerObject: bufOop) or:
- [(interpreterProxy isBytes: bufOop) not]) ifTrue: [
interpreterProxy success: false.
^ 0].
bufPtr := self cCoerce: (interpreterProxy firstIndexableField: bufOop) to: 'char *'.
bufSize := interpreterProxy stSizeOf: bufOop.
interpreterProxy failed ifTrue: [^ 0].
byteCount := self cCode: 'WeDoRead(bufPtr, bufSize)'.
byteCount < 0 ifTrue: [
interpreterProxy success: false.
^ 0].
interpreterProxy pop: 2. "pop args and rcvr"
interpreterProxy pushInteger: byteCount. "push result"
^ 0
!
Item was changed:
----- Method: WeDoPlugin>>primWrite (in category 'translated prims') -----
primWrite
"Write data to the WeDo port from the given buffer (a ByteArray or String). Answer the number of bytes written."
| bufOop bufPtr bufSize byteCount |
<export: true>
<var: 'bufPtr' declareC: 'char *bufPtr'>
bufOop := interpreterProxy stackValue: 0.
+ (interpreterProxy isBytes: bufOop) ifFalse: [
- ((interpreterProxy isIntegerObject: bufOop) or:
- [(interpreterProxy isBytes: bufOop) not]) ifTrue: [
interpreterProxy success: false.
^ 0].
bufPtr := self cCoerce: (interpreterProxy firstIndexableField: bufOop) to: 'char *'.
bufSize := interpreterProxy stSizeOf: bufOop.
interpreterProxy failed ifTrue: [^ 0].
byteCount := self cCode: 'WeDoWrite(bufPtr, bufSize)'.
byteCount < 0 ifTrue: [
interpreterProxy success: false.
^ 0].
interpreterProxy pop: 2. "pop args and rcvr"
interpreterProxy pushInteger: byteCount. "push result"
^ 0
!
More information about the Vm-dev
mailing list