[Vm-dev] VM Maker: VMMaker.oscog-eem.573.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Jan 4 02:34:17 UTC 2014
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.573.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.573
Author: eem
Time: 3 January 2014, 6:31:08.416 pm
UUID: ac60f615-ad3b-4d47-96c4-b941027dcd2d
Ancestors: VMMaker.oscog-eem.570
Implement "accessor depth" of internal plugin primitives for Spur.
The accessor depth is how much state to traverse to check for failure
due to lazy forwarders. Scheme analyses the parse trees of primitive
methods and computes depth automatically.
Hide the per-primitive depth after the primitive name entry in
the exports table, hence maintaining compatibility between "classic"
and Spur, and allowing generated plugin files to continue to be
shared.
Cache the depth in the unused sessionID slot in the primitive 117
tuple.
Add some simple equivalence comparison for TParseNodes (which
are compared by identity for #= & hash).
Don't merge with tpr.571 or dtl.572 yet. These mistakenly include
the experimental changes in eem.566.
=============== Diff against VMMaker.oscog-eem.570 ===============
Item was changed:
----- Method: BitBltSimulation>>alphaBlend:with: (in category 'combination rules') -----
alphaBlend: sourceWord with: destinationWord
"Blend sourceWord with destinationWord, assuming both are 32-bit pixels.
The source is assumed to have 255*alpha in the high 8 bits of each pixel,
while the high 8 bits of the destinationWord will be ignored.
The blend produced is alpha*source + (1-alpha)*dest, with
the computation being performed independently on each color
component. The high byte of the result will be 0."
+ | alpha unAlpha result blendRB blendAG |
- | alpha unAlpha colorMask result blend shift |
<inline: false>
+ <return: 'unsigned int'>
+ <var: #sourceWord type: 'unsigned int'>
+ <var: #destinationWord type: 'unsigned int'>
+ <var: #blendRB type: 'unsigned int'>
+ <var: #blendAG type: 'unsigned int'>
+ <var: #result type: 'unsigned int'>
+ <var: #alpha type: 'unsigned int'>
+ <var: #unAlpha type: 'unsigned int'>
alpha := sourceWord >> 24. "High 8 bits of source pixel"
alpha = 0 ifTrue: [ ^ destinationWord ].
alpha = 255 ifTrue: [ ^ sourceWord ].
unAlpha := 255 - alpha.
- colorMask := 16rFF.
- result := 0.
+ blendRB := ((sourceWord bitAnd: 16rFF00FF) * alpha) +
+ ((destinationWord bitAnd: 16rFF00FF) * unAlpha)
+ + 16rFF00FF. "blend red and blue"
+
+ blendAG := (((sourceWord>> 8 bitOr: 16rFF0000) bitAnd: 16rFF00FF) * alpha) +
+ ((destinationWord>>8 bitAnd: 16rFF00FF) * unAlpha)
+ + 16rFF00FF. "blend alpha and green"
+
+ blendRB := blendRB + (blendRB - 16r10001 >> 8 bitAnd: 16rFF00FF) >> 8 bitAnd: 16rFF00FF. "divide by 255"
+ blendAG := blendAG + (blendAG - 16r10001 >> 8 bitAnd: 16rFF00FF) >> 8 bitAnd: 16rFF00FF.
+ result := blendRB bitOr: blendAG<<8.
- "red"
- shift := 0.
- blend := ((sourceWord >> shift bitAnd: colorMask) * alpha) +
- ((destinationWord>>shift bitAnd: colorMask) * unAlpha)
- + 254 // 255 bitAnd: colorMask.
- result := result bitOr: blend << shift.
- "green"
- shift := 8.
- blend := ((sourceWord >> shift bitAnd: colorMask) * alpha) +
- ((destinationWord>>shift bitAnd: colorMask) * unAlpha)
- + 254 // 255 bitAnd: colorMask.
- result := result bitOr: blend << shift.
- "blue"
- shift := 16.
- blend := ((sourceWord >> shift bitAnd: colorMask) * alpha) +
- ((destinationWord>>shift bitAnd: colorMask) * unAlpha)
- + 254 // 255 bitAnd: colorMask.
- result := result bitOr: blend << shift.
- "alpha (pre-multiplied)"
- shift := 24.
- blend := (alpha * 255) +
- ((destinationWord>>shift bitAnd: colorMask) * unAlpha)
- + 254 // 255 bitAnd: colorMask.
- result := result bitOr: blend << shift.
^ result
!
Item was changed:
----- Method: BitBltSimulation>>alphaBlendConst:with:paintMode: (in category 'combination rules') -----
alphaBlendConst: sourceWord with: destinationWord paintMode: paintMode
"Blend sourceWord with destinationWord using a constant alpha.
Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
The blend produced is alpha*source + (1.0-alpha)*dest, with the
computation being performed independently on each color component.
This function could eventually blend into any depth destination,
using the same color averaging and mapping as warpBlt.
paintMode = true means do nothing if the source pixel value is zero."
"This first implementation works with dest depths of 16 and 32 bits only.
Normal color mapping will allow sources of lower depths in this case,
and results can be mapped directly by truncation, so no extra color maps are needed.
To allow storing into any depth will require subsequent addition of two other
colormaps, as is the case with WarpBlt."
+ | pixMask destShifted sourceShifted destPixVal rgbMask sourcePixVal unAlpha result pixBlend shift blend maskShifted bitsPerColor blendAG blendRB |
- | pixMask destShifted sourceShifted destPixVal rgbMask sourcePixVal unAlpha result pixBlend shift blend maskShifted bitsPerColor |
<inline: false>
+ <return: 'unsigned int'>
+ <var: #sourceWord type: 'unsigned int'>
+ <var: #destinationWord type: 'unsigned int'>
+ <var: #blendRB type: 'unsigned int'>
+ <var: #blendAG type: 'unsigned int'>
+ <var: #result type: 'unsigned int'>
+ <var: #sourceAlpha type: 'unsigned int'>
+ <var: #unAlpha type: 'unsigned int'>
destDepth < 16 ifTrue: [^ destinationWord "no-op"].
unAlpha := 255 - sourceAlpha.
- pixMask := maskTable at: destDepth.
- destDepth = 16
- ifTrue: [bitsPerColor := 5]
- ifFalse:[bitsPerColor := 8].
- rgbMask := (1<<bitsPerColor) - 1.
- maskShifted := destMask.
- destShifted := destinationWord.
- sourceShifted := sourceWord.
result := destinationWord.
destPPW = 1 ifTrue:["32bpp blends include alpha"
paintMode & (sourceWord = 0) "painting a transparent pixel" ifFalse:[
+
+ blendRB := ((sourceWord bitAnd: 16rFF00FF) * sourceAlpha) +
+ ((destinationWord bitAnd: 16rFF00FF) * unAlpha) + 16rFF00FF. "blendRB red and blue"
+
+ blendAG := ((sourceWord>> 8 bitAnd: 16rFF00FF) * sourceAlpha) +
+ ((destinationWord>>8 bitAnd: 16rFF00FF) * unAlpha) + 16rFF00FF. "blendRB alpha and green"
+
+ blendRB := blendRB + (blendRB - 16r10001 >> 8 bitAnd: 16rFF00FF) >> 8 bitAnd: 16rFF00FF. "divide by 255"
+ blendAG := blendAG + (blendAG - 16r10001 >> 8 bitAnd: 16rFF00FF) >> 8 bitAnd: 16rFF00FF.
+ result := blendRB bitOr: blendAG<<8.
- result := 0.
- 1 to: 4 do:[:i|
- shift := (i-1)*8.
- blend := (((sourceWord>>shift bitAnd: rgbMask) * sourceAlpha)
- + ((destinationWord>>shift bitAnd: rgbMask) * unAlpha))
- + 254 // 255 bitAnd: rgbMask.
- result := result bitOr: blend<<shift].
].
] ifFalse:[
+ pixMask := maskTable at: destDepth.
+ bitsPerColor := 5.
+ rgbMask := 16r1F.
+ maskShifted := destMask.
+ destShifted := destinationWord.
+ sourceShifted := sourceWord.
1 to: destPPW do:[:j |
sourcePixVal := sourceShifted bitAnd: pixMask.
((maskShifted bitAnd: pixMask) = 0 "no effect if outside of dest rectangle"
or: [paintMode & (sourcePixVal = 0) "or painting a transparent pixel"])
ifFalse:
[destPixVal := destShifted bitAnd: pixMask.
pixBlend := 0.
1 to: 3 do:
[:i | shift := (i-1)*bitsPerColor.
blend := (((sourcePixVal>>shift bitAnd: rgbMask) * sourceAlpha)
+ ((destPixVal>>shift bitAnd: rgbMask) * unAlpha))
+ 254 // 255 bitAnd: rgbMask.
pixBlend := pixBlend bitOr: blend<<shift].
+ result := (result bitAnd: (pixMask << (j-1*16)) bitInvert32)
+ bitOr: pixBlend << (j-1*16)].
- destDepth = 16
- ifTrue: [result := (result bitAnd: (pixMask << (j-1*16)) bitInvert32)
- bitOr: pixBlend << (j-1*16)]
- ifFalse: [result := pixBlend]].
maskShifted := maskShifted >> destDepth.
sourceShifted := sourceShifted >> destDepth.
destShifted := destShifted >> destDepth].
].
^ result
!
Item was changed:
----- Method: BitBltSimulation>>alphaBlendScaled:with: (in category 'combination rules') -----
alphaBlendScaled: sourceWord with: destinationWord
"Blend sourceWord with destinationWord using the alpha value from sourceWord.
Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
In contrast to alphaBlend:with: the color produced is
srcColor + (1-srcAlpha) * dstColor
e.g., it is assumed that the source color is already scaled."
+ | unAlpha rb ag |
- | unAlpha dstMask srcMask b g r a |
<inline: false> "Do NOT inline this into optimized loops"
+ <var: #sourceWord type: 'unsigned int'>
+ <var: #destinationWord type: 'unsigned int'>
+ <var: #rb type: 'unsigned int'>
+ <var: #ag type: 'unsigned int'>
+ <var: #unAlpha type: 'unsigned int'>
+ unAlpha := 255 - (sourceWord >> 24). "High 8 bits of source pixel is source opacity (ARGB format)"
+ rb := ((destinationWord bitAnd: 16rFF00FF) * unAlpha >> 8 bitAnd: 16rFF00FF) + (sourceWord bitAnd: 16rFF00FF). "blend red and blue components"
+ ag := ((destinationWord>>8 bitAnd: 16rFF00FF) * unAlpha >> 8 bitAnd: 16rFF00FF) + (sourceWord>>8 bitAnd: 16rFF00FF). "blend alpha and green components"
+ rb := (rb bitAnd: 16rFF00FF) bitOr: (rb bitAnd: 16r1000100) * 16rFF >> 8. "saturate red and blue components if there is a carry"
+ ag := (ag bitAnd: 16rFF00FF) << 8 bitOr: (ag bitAnd: 16r1000100) * 16rFF. "saturate alpha and green components if there is a carry"
+ ^ag bitOr: rb "recompose"!
- unAlpha := 255 - (sourceWord >> 24). "High 8 bits of source pixel"
- dstMask := destinationWord.
- srcMask := sourceWord.
- b := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
- b > 255 ifTrue:[b := 255].
- dstMask := dstMask >> 8.
- srcMask := srcMask >> 8.
- g := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
- g > 255 ifTrue:[g := 255].
- dstMask := dstMask >> 8.
- srcMask := srcMask >> 8.
- r := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
- r > 255 ifTrue:[r := 255].
- dstMask := dstMask >> 8.
- srcMask := srcMask >> 8.
- a := (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
- a > 255 ifTrue:[a := 255].
- ^(((((a << 8) + r) << 8) + g) << 8) + b!
Item was added:
+ ----- Method: BitBltSimulation>>partitionedAdd:to:nBits:componentMask:carryOverflowMask: (in category 'combination rules') -----
+ partitionedAdd: word1 to: word2 nBits: nBits componentMask: componentMask carryOverflowMask: carryOverflowMask
+ "Add word1 to word2 as nParts partitions of nBits each.
+ This is useful for packed pixels, or packed colors"
+ | carryOverflow sum w1 w2 |
+ "Use unsigned int everywhere because it has a well known arithmetic model without undefined behavior w.r.t. overflow and shifts"
+ <var: #word1 type: 'unsigned int'>
+ <var: #word2 type: 'unsigned int'>
+ <var: #w1 type: 'unsigned int'>
+ <var: #w2 type: 'unsigned int'>
+ <var: #componentMask type: 'unsigned int'>
+ <var: #carryOverflowMask type: 'unsigned int'>
+ <var: #carryOverflow type: 'unsigned int'>
+ <var: #sum type: 'unsigned int'>
+ w1 := word1 bitAnd: carryOverflowMask. "mask to remove high bit of each component"
+ w2 := word2 bitAnd: carryOverflowMask.
+ sum := (word1 bitXor: w1)+(word2 bitXor: w2). "sum without high bit to avoid overflowing over next component"
+ carryOverflow := (w1 bitAnd: w2) bitOr: ((w1 bitOr: w2) bitAnd: sum). "detect overflow condition for saturating"
+ ^((sum bitXor: w1)bitXor:w2) "sum high bit without overflow"
+ bitOr: carryOverflow>>(nBits-1) * componentMask "saturate in case of overflow"!
Item was removed:
- ----- Method: BitBltSimulation>>partitionedAdd:to:nBits:nPartitions: (in category 'combination rules') -----
- partitionedAdd: word1 to: word2 nBits: nBits nPartitions: nParts
- "Add word1 to word2 as nParts partitions of nBits each.
- This is useful for packed pixels, or packed colors"
- | mask sum result maskedWord1 |
- "In C, most arithmetic operations answer the same bit pattern regardless of the operands being signed or unsigned ints
- (this is due to the way 2's complement numbers work). However, comparisions might fail. Add the proper declaration of
- words as unsigned int in those cases where comparisions are done (jmv)"
- <var: #word1 type: 'unsigned int'>
- <var: #word2 type: 'unsigned int'>
- <var: #mask type: 'unsigned int'>
- <var: #sum type: 'unsigned int'>
- <var: #result type: 'unsigned int'>
- <var: #maskedWord1 type: 'unsigned int'>
- mask := maskTable at: nBits. "partition mask starts at the right"
- result := 0.
- 1 to: nParts do:
- [:i |
- maskedWord1 := word1 bitAnd: mask.
- sum := maskedWord1 + (word2 bitAnd: mask).
- (sum <= mask "result must not carry out of partition"
- and: [ sum >= maskedWord1 ]) "This is needed because in C, integer arithmetic overflows silently!! (jmv)"
- ifTrue: [result := result bitOr: sum]
- ifFalse: [result := result bitOr: mask].
- mask := mask << nBits "slide left to next partition"].
- ^ result
- !
Item was changed:
----- Method: BitBltSimulation>>rgbAdd:with: (in category 'combination rules') -----
rgbAdd: sourceWord with: destinationWord
<inline: false>
+ <var: #sourceWord type: 'unsigned int'>
+ <var: #destinationWord type: 'unsigned int'>
+ <var: #carryOverflowMask type: 'unsigned int'>
+ <var: #componentMask type: 'unsigned int'>
+ | componentMask carryOverflowMask |
destDepth < 16 ifTrue:
["Add each pixel separately"
+ componentMask := 1<<destDepth-1.
+ carryOverflowMask := 16rFFFFFFFF//componentMask<<(destDepth-1).
^ self partitionedAdd: sourceWord to: destinationWord
+ nBits: destDepth componentMask: componentMask carryOverflowMask: carryOverflowMask].
- nBits: destDepth nPartitions: destPPW].
destDepth = 16 ifTrue:
["Add RGB components of each pixel separately"
+ componentMask := 16r1F.
+ carryOverflowMask := 16r42104210.
+ ^ (self partitionedAdd: (sourceWord bitAnd: 16r7FFF7FFF) to: (destinationWord bitAnd: 16r7FFF7FFF) "make sure that the unused bit is at 0"
+ nBits: 5 componentMask: componentMask carryOverflowMask: carryOverflowMask)]
- ^ (self partitionedAdd: sourceWord to: destinationWord
- nBits: 5 nPartitions: 3)
- + ((self partitionedAdd: sourceWord>>16 to: destinationWord>>16
- nBits: 5 nPartitions: 3) << 16)]
ifFalse:
["Add RGBA components of the pixel separately"
+ componentMask := 16rFF.
+ carryOverflowMask := 16r80808080.
^ self partitionedAdd: sourceWord to: destinationWord
+ nBits: 8 componentMask: componentMask carryOverflowMask: carryOverflowMask]!
- nBits: 8 nPartitions: 4]!
Item was added:
+ ----- Method: CCodeGenerator>>accessorChainsForMethod:interpreterClass: (in category 'spur primitive compilation') -----
+ accessorChainsForMethod: method interpreterClass: interpreterClass
+ "Answer a set of access paths from arguments through objects, in the method, assuming
+ it is a primitive. This is in support of Spur's lazy become. A primitive may fail because it
+ may encounter a forwarder. The primitive failure code needs to know to what depth it
+ must follow arguments to follow forwarders and, if any are found and followed, retry the
+ primitive. This method determines that depth. It starts by collecting references to the
+ stack and then follows these through assignments to variables and use of accessor
+ methods such as fetchPointer:ofObject:. For example
+ | obj field |
+ obj := self stackTop.
+ field := objectMemory fetchPointer: 1 ofObject: obj.
+ self storePointer: 1 ofObject: field withValue: (self stackValue: 1)
+ has depth 2, since field is accessed, and field is an element of obj."
+
+ | accessors assignments roots chains extendedChains extended lastPass |
+ self accessorsAndAssignmentsForMethod: method
+ actuals: {}
+ depth: 0
+ interpreterClass: interpreterClass
+ into: [:theRoots :theAccessors :theAssignments|
+ roots := theRoots.
+ accessors := theAccessors.
+ assignments := theAssignments].
+ "Compute the transitive closure of assignments of accessor sends or variables to variables from the roots.
+ Start from the stack accesses (the roots).
+ On the last pass look only for accessors of the targets of the tip assignments."
+ chains := OrderedCollection new.
+ roots do: [:root| chains addAll: (assignments
+ select: [:assignment| assignment expression = root]
+ thenCollect: [:assignment| OrderedCollection with: assignment])].
+ lastPass := false.
+ [extended := false.
+ extendedChains := OrderedCollection new: chains size * 2.
+ chains do:
+ [:chain| | tip refs accessorRefs variableRefs |
+ tip := chain last variable.
+ refs := accessors select: [:send| send args anySatisfy: [:arg| tip isSameAs: arg]].
+ lastPass ifFalse:
+ [accessorRefs := refs collect: [:send|
+ assignments
+ detect: [:assignment|
+ assignment expression = send
+ and: [(chain includes: assignment) not]]
+ ifNone: []]
+ thenSelect: [:assignmentOrNil| assignmentOrNil notNil].
+ variableRefs := assignments select:
+ [:assignment|
+ (tip isSameAs: assignment expression)
+ and: [(tip isSameAs: assignment variable) not
+ and: [(chain includes: assignment) not]]].
+ refs := (Set withAll: accessorRefs) addAll: variableRefs; yourself].
+ refs isEmpty
+ ifTrue:
+ [extendedChains add: chain]
+ ifFalse:
+ [lastPass ifFalse: [extended := true].
+ self assert: (refs noneSatisfy: [:assignment| chain includes: assignment]).
+ extendedChains addAll: (refs collect: [:assignment| chain, {assignment}])]].
+ extended or: [lastPass not]] whileTrue:
+ [chains := extendedChains.
+ extended ifFalse: [lastPass := true]].
+ ^chains!
Item was added:
+ ----- Method: CCodeGenerator>>accessorDepthDeterminationFollowsSelfSends (in category 'spur primitive compilation') -----
+ accessorDepthDeterminationFollowsSelfSends
+ ^false!
Item was added:
+ ----- Method: CCodeGenerator>>accessorDepthForChain: (in category 'spur primitive compilation') -----
+ accessorDepthForChain: chain "OrderedCollection"
+ "Answer the actual number of accessors in the access chain, filtering out assignments of variables to variables."
+ | accessorDepth |
+ accessorDepth := 0.
+ chain do:
+ [:node|
+ (node isAssignment and: [node expression isVariable]) ifFalse:
+ [accessorDepth := accessorDepth + 1]].
+ ^accessorDepth!
Item was added:
+ ----- Method: CCodeGenerator>>accessorDepthForMethod: (in category 'spur primitive compilation') -----
+ accessorDepthForMethod: method
+ "Compute the depth the method traverses object structure, assuming it is a primitive.
+ This is in support of Spur's lazy become. A primitive may fail because it may encounter
+ a forwarder. The primitive failure code needs to know to what depth it must follow
+ arguments to follow forwarders and, if any are found and followed, retry the primitive.
+ This method determines that depth. It starts by collecting references to the stack and
+ then follows these through assignments to variables and use of accessor methods
+ such as fetchPointer:ofObject:. For example
+ | obj field |
+ obj := self stackTop.
+ field := objectMemory fetchPointer: 1 ofObject: obj.
+ self storePointer: 1 ofObject: field withValue: (self stackValue: 1)
+ has depth 2, since field is accessed, and field is an element of obj."
+
+ ^((self
+ accessorChainsForMethod: method
+ interpreterClass: (vmClass ifNil: [StackInterpreter]))
+ inject: 0
+ into: [:length :chain| length max: (self accessorDepthForChain: chain)]) - 1!
Item was added:
+ ----- Method: CCodeGenerator>>accessorDepthForSelector: (in category 'spur primitive compilation') -----
+ accessorDepthForSelector: selector
+ ^(selector = #initialiseModule
+ or: [InterpreterPlugin includesSelector: selector]) ifFalse:
+ [(self methodNamed: selector) ifNotNil:
+ [:m| self accessorDepthForMethod: m]]!
Item was added:
+ ----- Method: CCodeGenerator>>accessorsAndAssignmentsForMethod:actuals:depth:interpreterClass:into: (in category 'spur primitive compilation') -----
+ accessorsAndAssignmentsForMethod: method actuals: actualParameters depth: depth interpreterClass: interpreterClass into: aTrinaryBlock
+ "Evaluate aTrinaryBlock with the root accessor sends, accessor sends and assignments in the method."
+ | accessors assignments roots |
+ accessors := Set new.
+ assignments := Set new.
+ roots := Set new.
+ actualParameters with: method args do:
+ [:actual :argName|
+ (actual isVariable or: [actual isSend]) ifTrue:
+ [assignments add: (TAssignmentNode new
+ setVariable: (TVariableNode new setName: argName)
+ expression: actual)]].
+ method parseTree nodesDo:
+ [:node|
+ node isSend ifTrue:
+ [(interpreterClass isStackAccessor: node selector) ifTrue:
+ [roots add: node].
+ (interpreterClass isObjectAccessor: node selector) ifTrue:
+ [accessors add: node].
+ (self accessorDepthDeterminationFollowsSelfSends
+ and: [node receiver isVariable
+ and: [node receiver name = 'self'
+ and: [roots isEmpty
+ or: [node args anySatisfy:
+ [:arg|
+ (roots includes: arg)
+ or: [(accessors includes: arg)
+ or: [assignments anySatisfy: [:assignment| assignment variable isSameAs: arg]]]]]]]]) ifTrue:
+ [self accessorsAndAssignmentsForSubMethodNamed: node selector
+ actuals: node args
+ depth: depth + 1
+ interpreterClass: interpreterClass
+ into: [:subRoots :subAccessors :subAssignments|
+ (subRoots isEmpty and: [subAccessors isEmpty and: [subAssignments isEmpty]]) ifFalse:
+ [roots addAll: subRoots.
+ accessors add: node.
+ accessors addAll: subAccessors.
+ assignments addAll: subAssignments]]]].
+ (node isAssignment
+ and: [(roots includes: node expression)
+ or: [(accessors includes: node expression)
+ or: [node expression isVariable and: [node expression name ~= 'nil']]]]) ifTrue:
+ [assignments add: node]].
+ ^aTrinaryBlock
+ value: roots
+ value: accessors
+ value: assignments!
Item was added:
+ ----- Method: CCodeGenerator>>emitExportsNamed:pluginName:on: (in category 'C code generator') -----
+ emitExportsNamed: exportsNamePrefix pluginName: pluginName on: aStream
+ "Store all the exported primitives in the form used by the internal named prim system."
+ | nilVMClass |
+ (nilVMClass := vmClass isNil) ifTrue:
+ [vmClass := StackInterpreter].
+ aStream cr; cr; nextPutAll: 'void* '; nextPutAll: exportsNamePrefix; nextPutAll: '_exports[][3] = {'.
+ (self sortStrings: self exportedPrimitiveNames) do:
+ [:primName|
+ aStream cr;
+ nextPutAll:' {"';
+ nextPutAll: pluginName;
+ nextPutAll: '", "';
+ nextPutAll: primName.
+ (self accessorDepthForSelector: primName asSymbol) ifNotNil:
+ [:depth| "store the accessor depth in a hidden byte immediately after the primName"
+ self assert: depth < 128.
+ aStream
+ nextPutAll: '\000\';
+ nextPutAll: ((depth bitAnd: 255) printStringBase: 8 nDigits: 3)].
+ aStream
+ nextPutAll:'", (void*)';
+ nextPutAll: primName;
+ nextPutAll:'},'].
+ aStream cr; tab; nextPutAll:'{NULL, NULL, NULL}'; cr; nextPutAll: '};'; cr.
+ nilVMClass ifTrue:
+ [vmClass := nil]!
Item was changed:
----- Method: CCodeGenerator>>emitExportsOn: (in category 'C code generator') -----
emitExportsOn: aStream
+ "Store all the exported primitives in the form used by the internal named prim system."
+ (vmClass isNil or: [vmClass isInterpreterClass]) ifTrue:
+ [self emitExportsNamed: 'vm' pluginName: '' on: aStream]!
- "Store all the exported primitives in a form to be used by the internal named prim system"
- (vmClass isNil or: [vmClass isInterpreterClass]) ifFalse:
- [^self].
- aStream nextPutAll:'
-
- void* vm_exports[][3] = {'.
- (self sortStrings: self exportedPrimitiveNames) do:[:primName|
- aStream cr;
- nextPutAll:' {"", "';
- nextPutAll: primName;
- nextPutAll:'", (void*)';
- nextPutAll: primName;
- nextPutAll:'},'.
- ].
- aStream nextPutAll:'
- {NULL, NULL, NULL}
- };
- '!
Item was added:
+ InterpreterPlugin subclass: #CameraPlugin
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Plugins'!
Item was added:
+ ----- Method: CameraPlugin class>>hasHeaderFile (in category 'translation') -----
+ hasHeaderFile
+
+ ^true!
Item was added:
+ ----- Method: CameraPlugin>>primCameraName (in category 'primitives') -----
+ primCameraName
+ "Get the name for the camera with the given number. Fail if the camera number is greater than the number of available cameras."
+
+ | cameraNum nameStr count resultOop dst |
+ self export: true.
+ self var: 'nameStr' declareC: 'char* nameStr'.
+ self var: 'dst' declareC: 'char* dst'.
+
+ cameraNum := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ nameStr := self cCode: 'CameraName(cameraNum)'.
+ nameStr = nil ifTrue: [
+ interpreterProxy success: false.
+ ^ 0].
+
+ count := self cCode: '(int) strlen(nameStr)'.
+ resultOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: count.
+ dst := self cCoerce: (interpreterProxy firstIndexableField: resultOop) to: 'char *'.
+ 0 to: count - 1 do: [:i | dst at: i put: (nameStr at: i)].
+
+ interpreterProxy pop: 2 thenPush: resultOop. "pop arg and rcvr, push result"
+ ^ 0
+ !
Item was added:
+ ----- Method: CameraPlugin>>primCloseCamera (in category 'primitives') -----
+ primCloseCamera
+ "Close the camera. Do nothing if it was not open."
+
+ | cameraNum |
+ self export: true.
+ cameraNum := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ self cCode: 'CameraClose(cameraNum)'.
+
+ interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: CameraPlugin>>primFrameExtent (in category 'primitives') -----
+ primFrameExtent
+ "Answer the frame extent of the given camera, or zero if the camera is not open. The extent is 16 bits of width and height packed into a single integer."
+
+ | cameraNum e |
+ self export: true.
+ cameraNum := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ e := self cCode: 'CameraExtent(cameraNum)'.
+
+ interpreterProxy pop: 2 thenPush: (interpreterProxy integerObjectOf: e). "pop rcvr & arg, push int result"
+ ^ 0
+ !
Item was added:
+ ----- 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 |
+ self export: true.
+ self var: 'bitmap' declareC: 'unsigned char *bitmap'.
+
+ cameraNum := interpreterProxy stackIntegerValue: 1.
+ bitmapOop := interpreterProxy stackValue: 0.
+ ((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 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 added:
+ ----- Method: CameraPlugin>>primGetParam (in category 'primitives') -----
+ primGetParam
+ "Answer the given integer parameter of the given camera."
+
+ | cameraNum paramNum result |
+ self export: true.
+ cameraNum := interpreterProxy stackIntegerValue: 1.
+ paramNum := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ result := self cCode: 'CameraGetParam(cameraNum, paramNum)'.
+
+ interpreterProxy pop: 3 thenPush: (interpreterProxy integerObjectOf: result). "pop rcvr & args, push int result"
+ ^ 0
+ !
Item was added:
+ ----- Method: CameraPlugin>>primOpenCamera (in category 'primitives') -----
+ primOpenCamera
+ "Open a camera. Takes one argument, the index of the device to open."
+
+ | cameraNum desiredFrameWidth desiredFrameHeight ok |
+ self export: true.
+
+ cameraNum := interpreterProxy stackIntegerValue: 2.
+ desiredFrameWidth := interpreterProxy stackIntegerValue: 1.
+ desiredFrameHeight := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ ok := self cCode: 'CameraOpen(cameraNum, desiredFrameWidth, desiredFrameHeight)'.
+ ok = 0 ifTrue: [
+ interpreterProxy success: false.
+ ^ 0].
+
+ interpreterProxy pop: 3. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was changed:
----- Method: Interpreter>>dumpImage: (in category 'image save/restore') -----
dumpImage: fileName
"Dump the entire image out to the given file. Intended for debugging only."
| f dataSize result |
<export: true>
<var: #f type: 'sqImageFile'>
f := self cCode: 'sqImageFileOpen(fileName, "wb")'.
f = nil ifTrue: [^-1].
dataSize := endOfMemory - self startOfMemory.
+ result := self cCode: 'sqImageFileWrite(pointerForOop(memory()), sizeof(unsigned char), dataSize, f)'.
- result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
self cCode: 'sqImageFileClose(f)'.
^result
!
Item was added:
+ InterpreterPlugin subclass: #ScratchPlugin
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Plugins'!
+
+ !ScratchPlugin commentStamp: 'jm 11/8/2006 18:33' prior: 0!
+ This plugin combines a number of primitives needed by Scratch including:
+
+ a. primitives that manipulate 24-bit color images (i.e. 32-bit deep Forms but alpha is ignored)
+ b. primitive to open browsers, find the user's documents folder, set the window title and other host OS functions
+
+ This plugin includes new serial port primitives, including support for named serial ports. The underlying plugin code can support up to 32 simultaenously open ports.
+
+ Port options for Set/GetOption primitives:
+ 1. baud rate
+ 2. data bits
+ 3. stop bits
+ 4. parity type
+ 5. input flow control type
+ 6. output flow control type
+
+ Handshake lines (options 20-25 for Set/GetOption primitives):
+ 20. DTR (output line)
+ 21. RTS (output line)
+ 22. CTS (input line)
+ 23. DSR (input line)
+ 24. CD (input line)
+ 25. RI (input line)
+
+ !
Item was added:
+ ----- Method: ScratchPlugin class>>hasHeaderFile (in category 'translation') -----
+ hasHeaderFile
+
+ ^true!
Item was added:
+ ----- Method: ScratchPlugin>>bitmap:at:putH:s:v: (in category 'private') -----
+ bitmap: bitmap at: i putH: hue s: saturation v: brightness
+
+ | hI hF p q t v outPix |
+ self inline: true.
+ self var: 'bitmap' declareC: 'unsigned int *bitmap'.
+
+ hI := hue // 60. "integer part of hue (0..5)"
+ hF := hue \\ 60. "fractional part ofhue"
+ p := (1000 - saturation) * brightness.
+ q := (1000 - ((saturation * hF) // 60)) * brightness.
+ t := (1000 - ((saturation * (60 - hF)) // 60)) * brightness.
+
+ v := (brightness * 1000) // 3922.
+ p := p // 3922.
+ q := q // 3922.
+ t := t // 3922.
+
+ 0 = hI ifTrue: [outPix := ((v bitShift: 16) + (t bitShift: 8) + p)].
+ 1 = hI ifTrue: [outPix := ((q bitShift: 16) + (v bitShift: 8) + p)].
+ 2 = hI ifTrue: [outPix := ((p bitShift: 16) + (v bitShift: 8) + t)].
+ 3 = hI ifTrue: [outPix := ((p bitShift: 16) + (q bitShift: 8) + v)].
+ 4 = hI ifTrue: [outPix := ((t bitShift: 16) + (p bitShift: 8) + v)].
+ 5 = hI ifTrue: [outPix := ((v bitShift: 16) + (p bitShift: 8) + q)].
+
+ outPix = 0 ifTrue: [outPix := 1]. "convert transparent to 1"
+ bitmap at: i put: outPix.
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>checkedFloatPtrOf: (in category 'private') -----
+ checkedFloatPtrOf: oop
+ "Return an unsigned int pointer to the first indexable word of oop, which must be a words object."
+
+ self inline: true.
+ self returnTypeC: 'double *'.
+
+ interpreterProxy success: (interpreterProxy isWordsOrBytes: oop).
+ interpreterProxy failed ifTrue: [^ 0].
+ ^ self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'double *'
+ !
Item was added:
+ ----- Method: ScratchPlugin>>checkedUnsignedIntPtrOf: (in category 'private') -----
+ checkedUnsignedIntPtrOf: oop
+ "Return an unsigned int pointer to the first indexable word of oop, which must be a words object."
+
+ self inline: true.
+ self returnTypeC: 'unsigned int *'.
+
+ interpreterProxy success: (interpreterProxy isWords: oop).
+ interpreterProxy failed ifTrue: [^ 0].
+ ^ self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'unsigned int *'
+ !
Item was added:
+ ----- Method: ScratchPlugin>>hueFromR:G:B:min:max: (in category 'private') -----
+ hueFromR: r G: g B: b min: min max: max
+ "Answer the hue, an angle between 0 and 360."
+
+ | span result |
+ self inline: true.
+
+ span := max - min.
+ span = 0 ifTrue: [^ 0].
+
+ r = max
+ ifTrue: [result := ((60 * (g - b)) // span)]
+ ifFalse: [
+ g = max
+ ifTrue: [result := 120 + ((60 * (b - r)) // span)]
+ ifFalse: [result := 240 + ((60 * (r - g)) // span)]].
+
+ result < 0 ifTrue: [^ result + 360].
+ ^ result
+ !
Item was added:
+ ----- Method: ScratchPlugin>>interpolate:and:frac: (in category 'private') -----
+ interpolate: pix1 and: pix2 frac: frac2
+ "Answer the interpolated pixel value between the given two pixel values. If either pixel is zero (transparent) answer the other pixel. If both pixels are transparent, answer transparent. The fraction is between 0 and 1023, out of a total range of 1024."
+
+ | frac1 r g b result |
+ self inline: true.
+
+ pix1 = 0 ifTrue: [^ pix2]. "pix1 is transparent"
+ pix2 = 0 ifTrue: [^ pix1]. "pix2 is transparent"
+
+ frac1 := 1024 - frac2.
+ r := ((frac1 * ((pix1 bitShift: -16) bitAnd: 16rFF)) + (frac2 * ((pix2 bitShift: -16) bitAnd: 16rFF))) // 1024.
+ g := ((frac1 * ((pix1 bitShift: -8) bitAnd: 16rFF)) + (frac2 * ((pix2 bitShift: -8) bitAnd: 16rFF))) // 1024.
+ b := ((frac1 * (pix1 bitAnd: 16rFF)) + (frac2 * (pix2 bitAnd: 16rFF))) // 1024.
+ result := (r bitShift: 16) + (g bitShift: 8) + b.
+ result = 0 ifTrue: [result := 1].
+ ^ result
+ !
Item was added:
+ ----- Method: ScratchPlugin>>interpolatedFrom:x:y:width:height: (in category 'private') -----
+ interpolatedFrom: bitmap x: xFixed y: yFixed width: w height: h
+ "Answer the interpolated pixel value from the given bitmap at the given point. The x and y coordinates are fixed-point integers with 10 bits of fraction (i.e. they were multiplied by 1024, then truncated). If the given point is right on an edge, answer the nearest edge pixel value. If it is entirely outside of the image, answer 0 (transparent)."
+
+ | x y xFrac yFrac index topPix bottomPix |
+ self inline: true.
+ self var: 'bitmap' declareC: 'unsigned int *bitmap'.
+
+ x := xFixed bitShift: -10.
+ (x < -1 or: [x >= w]) ifTrue: [^ 0].
+ y := yFixed bitShift: -10.
+ (y < -1 or: [y >= h]) ifTrue: [^ 0].
+
+ xFrac := xFixed bitAnd: 1023.
+ x = -1 ifTrue: [x := 0. xFrac := 0]. "left edge"
+ x = (w - 1) ifTrue: [xFrac := 0]. "right edge"
+
+ yFrac := yFixed bitAnd: 1023.
+ y = -1 ifTrue: [y := 0. yFrac := 0]. "top edge"
+ y = (h - 1) ifTrue: [yFrac := 0]. "bottom edge"
+
+ index := (y * w) + x "for squeak: + 1".
+ topPix := (bitmap at: index) bitAnd: 16rFFFFFF.
+ xFrac > 0 ifTrue: [
+ topPix := self interpolate: topPix and: ((bitmap at: index + 1) bitAnd: 16rFFFFFF) frac: xFrac].
+
+ yFrac = 0 ifTrue: [^ topPix]. "no y fraction, so just use value from top row"
+
+ index := ((y + 1) * w) + x "for squeak: + 1".
+ bottomPix := (bitmap at: index) bitAnd: 16rFFFFFF.
+ xFrac > 0 ifTrue: [
+ bottomPix := self interpolate: bottomPix and: ((bitmap at: index + 1) bitAnd: 16rFFFFFF) frac: xFrac].
+
+ ^ self interpolate: topPix and: bottomPix frac: yFrac
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primClose (in category 'serial port') -----
+ primClose
+ "Close the given serial port."
+
+ | portNum |
+ self export: true.
+ portNum := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ self cCode: 'SerialPortClose(portNum)'.
+
+ interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primGetOption (in category 'serial port') -----
+ primGetOption
+ "Return the given option value for the given serial port."
+
+ | portNum attrNum result |
+ self export: true.
+ portNum := interpreterProxy stackIntegerValue: 1.
+ attrNum := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ result := self cCode: 'SerialPortGetOption(portNum, attrNum)'.
+ result = -1 ifTrue: [interpreterProxy success: false. ^ 0].
+
+ interpreterProxy pop: 3. "pop args and rcvr, push result"
+ interpreterProxy pushInteger: result.
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primIsPortOpen (in category 'serial port') -----
+ primIsPortOpen
+ "Answer the true if the given port is open."
+
+ | portNum result |
+ self export: true.
+ portNum := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ result := self cCode: 'SerialPortIsOpen(portNum)'.
+
+ interpreterProxy pop: 2. "pop arg and rcvr"
+ interpreterProxy pushBool: result ~= 0. "push result"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primOpenPortNamed (in category 'serial port') -----
+ primOpenPortNamed
+ "Open the port with the given name and baud rate."
+
+ | nameStr src nameOop baudRate count portNum |
+ self export: true.
+ self var: 'nameStr' declareC: 'char nameStr[1000]'.
+ self var: 'src' declareC: 'char * src'.
+
+ nameOop := interpreterProxy stackValue: 1.
+ baudRate := interpreterProxy stackIntegerValue: 0.
+
+ ((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 *'.
+ count := interpreterProxy stSizeOf: nameOop.
+ 0 to: count - 1 do: [:i | nameStr at: i put: (src at: i)].
+ nameStr at: count put: 0.
+
+ 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 added:
+ ----- Method: ScratchPlugin>>primPortCount (in category 'serial port') -----
+ primPortCount
+ "Answer the number of serial ports."
+
+ | result |
+ self export: true.
+
+ result := self cCode: 'SerialPortCount()'.
+ result = -1 ifTrue: [interpreterProxy success: false. ^ 0].
+
+ interpreterProxy
+ pop: 1 thenPush: (interpreterProxy integerObjectOf: result). "pop rcvr, push result"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primPortName (in category 'serial port') -----
+ primPortName
+ "Get the name for the port with the given number. Fail if the port number is greater than the number of available ports. Port numbering starts with 1."
+
+ | portIndex nameStr count resultOop dst |
+ self export: true.
+ self var: 'nameStr' declareC: 'char nameStr[1000]'.
+ self var: 'dst' declareC: 'char* dst'.
+
+ portIndex := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ self cCode: 'SerialPortName(portIndex, nameStr, 1000)'.
+
+ count := self cCode: 'strlen(nameStr)'.
+ count = 0 ifTrue: [
+ interpreterProxy success: false.
+ ^ 0].
+
+ resultOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: count.
+ dst := self cCoerce: (interpreterProxy firstIndexableField: resultOop) to: 'char *'.
+ 0 to: count - 1 do: [:i | dst at: i put: (nameStr at: i)].
+
+ interpreterProxy pop: 2 thenPush: resultOop. "pop arg and rcvr, push result"
+ ^ 0
+ !
Item was added:
+ ----- 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 bufPtr bufSize bytesRead |
+ self export: true.
+ self var: 'bufPtr' declareC: 'char *bufPtr'.
+
+ portNum := interpreterProxy stackIntegerValue: 1.
+ bufOop := interpreterProxy stackValue: 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 cCode: 'SerialPortRead(portNum, bufPtr, bufSize)'.
+
+ interpreterProxy pop: 3. "pop args and rcvr"
+ interpreterProxy pushInteger: bytesRead. "push result"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primSetOption (in category 'serial port') -----
+ primSetOption
+ "Return the given option value for the given serial port."
+
+ | portNum attrNum attrValue result |
+ self export: true.
+ portNum := interpreterProxy stackIntegerValue: 2.
+ attrNum := interpreterProxy stackIntegerValue: 1.
+ attrValue := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ result := self cCode: 'SerialPortSetOption(portNum, attrNum, attrValue)'.
+ result = -1 ifTrue: [interpreterProxy success: false. ^ 0].
+
+ interpreterProxy pop: 3. "pop args; leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- 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 bufPtr bufSize bytesWritten |
+ self export: true.
+ self var: 'bufPtr' declareC: 'char *bufPtr'.
+
+ portNum := interpreterProxy stackIntegerValue: 1.
+ bufOop := interpreterProxy stackValue: 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 cCode: 'SerialPortWrite(portNum, bufPtr, bufSize)'.
+
+ interpreterProxy pop: 3. "pop args and rcvr"
+ interpreterProxy pushInteger: bytesWritten. "push result"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveBlur (in category 'other filters') -----
+ primitiveBlur
+
+ | inOop outOop width in out sz height n rTotal gTotal bTotal pix outPix |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+ self var: 'out' declareC: 'unsigned int *out'.
+
+ inOop := interpreterProxy stackValue: 2.
+ outOop := interpreterProxy stackValue: 1.
+ width := interpreterProxy stackIntegerValue: 0.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ sz := interpreterProxy stSizeOf: inOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: outOop) = sz).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ height := sz // width.
+ 1 to: height - 2 do: [:y |
+ 1 to: width - 2 do: [:x |
+ n := rTotal := gTotal := bTotal := 0.
+ -1 to: 1 do: [:dY |
+ -1 to: 1 do: [:dX |
+ pix := (in at: ((y + dY) * width) + (x + dX) "add 1 when testing in Squeak") bitAnd: 16rFFFFFF.
+ pix = 0 ifFalse: [ "skip transparent pixels"
+ rTotal := rTotal + ((pix bitShift: -16) bitAnd: 16rFF).
+ gTotal := gTotal + ((pix bitShift: -8) bitAnd: 16rFF).
+ bTotal := bTotal + (pix bitAnd: 16rFF).
+ n := n + 1]]].
+ n = 0
+ ifTrue: [outPix := 0]
+ ifFalse: [outPix := ((rTotal // n) bitShift: 16) + ((gTotal // n) bitShift: 8) + (bTotal // n)].
+ out at: ((y * width) + x "add 1 when testing in Squeak") put: outPix]].
+
+ interpreterProxy pop: 3. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveBrightnessShift (in category 'hsv filters') -----
+ primitiveBrightnessShift
+
+ | inOop outOop shift in sz out pix r g b max min hue saturation brightness |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+ self var: 'out' declareC: 'unsigned int *out'.
+
+ inOop := interpreterProxy stackValue: 2.
+ outOop := interpreterProxy stackValue: 1.
+ shift := interpreterProxy stackIntegerValue: 0.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ sz := interpreterProxy stSizeOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: outOop) = sz).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ 0 to: sz - 1 do: [:i |
+ pix := (in at: i) bitAnd: 16rFFFFFF.
+ pix = 0 ifFalse: [ "skip pixel values of 0 (transparent)"
+ r := (pix bitShift: -16) bitAnd: 16rFF.
+ g := (pix bitShift: -8) bitAnd: 16rFF.
+ b := pix bitAnd: 16rFF.
+
+ "find min and max color components"
+ max := min := r.
+ g > max ifTrue: [max := g].
+ b > max ifTrue: [max := b].
+ g < min ifTrue: [min := g].
+ b < min ifTrue: [min := b].
+
+ "find current hue with range 0 to 360"
+ hue := self hueFromR: r G: g B: b min: min max: max.
+
+ "find current saturation and brightness with range 0 to 1000"
+ max = 0 ifTrue: [saturation := 0] ifFalse: [saturation := ((max - min) * 1000) // max].
+ brightness := (max * 1000) // 255.
+
+ "compute new brigthness"
+ brightness := brightness + (shift * 10).
+ brightness > 1000 ifTrue: [brightness := 1000].
+ brightness < 0 ifTrue: [brightness := 0].
+
+ self bitmap: out at: i putH: hue s: saturation v: brightness]].
+
+ interpreterProxy pop: 3. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveCondenseSound (in category 'sound') -----
+ primitiveCondenseSound
+
+ | srcOop dstOop factor sz src dst count max v |
+ self export: true.
+ self var: 'src' declareC: 'short *src'.
+ self var: 'dst' declareC: 'short *dst'.
+
+ srcOop := interpreterProxy stackValue: 2.
+ dstOop := interpreterProxy stackValue: 1.
+ factor := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy success: (interpreterProxy isWords: srcOop).
+ interpreterProxy success: (interpreterProxy isWords: dstOop).
+
+ count := (2 * (interpreterProxy stSizeOf: srcOop)) // factor.
+ sz := 2 * (interpreterProxy stSizeOf: dstOop).
+ interpreterProxy success: (sz >= count).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ src := self cCoerce: (interpreterProxy firstIndexableField: srcOop) to: 'short *'.
+ dst := self cCoerce: (interpreterProxy firstIndexableField: dstOop) to: 'short *'.
+
+ 1 to: count do: [:i |
+ max := 0.
+ 1 to: factor do: [:j |
+ v := self cCode: '*src++'.
+ v < 0 ifTrue: [v := 0 - v].
+ v > max ifTrue: [max := v]].
+ self cCode: '*dst++ = max'].
+
+ interpreterProxy pop: 3. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveDoubleSize (in category 'scaling') -----
+ primitiveDoubleSize
+
+ | in out inOop outOop inW inH outW outH dstX dstY baseIndex pix i |
+ self export: true.
+ self var: 'in' declareC: 'int *in'.
+ self var: 'out' declareC: 'int *out'.
+
+ inOop := interpreterProxy stackValue: 7.
+ inW := interpreterProxy stackIntegerValue: 6.
+ inH := interpreterProxy stackIntegerValue: 5.
+ outOop := interpreterProxy stackValue: 4.
+ outW := interpreterProxy stackIntegerValue: 3.
+ outH := interpreterProxy stackIntegerValue: 2.
+ dstX := interpreterProxy stackIntegerValue: 1.
+ dstY := interpreterProxy stackIntegerValue: 0.
+
+ in := self checkedUnsignedIntPtrOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ interpreterProxy success: (dstX + (2 * inW)) < outW.
+ interpreterProxy success: (dstY + (2 * inH)) < outH.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ 0 to: inH - 1 do: [:y |
+ baseIndex := ((dstY + (2 * y)) * outW) + dstX.
+ 0 to: inW - 1 do: [:x |
+ pix := in at: x + (y * inW).
+ i := baseIndex + (2 * x).
+ out at: i put: pix.
+ out at: i + 1 put: pix.
+ out at: i + outW put: pix.
+ out at: i + outW + 1 put: pix]].
+
+ interpreterProxy pop: 8. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveExtractChannel (in category 'sound') -----
+ primitiveExtractChannel
+
+ | srcOop dstOop rightFlag sz src dst |
+ self export: true.
+ self var: 'src' declareC: 'short *src'.
+ self var: 'dst' declareC: 'short *dst'.
+
+ srcOop := interpreterProxy stackValue: 2.
+ dstOop := interpreterProxy stackValue: 1.
+ rightFlag := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
+ interpreterProxy success: (interpreterProxy isWords: srcOop).
+ interpreterProxy success: (interpreterProxy isWords: dstOop).
+
+ sz := interpreterProxy stSizeOf: srcOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: dstOop) >= (sz // 2)).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ src := self cCoerce: (interpreterProxy firstIndexableField: srcOop) to: 'short *'.
+ dst := self cCoerce: (interpreterProxy firstIndexableField: dstOop) to: 'short *'.
+
+ rightFlag ifTrue: [self cCode: 'src++'].
+ 1 to: sz do: [:i | self cCode: '*dst++ = *src; src += 2'].
+
+ interpreterProxy pop: 3. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveFisheye (in category 'other filters') -----
+ primitiveFisheye
+
+ | inOop outOop width in out sz height centerX centerY dx dy ang pix power r srcX srcY scaledPower |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+ self var: 'out' declareC: 'unsigned int *out'.
+ self var: 'scaleX' declareC: 'double scaleX'.
+ self var: 'scaleY' declareC: 'double scaleY'.
+ self var: 'whirlRadians' declareC: 'double whirlRadians'.
+ self var: 'radiusSquared' declareC: 'double radiusSquared'.
+ self var: 'dx' declareC: 'double dx'.
+ self var: 'dy' declareC: 'double dy'.
+ self var: 'd' declareC: 'double d'.
+ self var: 'factor' declareC: 'double factor'.
+ self var: 'ang' declareC: 'double ang'.
+ self var: 'sina' declareC: 'double sina'.
+ self var: 'cosa' declareC: 'double cosa'.
+ self var: 'r' declareC: 'double r'.
+ self var: 'scaledPower' declareC: 'double scaledPower'.
+
+ inOop := interpreterProxy stackValue: 3.
+ outOop := interpreterProxy stackValue: 2.
+ width := interpreterProxy stackIntegerValue: 1.
+ power := interpreterProxy stackIntegerValue: 0.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ sz := interpreterProxy stSizeOf: inOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: outOop) = sz).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ "calculate height, center, scales, radius, whirlRadians, and radiusSquared"
+ height := sz // width.
+ centerX := width // 2.
+ centerY := height // 2.
+
+ height := sz // width.
+ centerX := width // 2.
+ centerY := height // 2.
+ scaledPower := power / 100.0.
+
+ 0 to: width - 1 do: [:x |
+ 0 to: height - 1 do: [:y |
+ dx := (x - centerX) / centerX asFloat.
+ dy := (y - centerY) / centerY asFloat.
+ r := ((dx * dx) + (dy * dy)) sqrt raisedTo: scaledPower.
+ r <= 1.0
+ ifTrue: [
+ ang := self cCode: 'atan2(dy,dx)'.
+ srcX := (1024 * (centerX + ((r * ang cos) * centerX))) asInteger.
+ srcY := (1024 * (centerY + ((r * ang sin) * centerY))) asInteger]
+ ifFalse: [
+ srcX := 1024 * x.
+ srcY := 1024 * y].
+ pix := self interpolatedFrom: in
+ x: srcX
+ y: srcY
+ width: width
+ height: height.
+ out at: ((y * width) + x "+ 1 for Squeak") put: pix]].
+
+ interpreterProxy pop: 4. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveGetFolderPath (in category 'os functions') -----
+ primitiveGetFolderPath
+ "Get the path for the special folder with given ID. Fail if the folder ID is out of range."
+
+ | nameStr dst folderID count resultOop |
+ self export: true.
+ self var: 'nameStr' declareC: 'char nameStr[2000]'.
+ self var: 'dst' declareC: 'char* dst'.
+
+ folderID := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifTrue: [^ 0].
+
+ self cCode: 'GetFolderPathForID(folderID, nameStr, 2000)'.
+
+ count := self cCode: 'strlen(nameStr)'.
+ resultOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: count.
+ dst := self cCoerce: (interpreterProxy firstIndexableField: resultOop) to: 'char *'.
+ 0 to: count - 1 do: [:i | dst at: i put: (nameStr at: i)].
+
+ interpreterProxy pop: 2 thenPush: resultOop. "pop arg and rcvr, push result"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveHalfSizeAverage (in category 'scaling') -----
+ primitiveHalfSizeAverage
+
+ | in inW inH out outW outH srcX srcY dstX dstY dstW dstH srcIndex dstIndex pixel r g b |
+ self export: true.
+ self var: 'in' declareC: 'int *in'.
+ self var: 'out' declareC: 'int *out'.
+
+ in := self checkedUnsignedIntPtrOf: (interpreterProxy stackValue: 11).
+ inW := interpreterProxy stackIntegerValue: 10.
+ inH := interpreterProxy stackIntegerValue: 9.
+ out := self checkedUnsignedIntPtrOf: (interpreterProxy stackValue: 8).
+ outW := interpreterProxy stackIntegerValue: 7.
+ outH := interpreterProxy stackIntegerValue: 6.
+ srcX := interpreterProxy stackIntegerValue: 5.
+ srcY := interpreterProxy stackIntegerValue: 4.
+ dstX := interpreterProxy stackIntegerValue: 3.
+ dstY := interpreterProxy stackIntegerValue: 2.
+ dstW := interpreterProxy stackIntegerValue: 1.
+ dstH := interpreterProxy stackIntegerValue: 0.
+
+ interpreterProxy success: (srcX >= 0) & (srcY >= 0).
+ interpreterProxy success: (srcX + (2 * dstW)) <= inW.
+ interpreterProxy success: (srcY + (2 * dstH)) <= inH.
+ interpreterProxy success: (dstX >= 0) & (dstY >= 0).
+ interpreterProxy success: (dstX + dstW) <= outW.
+ interpreterProxy success: (dstY + dstH) <= outH.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ 0 to: dstH - 1 do: [:y |
+ srcIndex := (inW * (srcY + (2 * y))) + srcX.
+ dstIndex := (outW * (dstY + y)) + dstX.
+ 0 to: dstW - 1 do: [:x |
+ pixel := in at: srcIndex.
+ r := pixel bitAnd: 16rFF0000.
+ g := pixel bitAnd: 16rFF00.
+ b := pixel bitAnd: 16rFF.
+
+ pixel := in at: srcIndex + 1.
+ r := r + (pixel bitAnd: 16rFF0000).
+ g := g + (pixel bitAnd: 16rFF00).
+ b := b + (pixel bitAnd: 16rFF).
+
+ pixel := in at: srcIndex + inW.
+ r := r + (pixel bitAnd: 16rFF0000).
+ g := g + (pixel bitAnd: 16rFF00).
+ b := b + (pixel bitAnd: 16rFF).
+
+ pixel := in at: srcIndex + inW + 1.
+ r := r + (pixel bitAnd: 16rFF0000).
+ g := g + (pixel bitAnd: 16rFF00).
+ b := b + (pixel bitAnd: 16rFF).
+
+ "store combined RGB into target bitmap"
+ out at: dstIndex put:
+ (((r bitShift: -2) bitAnd: 16rFF0000) bitOr:
+ (((g bitShift: -2) bitAnd: 16rFF00) bitOr: (b bitShift: -2))).
+
+ srcIndex := srcIndex + 2.
+ dstIndex := dstIndex + 1]].
+
+ interpreterProxy pop: 12. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveHalfSizeDiagonal (in category 'scaling') -----
+ primitiveHalfSizeDiagonal
+
+ | in inW inH out outW outH srcX srcY dstX dstY dstW dstH srcIndex dstIndex p1 p2 r g b |
+ self export: true.
+ self var: 'in' declareC: 'int *in'.
+ self var: 'out' declareC: 'int *out'.
+
+ in := self checkedUnsignedIntPtrOf: (interpreterProxy stackValue: 11).
+ inW := interpreterProxy stackIntegerValue: 10.
+ inH := interpreterProxy stackIntegerValue: 9.
+ out := self checkedUnsignedIntPtrOf: (interpreterProxy stackValue: 8).
+ outW := interpreterProxy stackIntegerValue: 7.
+ outH := interpreterProxy stackIntegerValue: 6.
+ srcX := interpreterProxy stackIntegerValue: 5.
+ srcY := interpreterProxy stackIntegerValue: 4.
+ dstX := interpreterProxy stackIntegerValue: 3.
+ dstY := interpreterProxy stackIntegerValue: 2.
+ dstW := interpreterProxy stackIntegerValue: 1.
+ dstH := interpreterProxy stackIntegerValue: 0.
+
+ interpreterProxy success: (srcX >= 0) & (srcY >= 0).
+ interpreterProxy success: (srcX + (2 * dstW)) <= inW.
+ interpreterProxy success: (srcY + (2 * dstH)) <= inH.
+ interpreterProxy success: (dstX >= 0) & (dstY >= 0).
+ interpreterProxy success: (dstX + dstW) <= outW.
+ interpreterProxy success: (dstY + dstH) <= outH.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ 0 to: dstH - 1 do: [:y |
+ srcIndex := (inW * (srcY + (2 * y))) + srcX.
+ dstIndex := (outW * (dstY + y)) + dstX.
+ 0 to: dstW - 1 do: [:x |
+ p1 := in at: srcIndex.
+ p2 := in at: srcIndex + inW + 1.
+
+ r := (((p1 bitAnd: 16rFF0000) + (p2 bitAnd: 16rFF0000)) bitShift: -1) bitAnd: 16rFF0000.
+ g := (((p1 bitAnd: 16rFF00) + (p2 bitAnd: 16rFF00)) bitShift: -1) bitAnd: 16rFF00.
+ b := ((p1 bitAnd: 16rFF) + (p2 bitAnd: 16rFF)) bitShift: -1.
+
+ "store combined RGB into target bitmap"
+ out at: dstIndex put: (r bitOr: (g bitOr: b)).
+
+ srcIndex := srcIndex + 2.
+ dstIndex := dstIndex + 1]].
+
+ interpreterProxy pop: 12. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveHueShift (in category 'hsv filters') -----
+ primitiveHueShift
+
+ | inOop outOop shift in sz out pix r g b max min brightness saturation hue |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+ self var: 'out' declareC: 'unsigned int *out'.
+
+ inOop := interpreterProxy stackValue: 2.
+ outOop := interpreterProxy stackValue: 1.
+ shift := interpreterProxy stackIntegerValue: 0.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ sz := interpreterProxy stSizeOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: outOop) = sz).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ 0 to: sz - 1 do: [:i |
+ pix := (in at: i) bitAnd: 16rFFFFFF.
+ pix = 0 ifFalse: [ "skip pixel values of 0 (transparent)"
+ r := (pix bitShift: -16) bitAnd: 16rFF.
+ g := (pix bitShift: -8) bitAnd: 16rFF.
+ b := pix bitAnd: 16rFF.
+
+ "find min and max color components"
+ max := min := r.
+ g > max ifTrue: [max := g].
+ b > max ifTrue: [max := b].
+ g < min ifTrue: [min := g].
+ b < min ifTrue: [min := b].
+
+ "find current brightness (v) and saturation with range 0 to 1000"
+ brightness := (max * 1000) // 255.
+ max = 0 ifTrue: [saturation := 0] ifFalse: [saturation := ((max - min) * 1000) // max].
+
+ brightness < 110 ifTrue: [ "force black to a very dark, saturated gray"
+ brightness := 110. saturation := 1000].
+ saturation < 90 ifTrue: [saturation := 90]. "force a small color change on grays"
+ ((brightness = 110) | (saturation = 90)) "tint all blacks and grays the same"
+ ifTrue: [hue := 0]
+ ifFalse: [hue := self hueFromR: r G: g B: b min: min max: max].
+
+ hue := (hue + shift + 360000000) \\ 360. "compute new hue"
+ self bitmap: out at: i putH: hue s: saturation v: brightness]].
+
+ interpreterProxy pop: 3. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveInterpolate (in category 'bilinear interpolation') -----
+ primitiveInterpolate
+
+ | inOop xFixed yFixed width in sz result |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+
+ inOop := interpreterProxy stackValue: 3.
+ width := interpreterProxy stackIntegerValue: 2.
+ xFixed := interpreterProxy stackIntegerValue: 1.
+ yFixed := interpreterProxy stackIntegerValue: 0.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ sz := interpreterProxy stSizeOf: inOop.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ result := self interpolatedFrom: in x: xFixed y: yFixed width: width height: sz // width.
+
+ interpreterProxy pop: 5. "pop args and rcvr"
+ interpreterProxy pushInteger: result.
+ ^ 0
+ !
Item was added:
+ ----- 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 |
+ self export: true.
+ self var: 'fullPath' declareC: 'char fullPath[1000]'.
+ self var: 'src' declareC: 'char * src'.
+
+ pathOop := interpreterProxy stackValue: 0.
+
+ ((interpreterProxy isIntegerObject: pathOop) or:
+ [(interpreterProxy isBytes: pathOop) not]) ifTrue: [
+ interpreterProxy success: false].
+
+ interpreterProxy failed ifTrue: [^ 0].
+
+ 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 cCode: 'IsFileOrFolderHidden(fullPath)'.
+
+ interpreterProxy pop: 2. "pop arg and rcvr"
+ interpreterProxy pushBool: result ~= 0. "push result"
+ ^ 0
+
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveOpenURL (in category 'os functions') -----
+ primitiveOpenURL
+ "Open a web browser on the given URL."
+
+ | urlStr src urlOop count |
+ self export: true.
+ self var: 'urlStr' declareC: 'char urlStr[2000]'.
+ self var: 'src' declareC: 'char * src'.
+
+ urlOop := interpreterProxy stackValue: 0.
+
+ ((interpreterProxy isIntegerObject: urlOop) or:
+ [(interpreterProxy isBytes: urlOop) not]) ifTrue: [
+ interpreterProxy success: false].
+
+ interpreterProxy failed ifTrue: [^ 0].
+
+ 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 cCode: 'OpenURL(urlStr)'.
+
+ interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0
+
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveSaturationShift (in category 'hsv filters') -----
+ primitiveSaturationShift
+
+ | inOop outOop shift in sz out pix r g b max min brightness saturation hue |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+ self var: 'out' declareC: 'unsigned int *out'.
+
+ inOop := interpreterProxy stackValue: 2.
+ outOop := interpreterProxy stackValue: 1.
+ shift := interpreterProxy stackIntegerValue: 0.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ sz := interpreterProxy stSizeOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: outOop) = sz).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ 0 to: sz - 1 do: [:i |
+ pix := (in at: i) bitAnd: 16rFFFFFF.
+ pix < 2 ifFalse: [ "skip pixel values of 0 (transparent) and 1 (black)"
+ r := (pix bitShift: -16) bitAnd: 16rFF.
+ g := (pix bitShift: -8) bitAnd: 16rFF.
+ b := pix bitAnd: 16rFF.
+
+ "find min and max color components"
+ max := min := r.
+ g > max ifTrue: [max := g].
+ b > max ifTrue: [max := b].
+ g < min ifTrue: [min := g].
+ b < min ifTrue: [min := b].
+
+ "find current brightness (v) and saturation with range 0 to 1000"
+ brightness := (max * 1000) // 255.
+ max = 0 ifTrue: [saturation := 0] ifFalse: [saturation := ((max - min) * 1000) // max].
+
+ saturation > 0 ifTrue: [ "do nothing if pixel is unsaturated (gray)"
+ hue := self hueFromR: r G: g B: b min: min max: max.
+
+ "compute new saturation"
+ saturation := saturation + (shift * 10).
+ saturation > 1000 ifTrue: [saturation := 1000].
+ saturation < 0 ifTrue: [saturation := 0].
+ self bitmap: out at: i putH: hue s: saturation v: brightness]]].
+
+ interpreterProxy pop: 3. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveScale (in category 'scaling') -----
+ primitiveScale
+ "Scale using bilinear interpolation."
+
+ | inOop inW inH outOop outW outH in out inX inY xIncr yIncr outPix w1 w2 w3 w4 t p1 p2 p3 p4 tWeight |
+ self export: true.
+ self var: 'in' declareC: 'int *in'.
+ self var: 'out' declareC: 'int *out'.
+
+ inOop := interpreterProxy stackValue: 5.
+ inW := interpreterProxy stackIntegerValue: 4.
+ inH := interpreterProxy stackIntegerValue: 3.
+ outOop := interpreterProxy stackValue: 2.
+ outW := interpreterProxy stackIntegerValue: 1.
+ outH := interpreterProxy stackIntegerValue: 0.
+
+ interpreterProxy success: (interpreterProxy stSizeOf: inOop) = (inW * inH).
+ interpreterProxy success: (interpreterProxy stSizeOf: outOop) = (outW * outH).
+ in := self checkedUnsignedIntPtrOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ inX := inY := 0. "source x and y, scaled by 1024"
+ xIncr := (inW * 1024) // outW. "source x increment, scaled by 1024"
+ yIncr := (inH * 1024) // outH. "source y increment, scaled by 1024"
+
+ 0 to: (outH - 1) do: [:outY |
+ inX := 0.
+ 0 to: (outW - 1) do: [:outX |
+ "compute weights, scaled by 2^20"
+ w1 := (1024 - (inX bitAnd: 1023)) * (1024 - (inY bitAnd: 1023)).
+ w2 := (inX bitAnd: 1023) * (1024 - (inY bitAnd: 1023)).
+ w3 := (1024 - (inX bitAnd: 1023)) * (inY bitAnd: 1023).
+ w4 := (inX bitAnd: 1023) * (inY bitAnd: 1023).
+
+ "get source pixels"
+ t := ((inY >> 10) * inW) + (inX >> 10).
+ p1 := in at: t.
+ ((inX >> 10) < (inW - 1)) ifTrue: [p2 := in at: t + 1] ifFalse: [p2 := p1].
+ (inY >> 10) < (inH - 1) ifTrue: [t := t + inW]. "next row"
+ p3 := in at: t.
+ ((inX >> 10) < (inW - 1)) ifTrue: [p4 := in at: t + 1] ifFalse: [p4 := p3].
+
+ "deal with transparent pixels"
+ tWeight := 0.
+ p1 = 0 ifTrue: [p1 := p2. tWeight := tWeight + w1].
+ p2 = 0 ifTrue: [p2 := p1. tWeight := tWeight + w2].
+ p3 = 0 ifTrue: [p3 := p4. tWeight := tWeight + w3].
+ p4 = 0 ifTrue: [p4 := p3. tWeight := tWeight + w4].
+ p1 = 0 ifTrue: [p1 := p3. p2 := p4]. "both top pixels were transparent; use bottom row"
+ p3 = 0 ifTrue: [p3 := p1. p4 := p2]. "both bottom pixels were transparent; use top row"
+
+ outPix := 0.
+ tWeight < 500000 ifTrue: [ "compute an (opaque) output pixel if less than 50% transparent"
+ t := (w1 * ((p1 >> 16) bitAnd: 255)) + (w2 * ((p2 >> 16) bitAnd: 255)) + (w3 * ((p3 >> 16) bitAnd: 255)) + (w4 * ((p4 >> 16) bitAnd: 255)).
+ outPix := ((t >> 20) bitAnd: 255) << 16.
+ t := (w1 * ((p1 >> 8) bitAnd: 255)) + (w2 * ((p2 >> 8) bitAnd: 255)) + (w3 * ((p3 >> 8) bitAnd: 255)) + (w4 * ((p4 >> 8) bitAnd: 255)).
+ outPix := outPix bitOr: (((t >> 20) bitAnd: 255) << 8).
+ t := (w1 * (p1 bitAnd: 255)) + (w2 * (p2 bitAnd: 255)) + (w3 * (p3 bitAnd: 255)) + (w4 * (p4 bitAnd: 255)).
+ outPix := outPix bitOr: ((t >> 20) bitAnd: 255).
+ outPix = 0 ifTrue: [outPix := 1]].
+
+ out at: (outY * outW) + outX put: outPix.
+ inX := inX + xIncr].
+ inY := inY + yIncr].
+
+ interpreterProxy pop: 6. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveSetUnicodePasteBuffer (in category 'os functions') -----
+ primitiveSetUnicodePasteBuffer
+ "Set the Mac OS X Unicode paste buffer."
+
+ | utf16 strOop count |
+ self export: true.
+ self var: 'utf16' declareC: 'short int *utf16'.
+
+ strOop := interpreterProxy stackValue: 0.
+
+ ((interpreterProxy isIntegerObject: strOop) or:
+ [(interpreterProxy isBytes: strOop) not]) ifTrue: [
+ interpreterProxy success: false].
+
+ interpreterProxy failed ifTrue: [^ 0].
+
+ utf16 := self cCoerce: (interpreterProxy firstIndexableField: strOop) to: 'short int *'.
+ count := interpreterProxy stSizeOf: strOop.
+
+ self cCode: 'SetUnicodePasteBuffer(utf16, count)'.
+
+ interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0
+
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveSetWindowTitle (in category 'os functions') -----
+ primitiveSetWindowTitle
+ "Set the title of the Scratch window."
+
+ | titleStr src titleOop count |
+ self export: true.
+ self var: 'titleStr' declareC: 'char titleStr[1000]'.
+ self var: 'src' declareC: 'char * src'.
+
+ titleOop := interpreterProxy stackValue: 0.
+
+ ((interpreterProxy isIntegerObject: titleOop) or:
+ [(interpreterProxy isBytes: titleOop) not]) ifTrue: [
+ interpreterProxy success: false].
+
+ interpreterProxy failed ifTrue: [^ 0].
+
+ 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 cCode: 'SetScratchWindowTitle(titleStr)'.
+
+ interpreterProxy pop: 1. "pop arg, leave rcvr on stack"
+ ^ 0
+
+ !
Item was added:
+ ----- 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 |
+ self export: true.
+ self var: 'shortPath' declareC: 'char shortPath[1000]'.
+ self var: 'longPath' declareC: 'char longPath[1000]'.
+ self var: 'ptr' declareC: 'char * ptr'.
+
+ shortPathOop := interpreterProxy stackValue: 0.
+
+ ((interpreterProxy isIntegerObject: shortPathOop) or:
+ [(interpreterProxy isBytes: shortPathOop) not]) ifTrue: [
+ interpreterProxy success: false. ^ 0].
+
+ 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 cCode: 'strlen(longPath)'.
+ resultOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: count.
+ 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
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveWaterRipples1 (in category 'other filters') -----
+ primitiveWaterRipples1
+
+ | in out aArray bArray ripply temp pix dx dy dist inOop outOop width allPix aArOop bArOop height t1 blops x y power val val2 dx2 dy2 newLoc |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+ self var: 'out' declareC: 'unsigned int *out'.
+ self var: 'aArray' declareC: 'double *aArray'.
+ self var: 'bArray' declareC: 'double *bArray'.
+ self var: 'ripply' declareC: 'int ripply'.
+ self var: 'temp' declareC: 'double temp'.
+ self var: 'pix' declareC: 'unsigned int pix'.
+ self var: 'dist' declareC: 'double dist'.
+ self var: 'dx2' declareC: 'double dx2'.
+ self var: 'dy2' declareC: 'double dy2'.
+
+ inOop := interpreterProxy stackValue: 5.
+ outOop := interpreterProxy stackValue: 4.
+ width := interpreterProxy stackIntegerValue: 3.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ allPix := interpreterProxy stSizeOf: inOop.
+ ripply := interpreterProxy stackIntegerValue: 2.
+ aArOop := interpreterProxy stackValue: 1.
+ bArOop := interpreterProxy stackValue: 0.
+ aArray := self checkedFloatPtrOf: aArOop.
+ bArray := self checkedFloatPtrOf: bArOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: outOop) = allPix).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ height := allPix // width.
+
+ t1 := self cCode: 'rand()'.
+ blops := t1 \\ ripply -1.
+ 0 to: blops /2-1 do: [:t |
+ t1 := self cCode: 'rand()'.
+ x := t1 \\ width.
+ t1 := self cCode: 'rand()'.
+ y := t1 \\ height.
+ t1 := self cCode: 'rand()'.
+ power := t1 \\ 8.
+ -4 to: 4 do: [:g |
+ -4 to: 4 do: [:h |
+ dist := ((g*g) + (h*h)) asFloat.
+ ((dist < 25) and: [dist > 0]) ifTrue: [
+ dx := (x + g) asInteger.
+ dy := (y + h) asInteger.
+ ((dx >0) and: [(dy>0) and: [(dy < height) and: [dx < width]]]) ifTrue: [
+ aArray at: ((dy)*width + dx) put: (power *(1.0 asFloat -(dist/(25.0 asFloat))) asFloat).
+ ].
+ ].
+ ].
+ ].
+ ].
+
+ 1 to: width -2 do: [:f |
+ 1 to: height -2 do: [:d |
+ val := (d)*width + f.
+ aArray at: val put: (((
+ (bArray at: (val+1)) + (bArray at: (val-1)) + (bArray at: (val + width)) + (bArray at: (val - width)) +
+ ((bArray at: (val -1 -width))/2) + ((bArray at: (val-1+width))/2) + ((bArray at: (val+1-width))/2) + ((bArray at: (val+1+width))/2)) /4) - (aArray at: (val))).
+ aArray at: (val) put: ((aArray at: (val))*(0.9 asFloat)).
+ ].
+ ].
+
+ "temp := bArray.
+ bArray := aArray.
+ aArray := temp."
+ 0 to: width*height do: [:q |
+ temp := bArray at: q.
+ bArray at: q put: (aArray at: q).
+ aArray at: q put: temp.
+ ].
+
+ 0 to: height-1 do: [:j |
+ 0 to: width-1 do: [:i |
+ ((i > 1) and: [(i<(width-1)) and: [(j>1) and: [(j<(height-1))]]]) ifTrue: [
+ val2 := (j)*width + i.
+ dx2 := ((((aArray at: (val2)) - (aArray at: (val2-1))) + ((aArray at: (val2+1)) - (aArray at: (val2)))) *64) asFloat.
+ dy2 := ((((aArray at: (val2)) - (aArray at: (val2-width))) + ((aArray at: (val2+width)) - (aArray at: (val2)))) /64) asFloat.
+ (dx2<-2) ifTrue: [dx2 := -2].
+ (dx2>2) ifTrue: [dx2 := 2].
+ (dy2<-2) ifTrue: [dy2 := -2].
+ (dy2>2) ifTrue: [dy2 := 2].
+ newLoc := ((j+dy2)*width + (i+dx2)) asInteger.
+ ((newLoc < (width*height)) and: [newLoc >=0]) ifTrue: [
+ pix := in at: newLoc]
+ ifFalse: [
+ pix := in at: (i +(j*width)) ].
+ ]
+ ifFalse: [
+ pix := in at: (i +(j*width)) ].
+ out at: (i + (j*width)) put: pix.
+ ]].
+
+ interpreterProxy pop: 6. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: ScratchPlugin>>primitiveWhirl (in category 'other filters') -----
+ primitiveWhirl
+
+ | inOop outOop width degrees in out sz height centerX centerY radius scaleX scaleY whirlRadians radiusSquared dx dy d factor ang sina cosa pix |
+ self export: true.
+ self var: 'in' declareC: 'unsigned int *in'.
+ self var: 'out' declareC: 'unsigned int *out'.
+ self var: 'scaleX' declareC: 'double scaleX'.
+ self var: 'scaleY' declareC: 'double scaleY'.
+ self var: 'whirlRadians' declareC: 'double whirlRadians'.
+ self var: 'radiusSquared' declareC: 'double radiusSquared'.
+ self var: 'dx' declareC: 'double dx'.
+ self var: 'dy' declareC: 'double dy'.
+ self var: 'd' declareC: 'double d'.
+ self var: 'factor' declareC: 'double factor'.
+ self var: 'ang' declareC: 'double ang'.
+ self var: 'sina' declareC: 'double sina'.
+ self var: 'cosa' declareC: 'double cosa'.
+
+ inOop := interpreterProxy stackValue: 3.
+ outOop := interpreterProxy stackValue: 2.
+ width := interpreterProxy stackIntegerValue: 1.
+ degrees := interpreterProxy stackIntegerValue: 0.
+ in := self checkedUnsignedIntPtrOf: inOop.
+ out := self checkedUnsignedIntPtrOf: outOop.
+ sz := interpreterProxy stSizeOf: inOop.
+ interpreterProxy success: ((interpreterProxy stSizeOf: outOop) = sz).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ "calculate height, center, scales, radius, whirlRadians, and radiusSquared"
+ height := sz // width.
+ centerX := width // 2.
+ centerY := height // 2.
+ centerX < centerY
+ ifTrue: [
+ radius := centerX.
+ scaleX := centerY asFloat / centerX.
+ scaleY := 1.0]
+ ifFalse: [
+ radius := centerY.
+ scaleX := 1.0.
+ centerY < centerX
+ ifTrue: [scaleY := centerX asFloat / centerY]
+ ifFalse: [scaleY := 1.0]].
+ whirlRadians := (-3.141592653589793 * degrees) / 180.0.
+ radiusSquared := (radius * radius) asFloat.
+
+ 0 to: width - 1 do: [:x |
+ 0 to: height - 1 do: [:y |
+ dx := scaleX * (x - centerX) asFloat.
+ dy := scaleY * (y - centerY) asFloat.
+ d := (dx * dx) + (dy * dy).
+ d < radiusSquared ifTrue: [ "inside the whirl circle"
+ factor := 1.0 - (d sqrt / radius).
+ ang := whirlRadians * (factor * factor).
+ sina := ang sin.
+ cosa := ang cos.
+ pix := self interpolatedFrom: in
+ x: (1024.0 * ((((cosa * dx) - (sina * dy)) / scaleX) + centerX)) asInteger
+ y: (1024.0 * ((((sina * dx) + (cosa * dy)) / scaleY) + centerY)) asInteger
+ width: width
+ height: height.
+ out at: ((width * y) + x "for Squeak: + 1") put: pix]]].
+
+ interpreterProxy pop: 4. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: StackInterpreter class>>isObjectAccessor: (in category 'spur compilation support') -----
+ isObjectAccessor: selector
+ "Answer if selector is one of fetchPointer:ofObject: storePointer:ofObject:withValue:
+ et al."
+ ^(InterpreterProxy whichCategoryIncludesSelector: selector) = #'object access'
+ or: [(SpurMemoryManager whichCategoryIncludesSelector: selector) = #'object access']
+
+ "This for checking. The above two protocols are somewhat disjoint."
+ "(InterpreterProxy allMethodsInCategory: #'object access') copyWithoutAll: (SpurMemoryManager allMethodsInCategory: #'object access')"
+ "(SpurMemoryManager allMethodsInCategory: #'object access') copyWithoutAll: (InterpreterProxy allMethodsInCategory: #'object access')"!
Item was added:
+ ----- Method: StackInterpreter class>>isStackAccessor: (in category 'spur compilation support') -----
+ isStackAccessor: selector
+ ^#( stackTop stackValue: stackTopPut: stackValue:put:
+ stackFloatValue: stackIntegerValue: stackObjectValue:) includes: selector!
Item was changed:
----- Method: StackInterpreter>>dumpImage: (in category 'image save/restore') -----
dumpImage: fileName
"Dump the entire image out to the given file. Intended for debugging only."
| f dataSize result |
<export: true>
<var: #f type: 'sqImageFile'>
f := self cCode: 'sqImageFileOpen(pointerForOop(fileName), "wb")'.
f = nil ifTrue: [^-1].
dataSize := objectMemory endOfMemory - objectMemory startOfMemory.
+ result := self cCode: 'sqImageFileWrite(pointerForOop(memory()), sizeof(unsigned char), dataSize, f)'.
- result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
self cCode: 'sqImageFileClose(f)'.
^result
!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveExternalCall (in category 'plugin primitives') -----
primitiveExternalCall
"Call an external primitive. External primitive methods first literals are an array of
+ * The module name (String | Symbol)
+ * The function name (String | Symbol)
+ * The session ID (SmallInteger) [OBSOLETE] (or in Spur, the accessorDepth)
- * The module name (String | Symbol)
- * The function name (String | Symbol)
- * The session ID (SmallInteger) [OBSOLETE]
* The function index (Integer) in the externalPrimitiveTable
For fast interpreter dispatch in subsequent invocations the primitiveFunctionPointer
in the method cache is rewritten, either to the function itself, or to zero if the external
function is not found. This allows for fast responses as long as the method stays in
the cache. The cache rewrite relies on lastMethodCacheProbeWrite which is set in
+ addNewMethodToCache:.
- addNewMethodToCache:.
Now that the VM flushes function addresses from its tables, the session ID is obsolete,
but it is kept for backward compatibility. Also, a failed lookup is reported specially. If a
method has been looked up and not been found, the function address is stored as -1
(i.e., the SmallInteger -1 to distinguish from 16rFFFFFFFF which may be returned from
lookup), and the primitive fails with PrimErrNotFound."
+ | lit addr moduleName functionName moduleLength functionLength accessorDepth index |
- | lit addr moduleName functionName moduleLength functionLength index |
<var: #addr declareC: 'void (*addr)()'>
"Fetch the first literal of the method"
(self literalCountOf: newMethod) > 0 ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
lit := self literal: 0 ofMethod: newMethod.
"Check if it's an array of length 4"
((objectMemory isArray: lit) and: [(objectMemory lengthOf: lit) = 4]) ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
"Look at the function index in case it has been loaded before"
index := objectMemory fetchPointer: 3 ofObject: lit.
(objectMemory isIntegerObject: index) ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
index := objectMemory integerValueOf: index.
"Check if we have already looked up the function and failed."
index < 0 ifTrue:
["Function address was not found in this session,
Void the primitive function."
self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
^self primitiveFailFor: PrimErrNotFound].
"Try to call the function directly"
(index > 0 and: [index <= MaxExternalPrimitiveTableSize]) ifTrue:
[addr := externalPrimitiveTable at: index - 1.
addr ~= 0 ifTrue:
[self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: 'addr' inSmalltalk: [1000 + index]).
self callExternalPrimitive: addr.
^nil].
"if we get here, then an index to the external prim was
kept on the ST side although the underlying prim
table was already flushed"
^self primitiveFailFor: PrimErrNamedInternal].
"Clean up session id and external primitive index"
objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
"The function has not been loaded yet. Fetch module and function name."
moduleName := objectMemory fetchPointer: 0 ofObject: lit.
moduleName = objectMemory nilObject
ifTrue: [moduleLength := 0]
ifFalse: [(objectMemory isBytes: moduleName) ifFalse:
[self primitiveFailFor: PrimErrBadMethod].
moduleLength := objectMemory lengthOf: moduleName].
functionName := objectMemory fetchPointer: 1 ofObject: lit.
(objectMemory isBytes: functionName) ifFalse:
[self primitiveFailFor: PrimErrBadMethod].
functionLength := objectMemory lengthOf: functionName.
+ objectMemory hasSpurMemoryManagerAPI
+ ifTrue:
+ [addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
+ OfLength: functionLength
+ FromModule: moduleName + BaseHeaderSize
+ OfLength: moduleLength
+ AccessorDepthInto: (self addressOf: accessorDepth
+ put: [:val| accessorDepth := val]).
+ addr = 0
+ ifTrue: [index := -1]
+ ifFalse: "add the function to the external primitive table"
+ [index := self addToExternalPrimitiveTable: addr.
+ objectMemory
+ storePointerUnchecked: 2
+ ofObject: lit
+ withValue: (objectMemory integerObjectOf: accessorDepth)]]
+ ifFalse:
+ [addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
+ OfLength: functionLength
+ FromModule: moduleName + BaseHeaderSize
+ OfLength: moduleLength.
+ addr = 0
+ ifTrue: [index := -1]
+ ifFalse: "add the function to the external primitive table"
+ [index := self addToExternalPrimitiveTable: addr]].
- addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
- OfLength: functionLength
- FromModule: moduleName + BaseHeaderSize
- OfLength: moduleLength.
- addr = 0
- ifTrue: [index := -1]
- ifFalse: ["add the function to the external primitive table"
- index := self addToExternalPrimitiveTable: addr].
"Store the index (or -1 if failure) back in the literal"
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).
"If the function has been successfully loaded cache and call it"
index >= 0
ifTrue:
[self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: [addr] inSmalltalk: [1000 + index]).
+ self callExternalPrimitive: addr]
+ ifFalse: "Otherwise void the primitive function and fail"
+ [self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
+ self assert: (objectMemory fetchPointer: 2 ofObject: lit) = ConstZero.
+ self primitiveFailFor: PrimErrNotFound]!
- self callExternalPrimitive: addr]
- ifFalse: ["Otherwise void the primitive function and fail"
- self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
- ^self primitiveFailFor: PrimErrNotFound]!
Item was added:
+ ----- Method: TConstantNode>>isSameAs: (in category 'comparing') -----
+ isSameAs: aTParseNode
+ ^aTParseNode isConstant
+ and: [value class == aTParseNode value class
+ and: [value = aTParseNode value]]!
Item was added:
+ ----- Method: TDefineNode>>isSameAs: (in category 'comparing') -----
+ isSameAs: aTParseNode
+ ^self class == aTParseNode class
+ and: [value class == aTParseNode value class
+ and: [value = aTParseNode value
+ and: [name = aTParseNode nameOrValue]]]!
Item was added:
+ ----- Method: TParseNode>>isSameAs: (in category 'comparing') -----
+ isSameAs: aTParseNode
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: TSendNode>>isSameAs: (in category 'comparing') -----
+ isSameAs: aTParseNode
+ (aTParseNode isSend
+ and: [selector == aTParseNode selector]) ifFalse:
+ [^false].
+ arguments with: aTParseNode args do:
+ [:a :b|
+ (a isSameAs: b) ifFalse:
+ [^false]].
+ ^true!
Item was added:
+ ----- Method: TVariableNode>>isSameAs: (in category 'comparing') -----
+ isSameAs: aTParseNode
+ ^aTParseNode isVariable
+ and: [name = aTParseNode name]!
Item was added:
+ InterpreterPlugin subclass: #UnicodePlugin
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Plugins'!
+
+ !UnicodePlugin commentStamp: '<historical>' prior: 0!
+ This plugin measures and renders Unicode (UTF8) strings.
+ !
Item was added:
+ ----- Method: UnicodePlugin class>>hasHeaderFile (in category 'translation') -----
+ hasHeaderFile
+
+ ^true!
Item was added:
+ ----- 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."
+
+ self inline: false.
+ self returnTypeC: 'char *'.
+
+ ((interpreterProxy isIntegerObject: stringOop) or:
+ [(interpreterProxy isBytes: stringOop) not]) ifTrue: [
+ interpreterProxy success: false.
+ ^ 0].
+
+ ^ self cCoerce: (interpreterProxy firstIndexableField: stringOop) to: 'char *'
+ !
Item was added:
+ ----- 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."
+
+ self inline: false.
+ self returnTypeC: 'void *'.
+
+ interpreterProxy success:
+ ((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 added:
+ ----- 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 |
+ self inline: false.
+ self var: 'stringPtr' declareC: 'char *stringPtr'.
+ self var: 'srcPtr' declareC: 'char *srcPtr'.
+
+ ((interpreterProxy isIntegerObject: stringOop) or:
+ [(interpreterProxy isBytes: stringOop) not]) ifTrue: [
+ interpreterProxy success: false.
+ ^ 0].
+
+ 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
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveClipboardGet (in category 'primitives') -----
+ primitiveClipboardGet
+ "Read the clipboard into the given UTF16 string.."
+
+ | utf16Oop utf16 utf16Length count |
+ self export: true.
+ self var: 'utf16' declareC: 'unsigned short *utf16'.
+
+ utf16Oop := interpreterProxy stackValue: 0.
+
+ ((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 *'.
+ utf16Length := 2 * (interpreterProxy stSizeOf: utf16Oop).
+
+ count := self cCode: 'unicodeClipboardGet(utf16, utf16Length)'.
+
+ interpreterProxy pop: 2
+ thenPush: (interpreterProxy integerObjectOf: count).
+
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveClipboardPut (in category 'primitives') -----
+ primitiveClipboardPut
+ "Set the clipboard to a UTF16 string.."
+
+ | strOop count utf16 utf16Length |
+ self export: true.
+ self var: 'utf16' declareC: 'unsigned short *utf16'.
+
+ strOop := interpreterProxy stackValue: 1.
+ count := interpreterProxy stackIntegerValue: 0.
+
+ ((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 *'.
+ utf16Length := 2 * (interpreterProxy stSizeOf: strOop).
+ ((count >= 0) & (count < utf16Length)) ifTrue: [utf16Length := count].
+
+ self cCode: 'unicodeClipboardPut(utf16, utf16Length)'.
+
+ interpreterProxy pop: 2. "pop args, leave rcvr on stack"
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveClipboardSize (in category 'primitives') -----
+ primitiveClipboardSize
+
+ | count |
+ self export: true.
+
+ count := self cCode: 'unicodeClipboardSize()'.
+
+ interpreterProxy pop: 1
+ thenPush: (interpreterProxy integerObjectOf: count).
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveDrawString (in category 'primitives') -----
+ primitiveDrawString
+
+ | utf8Oop utf8 w h bitmapOop bitmapPtr utf8Length result |
+ self export: true.
+ self var: 'utf8' declareC: 'char *utf8'.
+ self var: 'bitmapPtr' declareC: 'void *bitmapPtr'.
+
+ utf8Oop := interpreterProxy stackValue: 3.
+ utf8 := self asCString: utf8Oop.
+ w := interpreterProxy stackIntegerValue: 2.
+ h := interpreterProxy stackIntegerValue: 1.
+ bitmapOop := interpreterProxy stackValue: 0.
+ bitmapPtr := self cWordsPtr: bitmapOop minSize: w * h.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ utf8Length := interpreterProxy stSizeOf: utf8Oop.
+ self cCode: 'unicodeDrawString(utf8, utf8Length, &w, &h, bitmapPtr)'.
+
+ result := interpreterProxy makePointwithxValue: w yValue: h.
+ interpreterProxy pop: 5 thenPush: result.
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveGetFontList (in category 'primitives') -----
+ primitiveGetFontList
+
+
+ | strOop str strLength count |
+ self export: true.
+ self var: 'str' declareC: 'char *str'.
+
+ strOop := interpreterProxy stackValue: 0.
+ str := self asCString: strOop.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ strLength := interpreterProxy stSizeOf: strOop.
+ count := self cCode: 'unicodeGetFontList(str, strLength)'.
+
+ interpreterProxy pop: 2
+ thenPush: (interpreterProxy integerObjectOf: count).
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveGetXRanges (in category 'primitives') -----
+ primitiveGetXRanges
+
+ | utf8Oop utf8 resultOop resultPtr utf8Length count resultLength |
+ self export: true.
+ self var: 'utf8' declareC: 'char *utf8'.
+ self var: 'resultPtr' declareC: 'int *resultPtr'.
+
+ utf8Oop := interpreterProxy stackValue: 1.
+ utf8 := self asCString: utf8Oop.
+
+ resultOop := interpreterProxy stackValue: 0.
+ resultPtr := self cWordsPtr: resultOop minSize: 0.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ utf8Length := interpreterProxy stSizeOf: utf8Oop.
+ resultLength := interpreterProxy stSizeOf: resultOop.
+ count := self cCode: 'unicodeGetXRanges(utf8, utf8Length, resultPtr, resultLength)'.
+
+ interpreterProxy pop: 3 thenPush: (interpreterProxy integerObjectOf: count).
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveMeasureString (in category 'primitives') -----
+ primitiveMeasureString
+
+ | utf8Oop utf8 utf8Length w h result |
+ self export: true.
+ self var: 'utf8' declareC: 'char *utf8'.
+
+ utf8Oop := interpreterProxy stackValue: 0.
+ utf8 := self asCString: utf8Oop.
+ interpreterProxy failed ifTrue: [^ nil].
+
+ w := h := 0.
+ utf8Length := interpreterProxy stSizeOf: utf8Oop.
+ self cCode: 'unicodeMeasureString(utf8, utf8Length, &w, &h)'.
+
+ result := interpreterProxy makePointwithxValue: w yValue: h.
+ interpreterProxy pop: 2 thenPush: result.
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveSetColors (in category 'primitives') -----
+ primitiveSetColors
+
+ | fgRed fgGreen fgBlue bgRed bgGreen bgBlue mapBGToTransparent |
+ self export: true.
+
+ fgRed := interpreterProxy stackIntegerValue: 6.
+ fgGreen := interpreterProxy stackIntegerValue: 5.
+ fgBlue := interpreterProxy stackIntegerValue: 4.
+ bgRed := interpreterProxy stackIntegerValue: 3.
+ bgGreen := interpreterProxy stackIntegerValue: 2.
+ bgBlue := interpreterProxy stackIntegerValue: 1.
+ mapBGToTransparent := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ self cCode: 'unicodeSetColors(fgRed, fgGreen, fgBlue, bgRed, bgGreen, bgBlue, mapBGToTransparent)'.
+
+ interpreterProxy pop: 7.
+ ^ 0
+ !
Item was added:
+ ----- Method: UnicodePlugin>>primitiveSetFont (in category 'primitives') -----
+ primitiveSetFont
+
+ | fontName fontSize boldFlag italicFlag antiAliasFlag |
+ self export: true.
+ self var: 'fontName' declareC: 'char fontName[200]'.
+
+ self copyString: (interpreterProxy stackValue: 4) into: fontName max: 200.
+ fontSize := interpreterProxy stackIntegerValue: 3.
+ boldFlag := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 2).
+ italicFlag := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 1).
+ antiAliasFlag := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
+ interpreterProxy failed ifTrue: [^ nil].
+
+ self cCode: 'unicodeSetFont(fontName, fontSize, boldFlag, italicFlag, antiAliasFlag)'.
+
+ interpreterProxy pop: 5.
+ ^ 0
+ !
Item was changed:
CCodeGenerator subclass: #VMPluginCodeGenerator
+ instanceVariableNames: 'pluginClass pluginName pluginFunctionsUsed inProgressSelectors'
- instanceVariableNames: 'pluginClass pluginName pluginFunctionsUsed'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
!VMPluginCodeGenerator commentStamp: '<historical>' prior: 0!
I generate code that can be loaded dynamically from external libraries (e.g., DSOs on Unix or DLLs on Windows)!
Item was added:
+ ----- Method: VMPluginCodeGenerator>>accessorChainsForMethod:interpreterClass: (in category 'spur primitive compilation') -----
+ accessorChainsForMethod: method interpreterClass: interpreterClass
+ inProgressSelectors := Set new.
+ ^[super accessorChainsForMethod: method interpreterClass: interpreterClass] ensure:
+ [inProgressSelectors := nil]!
Item was added:
+ ----- Method: VMPluginCodeGenerator>>accessorDepthDeterminationFollowsSelfSends (in category 'spur primitive compilation') -----
+ accessorDepthDeterminationFollowsSelfSends
+ ^true!
Item was added:
+ ----- Method: VMPluginCodeGenerator>>accessorsAndAssignmentsForSubMethodNamed:actuals:depth:interpreterClass:into: (in category 'spur primitive compilation') -----
+ accessorsAndAssignmentsForSubMethodNamed: selector actuals: actualParameters depth: depth interpreterClass: interpreterClass into: aTrinaryBlock
+ "Evaluate aTrinaryBlock with the root accessor sends, accessor sends and assignments in the sub-method named selector."
+
+ | method map |
+ (inProgressSelectors includes: selector) ifTrue:
+ [^nil].
+ inProgressSelectors add: selector.
+ method := self methodNamed: selector.
+ "this is unsatisfactory. a pluggable scheme that asks the relevant plugin the right question would
+ be better but for now the only cross-plugin load is for loadBitBltFrom:warping: and variants."
+ (#(loadBitBltFrom: loadWarpBltFrom: loadBitBltFrom:warping:) includes: selector) ifTrue:
+ [(method isNil
+ or: [method definingClass ~~ BitBltSimulation]) ifTrue:
+ [method := (BitBltSimulation >> selector) methodNode asTranslationMethodOfClass: TMethod]].
+ method ifNil:
+ [^nil].
+ map := Dictionary new.
+ method args do: [:var| map at: var put: depth asString, var].
+ method locals do: [:var| map at: var put: depth asString, var].
+ ^self accessorsAndAssignmentsForMethod: (method copy renameVariablesUsing: map)
+ actuals: actualParameters
+ depth: depth + 1
+ interpreterClass: interpreterClass
+ into: aTrinaryBlock!
Item was changed:
----- Method: VMPluginCodeGenerator>>emitExportsOn: (in category 'C code generator') -----
emitExportsOn: aStream
+ "Store all the exported primitives in the form used by the internal named prim system."
+ aStream cr; cr; nextPutAll:'#ifdef SQUEAK_BUILTIN_PLUGIN'.
+ self emitExportsNamed: pluginName pluginName: pluginName on: aStream.
+ aStream cr; nextPutAll: '#endif /* ifdef SQ_BUILTIN_PLUGIN */'; cr!
- "Store all the exported primitives in a form to be used by internal plugins"
- | prefix |
- aStream nextPutAll:'
-
- #ifdef SQUEAK_BUILTIN_PLUGIN
-
- void* ', pluginName,'_exports[][3] = {'.
- prefix := '"', pluginName,'"'.
- (self sortStrings: self exportedPrimitiveNames) do:[:primName|
- aStream cr;
- nextPutAll:' {';
- nextPutAll: prefix;
- nextPutAll:', "';
- nextPutAll: primName;
- nextPutAll:'", (void*)';
- nextPutAll: primName;
- nextPutAll:'},'.
- ].
- aStream nextPutAll:'
- {NULL, NULL, NULL}
- };
-
- #endif /* ifdef SQ_BUILTIN_PLUGIN */
- '!
Item was added:
+ InterpreterPlugin subclass: #WeDoPlugin
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Plugins'!
+
+ !WeDoPlugin commentStamp: 'jm 12/2/2008 14:22' prior: 0!
+ Low level interface to the Lego WeDo.
+ !
Item was added:
+ ----- Method: WeDoPlugin class>>hasHeaderFile (in category 'translation') -----
+ hasHeaderFile
+
+ ^true!
Item was added:
+ ----- Method: WeDoPlugin>>primClosePort (in category 'translated prims') -----
+ primClosePort
+ "Close the WeDo port."
+
+ self export: true.
+ interpreterProxy success: (self cCode: 'WeDoClosePort()').
+ ^ 0
+ !
Item was added:
+ ----- Method: WeDoPlugin>>primOpenPort (in category 'translated prims') -----
+ primOpenPort
+ "Open the WeDo port."
+
+ self export: true.
+ interpreterProxy success: (self cCode: 'WeDoOpenPort()').
+ ^ 0
+ !
Item was added:
+ ----- 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 |
+ self export: true.
+ self var: 'bufPtr' declareC: 'char *bufPtr'.
+
+ bufOop := interpreterProxy stackValue: 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: [^ 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 added:
+ ----- 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 |
+ self export: true.
+ self var: 'bufPtr' declareC: 'char *bufPtr'.
+
+ bufOop := interpreterProxy stackValue: 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: [^ 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