Vm-dev January 2014

vm-dev@lists.squeakfoundation.org

28 participants
97 discussions

VM Maker: VMMaker.oscog-dtl.574.mcz
by commits＠source.squeak.org 04 Jan '14

04 Jan '14

David T. Lewis uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-dtl.574.mcz ==================== Summary ==================== Name: VMMaker.oscog-dtl.574 Author: dtl Time: 4 January 2014, 2:16:30.525 pm UUID: a3e2af5e-2cc7-4c7f-9b72-8c6b2cd28a0f Ancestors: VMMaker.oscog-eem.573 VMMaker 4.12.12 (VMMaker-dtl.334) Add Pragmatizer. Convert Scratch plugins to pragmas. Changes to generated code are cosmetic, e.g. variable names and ordering. Conversion script: converter := Pragmatizer on: 'VMMaker' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: ). converter classes: { CameraPlugin . ScratchPlugin . WeDoPlugin . UnicodePlugin }. converter pragmatize. =============== Diff against VMMaker.oscog-eem.573 =============== Item was changed: ----- 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 | + <export: true> + <var: 'nameStr' declareC: 'char* nameStr'> + <var: 'dst' declareC: 'char* 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 changed: ----- Method: CameraPlugin>>primCloseCamera (in category 'primitives') ----- primCloseCamera "Close the camera. Do nothing if it was not open." | cameraNum | + <export: true> - 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 changed: ----- 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 | + <export: true> - 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 changed: ----- Method: CameraPlugin>>primGetFrame (in category 'primitives') ----- primGetFrame "Copy a camera frame into the given Bitmap. The Bitmap should be for a Form of depth 32 that is the same width and height as the current camera frame. Fail if the camera is not open or if the bitmap is not the right size. If successful, answer the number of frames received from the camera since the last call. If this is zero, then there has been no change." | cameraNum bitmapOop bitmap pixCount result | + <export: true> + <var: 'bitmap' declareC: 'unsigned char *bitmap'> - 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 changed: ----- Method: CameraPlugin>>primGetParam (in category 'primitives') ----- primGetParam "Answer the given integer parameter of the given camera." | cameraNum paramNum result | + <export: true> - 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 changed: ----- Method: CameraPlugin>>primOpenCamera (in category 'primitives') ----- primOpenCamera "Open a camera. Takes one argument, the index of the device to open." | cameraNum desiredFrameWidth desiredFrameHeight ok | + <export: true> - 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 added: + Object subclass: #Pragmatizer + instanceVariableNames: 'package selectors classes stampCutString stampInsertString' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-Translation to C'! + + !Pragmatizer commentStamp: 'dtl 9/25/2010 18:26' prior: 0! + Pragmatizer is a utility for converting message send directives (such as 'self inline: true') to their corresponding pragma implementations (<inline: true>) in method source. + + The #depragmatize method provides a means for reverting to message send directives. This may be useful in the event of needing to load VMMaker into an image that does not support pragmas. + + This is based on an original script provided by Eliot Miranda.! Item was added: + ----- Method: Pragmatizer class>>convertVMMakerAndPluginsToPragmas (in category 'examples') ----- + convertVMMakerAndPluginsToPragmas + "Create (unused) packages named 'VMMaker-Interpreter', 'VMMaker-Plugins', + and 'VMMaker-SmartSyntaxPlugins'. Open a transcript, then evaluate this method. + Some errors will be found during the conversion. Fix the problem methods + manually in the notifier dialog, and proceed. The issues are related to declarations + that are not the first lines of source in the method, so just move the declarations + to the top of the method to resolve." + + "Pragmatizer convertVMMakerAndPluginsToPragmas" + + | selectorsToConvert packages converter | + selectorsToConvert := #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: ). + packages := { 'VMMaker-Interpreter' . 'VMMaker-Plugins' . 'VMMaker-SmartSyntaxPlugins' }. + packages do: [:package | + converter := Pragmatizer on: package selectors: selectorsToConvert. + converter pragmatize]! Item was added: + ----- Method: Pragmatizer class>>on:selectors: (in category 'instance creation') ----- + on: packageName selectors: selectorList + "Pragmatizer on: 'VMMaker-Interpreter' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: )" + "Pragmatizer on: 'VMMaker-Plugins' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: )" + "Pragmatizer on: 'VMMaker-SmartSyntaxPlugins' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: )" + + ^ self new package: packageName selectors: selectorList! Item was added: + ----- Method: Pragmatizer class>>revertVMMakerAndPluginsToMessageSendDeclarations (in category 'examples') ----- + revertVMMakerAndPluginsToMessageSendDeclarations + "To revert back to the message send declarations. " + + "Pragmatizer revertVMMakerAndPluginsToMessageSendDeclarations" + + | selectorsToConvert packages converter substringToRemoveFromMethodStamp | + + "Optional - Edit the following to match substring to be removed from the method + stamps to return them to their original form prior to conversion to pragmas: + Note leading space in the string." + substringToRemoveFromMethodStamp := ' (auto pragmas dtl 2010-09-26)'. + + selectorsToConvert := #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: ). + packages := { 'VMMaker-Interpreter' . 'VMMaker-Plugins' . 'VMMaker-SmartSyntaxPlugins' }. + packages do: [:package | + converter := Pragmatizer on: package selectors: selectorsToConvert. + converter stampCutString: substringToRemoveFromMethodStamp. + converter stampInsertString: ''. + converter depragmatize]! Item was added: + ----- Method: Pragmatizer>>classes: (in category 'accessing') ----- + classes: listOfClasses + "If set, only the classes in this list will be modified. The classes are assumed to be + classes in the package. This is intended to allow specifying one or more plugins + in VMMaker-Plugins to be converted individually." + + classes := listOfClasses! Item was added: + ----- Method: Pragmatizer>>depragmatize (in category 'convert pragmas to sends') ----- + depragmatize + "Convert methods from pragmas to old style message send directives, retaining + original author initials and time stamps. Answer the methods that were modified." + + | instanceMethods | + "Only instance side methods are translated, so ignore class side methods in the package" + instanceMethods := package methods + reject: [:e | e classIsMeta + or: [self isExcludedClass: e]]. + ^ instanceMethods + reject: [:mr | self depragmatize: mr]! Item was added: + ----- Method: Pragmatizer>>depragmatize: (in category 'convert pragmas to sends') ----- + depragmatize: methodReference + "Depragmatize the method. Answer true if the method was not modified, and false + if conversion was performed." + + | method newSource newStamp pragmas stamp | + pragmas := OrderedCollection new. + method := methodReference compiledMethod. + method properties keysAndValuesDo: [:sel :p | + (selectors includes: sel) + ifTrue: [pragmas add: p]]. + pragmas isEmpty ifTrue: [^ true]. + newSource := pragmas + inject: method getSourceFromFile asString + into: [:src : pragma | + src copyReplaceAll: pragma asString + with: 'self ', pragma asString allButFirst allButLast, '.']. + stamp := method timeStamp. + newStamp := self newConvertToMessageSendStamp: stamp. + Transcript + print: method methodClass; + nextPutAll: '>>'; + print: method selector; + nextPut: Character space; + nextPutAll: newStamp; + cr; flush. + method methodClass + compile: newSource + classified: methodReference category + withStamp: newStamp + notifying: nil. + ^false + ! Item was added: + ----- Method: Pragmatizer>>isExcludedClass: (in category 'testing') ----- + isExcludedClass: aMethodReference + + classes notNil + and: [classes + detect: [:cls | cls name = aMethodReference classSymbol] + ifNone: [^ true]]. + ^ false! Item was added: + ----- Method: Pragmatizer>>newConvertToMessageSendStamp: (in category 'method stamp') ----- + newConvertToMessageSendStamp: oldStamp + "Insert a comment in a method stamp to indicate that conversion from pragmas to old + style message sends was done. If stampCutString has been set, remove this substring + from the oldStamp prior to adding a new substring. If stampInsertString was set, use + this as the substring to insert. Otherwise add a substring with current date and author + initials." + + | newStamp | + stampCutString + ifNil: [newStamp := oldStamp] + ifNotNil: [newStamp := oldStamp copyReplaceAll: stampCutString with: '']. + stampInsertString + ifNil: [newStamp := newStamp + copyReplaceFrom: (oldStamp indexOf: Character space) + 1 + to: (oldStamp indexOf: Character space) + with: '(remove pragmas ', Utilities authorInitials, ' ', Date today yyyymmdd, ') '] + ifNotNil: [newStamp := newStamp + copyReplaceFrom: (oldStamp indexOf: Character space) + 1 + to: (oldStamp indexOf: Character space) + with: stampInsertString]. + ^ newStamp + ! Item was added: + ----- Method: Pragmatizer>>newConvertToPragmaStamp: (in category 'method stamp') ----- + newConvertToPragmaStamp: oldStamp + "Insert a comment in a method stamp to indicate that conversion to pragmas was done. + If stampCutString has been set, remove this substring from the oldStamp prior to adding + a new substring. If stampInsertString was set, use this as the substring to insert. Otherwise + add a substring with current date and author initials." + + | newStamp | + stampCutString + ifNil: [newStamp := oldStamp] + ifNotNil: [newStamp := oldStamp copyReplaceAll: stampCutString with: '']. + stampInsertString + ifNil: [newStamp := newStamp + copyReplaceFrom: (oldStamp indexOf: Character space) + 1 + to: (oldStamp indexOf: Character space) + with: '(auto pragmas ', Utilities authorInitials, ' ', Date today yyyymmdd, ') '] + ifNotNil: [newStamp := newStamp + copyReplaceFrom: (oldStamp indexOf: Character space) + 1 + to: (oldStamp indexOf: Character space) + with: stampInsertString]. + ^ newStamp + ! Item was added: + ----- Method: Pragmatizer>>newPragmatizedSourceFrom:nodes:nodeRanges: (in category 'convert sends to pragmas') ----- + newPragmatizedSourceFrom: source nodes: pragmaNodes nodeRanges: ranges + + ^ String streamContents: [:str| + str nextPutAll: (source copyFrom: 1 to: ranges first - 6). + pragmaNodes + do: [:node| | pragma args | + str nextPut: $<. + str nextPutAll: (node asString allButFirst: 6) allButLast. + str nextPut: $>] + separatedBy: [str crtab: 1]. + str nextPutAll: (source copyFrom: ((ranges last + 1 <= source size + and: [(source at: ranges last + 1) = $.]) + ifTrue: [ranges last + 2] + ifFalse: [ranges last + 1]) + to: source size)] + ! Item was added: + ----- Method: Pragmatizer>>package:selectors: (in category 'initialize-release') ----- + package: packageName selectors: selectorList + + package := PackageOrganizer default + packageNamed: packageName + ifAbsent: [self error: 'package ', packageName, ' not found']. + selectors := selectorList! Item was added: + ----- Method: Pragmatizer>>pragmatize (in category 'convert sends to pragmas') ----- + pragmatize + "Convert methods to use pragmas, retaining original author initials and time stamps. + Answer the methods that were modified." + + | instanceMethods | + "Only instance side methods are translated, so ignore class side methods in the package" + instanceMethods := package methods + reject: [:e | e classIsMeta + or: [self isExcludedClass: e]]. + ^ instanceMethods + reject: [:mr | self pragmatize: mr]! Item was added: + ----- Method: Pragmatizer>>pragmatize: (in category 'convert sends to pragmas') ----- + pragmatize: methodReference + "Pragmatize the method. Answer true if the method was not modified, and false + if conversion was performed." + + | method methodNode pragmaNodes sourceRanges ranges source newSource stamp newStamp | + method := methodReference compiledMethod. + methodNode := method methodNode. + pragmaNodes := SortedCollection + sortBlock: [:a :b | (sourceRanges at: a) first <= (sourceRanges at: b) first]. + (sourceRanges := methodNode rawSourceRanges) + keysAndValuesDo: [:node :range | (node isMessageNode + and: [selectors includes: node selector key]) + ifTrue: [pragmaNodes add: node]]. + ^ pragmaNodes isEmpty + ifFalse: [ranges := (sourceRanges at: pragmaNodes first) first + to: (sourceRanges at: pragmaNodes last) last. + + source := method getSourceFromFile asString. + "methodBodyStart := method methodClass parserClass new + parseMethodComment: source setPattern: [:ignored|]; + startOfNextToken. + tempsStart := source indexOf: $| startingAt: methodBodyStart. + hasTemps := tempsStart > 0 and: [tempsStart < ranges first]." + (source copyFrom: ranges first - 5 to: ranges first - 1) ~= 'self ' ifTrue: [self halt]. + (ranges last < source size + and: [(source indexOf: $. startingAt: ranges last) > (ranges last + 1)]) ifTrue: [self halt]. + newSource := self newPragmatizedSourceFrom: source + nodes: pragmaNodes + nodeRanges: ranges. + stamp := method timeStamp. + newStamp := self newConvertToPragmaStamp: stamp. + Transcript + print: method methodClass; + nextPutAll: '>>'; + print: method selector; + nextPut: Character space; + nextPutAll: newStamp; + cr; flush. + method methodClass + compile: newSource + classified: methodReference category + withStamp: newStamp + notifying: nil. + false] + ! Item was added: + ----- Method: Pragmatizer>>stampCutString: (in category 'accessing') ----- + stampCutString: stringToRemoveFromMethodStamp + "If set, this substring will be removed from method stamps during conversion. This is + intended to enable conversion to and from pragmas without repeated extension of the + method stamp." + + stampCutString := stringToRemoveFromMethodStamp! Item was added: + ----- Method: Pragmatizer>>stampInsertString: (in category 'accessing') ----- + stampInsertString: commentToInsert + "If set, the commentToInsert will be used for method stamp modification + rather than the default conversion value. This is intended to permit a + Pragmatizer to reproduce a previous conversion, e.g. the previously converted + methods in the Cog VM." + + stampInsertString := commentToInsert + ! Item was changed: ----- 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 | + <inline: true> + <var: 'bitmap' declareC: 'unsigned int *bitmap'> - 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 changed: ----- 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." + <inline: true> + <returnTypeC: 'double *'> - self inline: true. - self returnTypeC: 'double *'. interpreterProxy success: (interpreterProxy isWordsOrBytes: oop). interpreterProxy failed ifTrue: [^ 0]. ^ self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'double *' ! Item was changed: ----- 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." + <inline: true> + <returnTypeC: 'unsigned int *'> - 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 changed: ----- 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 | + <inline: true> - 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 changed: ----- 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 | + <inline: true> - 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 changed: ----- 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 | + <inline: true> + <var: 'bitmap' declareC: 'unsigned int *bitmap'> - 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 changed: ----- Method: ScratchPlugin>>primClose (in category 'serial port') ----- primClose "Close the given serial port." | portNum | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primGetOption (in category 'serial port') ----- primGetOption "Return the given option value for the given serial port." | portNum attrNum result | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primIsPortOpen (in category 'serial port') ----- primIsPortOpen "Answer the true if the given port is open." | portNum result | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primOpenPortNamed (in category 'serial port') ----- primOpenPortNamed "Open the port with the given name and baud rate." | nameStr src nameOop baudRate count portNum | + <export: true> + <var: 'nameStr' declareC: 'char nameStr[1000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primPortCount (in category 'serial port') ----- primPortCount "Answer the number of serial ports." | result | + <export: true> - 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 changed: ----- 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 | + <export: true> + <var: 'nameStr' declareC: 'char nameStr[1000]'> + <var: 'dst' declareC: 'char* 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 changed: ----- Method: ScratchPlugin>>primRead (in category 'serial port') ----- primRead "Read data from the given serial port into the given buffer (a ByteArray or String). Answer the number of bytes read." | portNum bufOop bufPtr bufSize bytesRead | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 changed: ----- Method: ScratchPlugin>>primSetOption (in category 'serial port') ----- primSetOption "Return the given option value for the given serial port." | portNum attrNum attrValue result | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primWrite (in category 'serial port') ----- primWrite "Write data to the given serial port from the given buffer (a ByteArray or String). Answer the number of bytes written." | portNum bufOop bufPtr bufSize bytesWritten | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 changed: ----- Method: ScratchPlugin>>primitiveBlur (in category 'other filters') ----- primitiveBlur | inOop outOop width in out sz height n rTotal gTotal bTotal pix outPix | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveBrightnessShift (in category 'hsv filters') ----- primitiveBrightnessShift | inOop outOop shift in sz out pix r g b max min hue saturation brightness | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveCondenseSound (in category 'sound') ----- primitiveCondenseSound | srcOop dstOop factor sz src dst count max v | + <export: true> + <var: 'src' declareC: 'short *src'> + <var: 'dst' declareC: 'short *dst'> - 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 changed: ----- Method: ScratchPlugin>>primitiveDoubleSize (in category 'scaling') ----- primitiveDoubleSize | in out inOop outOop inW inH outW outH dstX dstY baseIndex pix i | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveExtractChannel (in category 'sound') ----- primitiveExtractChannel | srcOop dstOop rightFlag sz src dst | + <export: true> + <var: 'src' declareC: 'short *src'> + <var: 'dst' declareC: 'short *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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> + <var: 'scaleX' declareC: 'double scaleX'> + <var: 'scaleY' declareC: 'double scaleY'> + <var: 'whirlRadians' declareC: 'double whirlRadians'> + <var: 'radiusSquared' declareC: 'double radiusSquared'> + <var: 'dx' declareC: 'double dx'> + <var: 'dy' declareC: 'double dy'> + <var: 'd' declareC: 'double d'> + <var: 'factor' declareC: 'double factor'> + <var: 'ang' declareC: 'double ang'> + <var: 'sina' declareC: 'double sina'> + <var: 'cosa' declareC: 'double cosa'> + <var: 'r' declareC: 'double r'> + <var: 'scaledPower' declareC: 'double 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 changed: ----- 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 | + <export: true> + <var: 'nameStr' declareC: 'char nameStr[2000]'> + <var: 'dst' declareC: 'char* dst'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveHueShift (in category 'hsv filters') ----- primitiveHueShift | inOop outOop shift in sz out pix r g b max min brightness saturation hue | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveInterpolate (in category 'bilinear interpolation') ----- primitiveInterpolate | inOop xFixed yFixed width in sz result | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> - 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 changed: ----- Method: ScratchPlugin>>primitiveIsHidden (in category 'os functions') ----- primitiveIsHidden "Answer true if the file or folder with the given path should be hidden from the user. On Windows, this is the value of the 'hidden' file property." | pathOop src count fullPath result | + <export: true> + <var: 'fullPath' declareC: 'char fullPath[1000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primitiveOpenURL (in category 'os functions') ----- primitiveOpenURL "Open a web browser on the given URL." | urlStr src urlOop count | + <export: true> + <var: 'urlStr' declareC: 'char urlStr[2000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primitiveSaturationShift (in category 'hsv filters') ----- primitiveSaturationShift | inOop outOop shift in sz out pix r g b max min brightness saturation hue | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveSetUnicodePasteBuffer (in category 'os functions') ----- primitiveSetUnicodePasteBuffer "Set the Mac OS X Unicode paste buffer." | utf16 strOop count | + <export: true> + <var: 'utf16' declareC: 'short int *utf16'> - 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 changed: ----- Method: ScratchPlugin>>primitiveSetWindowTitle (in category 'os functions') ----- primitiveSetWindowTitle "Set the title of the Scratch window." | titleStr src titleOop count | + <export: true> + <var: 'titleStr' declareC: 'char titleStr[1000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primitiveShortToLongPath (in category 'os functions') ----- primitiveShortToLongPath "On Windows, convert a short file/path name into a long one. Fail on other platforms." | shortPath longPath ptr shortPathOop result count resultOop | + <export: true> + <var: 'shortPath' declareC: 'char shortPath[1000]'> + <var: 'longPath' declareC: 'char longPath[1000]'> + <var: 'ptr' declareC: 'char * ptr'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> + <var: 'aArray' declareC: 'double *aArray'> + <var: 'bArray' declareC: 'double *bArray'> + <var: 'ripply' declareC: 'int ripply'> + <var: 'temp' declareC: 'double temp'> + <var: 'pix' declareC: 'unsigned int pix'> + <var: 'dist' declareC: 'double dist'> + <var: 'dx2' declareC: 'double dx2'> + <var: 'dy2' declareC: 'double dy2'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> + <var: 'scaleX' declareC: 'double scaleX'> + <var: 'scaleY' declareC: 'double scaleY'> + <var: 'whirlRadians' declareC: 'double whirlRadians'> + <var: 'radiusSquared' declareC: 'double radiusSquared'> + <var: 'dx' declareC: 'double dx'> + <var: 'dy' declareC: 'double dy'> + <var: 'd' declareC: 'double d'> + <var: 'factor' declareC: 'double factor'> + <var: 'ang' declareC: 'double ang'> + <var: 'sina' declareC: 'double sina'> + <var: 'cosa' declareC: 'double cosa'> - 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 changed: ----- Method: UnicodePlugin>>asCString: (in category 'utility') ----- asCString: stringOop "Return a C char * pointer into the given Squeak string object." "Warning: A Squeak string is not necessarily null-terminated." "Warning: the resulting pointer may become invalid after the next garbage collection and should only be using during the current primitive call." + <inline: false> + <returnTypeC: 'char *'> - 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 changed: ----- Method: UnicodePlugin>>cWordsPtr:minSize: (in category 'utility') ----- cWordsPtr: oop minSize: minSize "Return a C pointer to the first indexable field of oop, which must be a words object of at least the given size." "Warning: the resulting pointer may become invalid after the next garbage collection and should only be using during the current primitive call." + <inline: false> + <returnTypeC: 'void *'> - 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 changed: ----- Method: UnicodePlugin>>copyString:into:max: (in category 'utility') ----- copyString: stringOop into: stringPtr max: maxChars "Copy the Squeak string into a temporary buffer and add a terminating null byte. Fail if there is not sufficent space in the buffer." | srcPtr count | + <inline: false> + <var: 'stringPtr' declareC: 'char *stringPtr'> + <var: 'srcPtr' declareC: 'char *srcPtr'> - 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 changed: ----- Method: UnicodePlugin>>primitiveClipboardGet (in category 'primitives') ----- primitiveClipboardGet "Read the clipboard into the given UTF16 string.." | utf16Oop utf16 utf16Length count | + <export: true> + <var: 'utf16' declareC: 'unsigned short *utf16'> - 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 changed: ----- Method: UnicodePlugin>>primitiveClipboardPut (in category 'primitives') ----- primitiveClipboardPut "Set the clipboard to a UTF16 string.." | strOop count utf16 utf16Length | + <export: true> + <var: 'utf16' declareC: 'unsigned short *utf16'> - 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 changed: ----- Method: UnicodePlugin>>primitiveClipboardSize (in category 'primitives') ----- primitiveClipboardSize | count | + <export: true> - self export: true. count := self cCode: 'unicodeClipboardSize()'. interpreterProxy pop: 1 thenPush: (interpreterProxy integerObjectOf: count). ^ 0 ! Item was changed: ----- Method: UnicodePlugin>>primitiveDrawString (in category 'primitives') ----- primitiveDrawString | utf8Oop utf8 w h bitmapOop bitmapPtr utf8Length result | + <export: true> + <var: 'utf8' declareC: 'char *utf8'> + <var: 'bitmapPtr' declareC: 'void *bitmapPtr'> - 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 changed: ----- Method: UnicodePlugin>>primitiveGetFontList (in category 'primitives') ----- primitiveGetFontList | strOop str strLength count | + <export: true> + <var: 'str' declareC: 'char *str'> - 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 changed: ----- Method: UnicodePlugin>>primitiveGetXRanges (in category 'primitives') ----- primitiveGetXRanges | utf8Oop utf8 resultOop resultPtr utf8Length count resultLength | + <export: true> + <var: 'utf8' declareC: 'char *utf8'> + <var: 'resultPtr' declareC: 'int *resultPtr'> - 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 changed: ----- Method: UnicodePlugin>>primitiveMeasureString (in category 'primitives') ----- primitiveMeasureString | utf8Oop utf8 utf8Length w h result | + <export: true> + <var: 'utf8' declareC: 'char *utf8'> - 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 changed: ----- Method: UnicodePlugin>>primitiveSetColors (in category 'primitives') ----- primitiveSetColors | fgRed fgGreen fgBlue bgRed bgGreen bgBlue mapBGToTransparent | + <export: true> - 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 changed: ----- Method: UnicodePlugin>>primitiveSetFont (in category 'primitives') ----- primitiveSetFont | fontName fontSize boldFlag italicFlag antiAliasFlag | + <export: true> + <var: 'fontName' declareC: 'char fontName[200]'> - 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: ----- Method: WeDoPlugin>>primClosePort (in category 'translated prims') ----- primClosePort "Close the WeDo port." + <export: true> - self export: true. interpreterProxy success: (self cCode: 'WeDoClosePort()'). ^ 0 ! Item was changed: ----- Method: WeDoPlugin>>primOpenPort (in category 'translated prims') ----- primOpenPort "Open the WeDo port." + <export: true> - self export: true. interpreterProxy success: (self cCode: 'WeDoOpenPort()'). ^ 0 ! Item was changed: ----- Method: WeDoPlugin>>primRead (in category 'translated prims') ----- primRead "Read data from the WeDo port into the given buffer (a ByteArray or String). Answer the number of bytes read." | bufOop bufPtr bufSize byteCount | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 changed: ----- Method: WeDoPlugin>>primWrite (in category 'translated prims') ----- primWrite "Write data to the WeDo port from the given buffer (a ByteArray or String). Answer the number of bytes written." | bufOop bufPtr bufSize byteCount | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 !

1 0

[commit][2839] VMMaker 4.12.12 (VMMaker-dtl.334)
by commits＠squeakvm.org 04 Jan '14

04 Jan '14

Revision: 2839 Author: lewis Date: 2014-01-04 11:09:42 -0800 (Sat, 04 Jan 2014) Log Message: ----------- VMMaker 4.12.12 (VMMaker-dtl.334) Convert Scratch plugins to pragmas. Changes to generated code are cosmetic, e.g. variable names and ordering. Modified Paths: -------------- trunk/src/ckformat.c trunk/src/plugins/ADPCMCodecPlugin/ADPCMCodecPlugin.c trunk/src/plugins/AioPlugin/AioPlugin.c trunk/src/plugins/AsynchFilePlugin/AsynchFilePlugin.c trunk/src/plugins/B2DPlugin/B2DPlugin.c trunk/src/plugins/B3DAcceleratorPlugin/B3DAcceleratorPlugin.c trunk/src/plugins/BMPReadWriterPlugin/BMPReadWriterPlugin.c trunk/src/plugins/BitBltPlugin/BitBltPlugin.c trunk/src/plugins/CameraPlugin/CameraPlugin.c trunk/src/plugins/ClipboardExtendedPlugin/ClipboardExtendedPlugin.c trunk/src/plugins/CroquetPlugin/CroquetPlugin.c trunk/src/plugins/DBusPlugin/DBusPlugin.c trunk/src/plugins/DSAPrims/DSAPrims.c trunk/src/plugins/DropPlugin/DropPlugin.c trunk/src/plugins/FFTPlugin/FFTPlugin.c trunk/src/plugins/FT2Plugin/FT2Plugin.c trunk/src/plugins/FileCopyPlugin/FileCopyPlugin.c trunk/src/plugins/FilePlugin/FilePlugin.c trunk/src/plugins/FloatArrayPlugin/FloatArrayPlugin.c trunk/src/plugins/FloatMathPlugin/FloatMathPlugin.c trunk/src/plugins/GeniePlugin/GeniePlugin.c trunk/src/plugins/HostWindowPlugin/HostWindowPlugin.c trunk/src/plugins/JPEGReadWriter2Plugin/JPEGReadWriter2Plugin.c trunk/src/plugins/JPEGReaderPlugin/JPEGReaderPlugin.c trunk/src/plugins/JoystickTabletPlugin/JoystickTabletPlugin.c trunk/src/plugins/Klatt/Klatt.c trunk/src/plugins/LargeIntegers/LargeIntegers.c trunk/src/plugins/LocalePlugin/LocalePlugin.c trunk/src/plugins/MIDIPlugin/MIDIPlugin.c trunk/src/plugins/Matrix2x3Plugin/Matrix2x3Plugin.c trunk/src/plugins/MiscPrimitivePlugin/MiscPrimitivePlugin.c trunk/src/plugins/Mpeg3Plugin/Mpeg3Plugin.c trunk/src/plugins/RePlugin/RePlugin.c trunk/src/plugins/RomePlugin/RomePlugin.c trunk/src/plugins/ScratchPlugin/ScratchPlugin.c trunk/src/plugins/SecurityPlugin/SecurityPlugin.c trunk/src/plugins/SerialPlugin/SerialPlugin.c trunk/src/plugins/SocketPlugin/SocketPlugin.c trunk/src/plugins/SoundCodecPrims/SoundCodecPrims.c trunk/src/plugins/SoundGenerationPlugin/SoundGenerationPlugin.c trunk/src/plugins/SoundPlugin/SoundPlugin.c trunk/src/plugins/Squeak3D/Squeak3D.c trunk/src/plugins/SqueakFFIPrims/SqueakFFIPrims.c trunk/src/plugins/SqueakSSL/SqueakSSL.c trunk/src/plugins/StarSqueakPlugin/StarSqueakPlugin.c trunk/src/plugins/UUIDPlugin/UUIDPlugin.c trunk/src/plugins/UnicodePlugin/UnicodePlugin.c trunk/src/plugins/UnixOSProcessPlugin/UnixOSProcessPlugin.c trunk/src/plugins/WeDoPlugin/WeDoPlugin.c trunk/src/plugins/XDisplayControlPlugin/XDisplayControlPlugin.c trunk/src/plugins/ZipPlugin/ZipPlugin.c trunk/src/vm/interp.c trunk/src/vm/interp.h trunk/src/vm/sqNamedPrims.h Modified: trunk/src/ckformat.c =================================================================== --- trunk/src/ckformat.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/ckformat.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -5,7 +5,7 @@ /* Usage: ckformat imageFileName */ /* --- DO NOT EDIT THIS FILE --- */ -/* --- Automatically generated from class ImageFormat 2013-12-30T13:12:01.886+01:00--- */ +/* --- Automatically generated from class ImageFormat 2014-01-04T14:04:16.401+01:00--- */ /* --- Source code is in package ImageFormat in the VMMaker repository --- */ /* --- DO NOT EDIT THIS FILE --- */ Modified: trunk/src/plugins/ADPCMCodecPlugin/ADPCMCodecPlugin.c =================================================================== --- trunk/src/plugins/ADPCMCodecPlugin/ADPCMCodecPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/ADPCMCodecPlugin/ADPCMCodecPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:34 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:35 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - ADPCMCodecPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + ADPCMCodecPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "ADPCMCodecPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "ADPCMCodecPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -70,9 +70,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "ADPCMCodecPlugin 30 December 2013 (i)" + "ADPCMCodecPlugin 4 January 2014 (i)" #else - "ADPCMCodecPlugin 30 December 2013 (e)" + "ADPCMCodecPlugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/AioPlugin/AioPlugin.c =================================================================== --- trunk/src/plugins/AioPlugin/AioPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/AioPlugin/AioPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,6 +1,6 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:12 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:04:14 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from UnixAioPlugin VMConstruction-Plugins-AioPlugin-eem.15 uuid: 0029df1c-3720-4b61-8579-4851417d24a7 */ @@ -88,9 +88,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "AioPlugin 30 December 2013 (i)" + "AioPlugin 4 January 2014 (i)" #else - "AioPlugin 30 December 2013 (e)" + "AioPlugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/AsynchFilePlugin/AsynchFilePlugin.c =================================================================== --- trunk/src/plugins/AsynchFilePlugin/AsynchFilePlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/AsynchFilePlugin/AsynchFilePlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:35 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:35 pm */ /* Automatically generated by - SmartSyntaxPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + SmartSyntaxPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - AsynchFilePlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + AsynchFilePlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "AsynchFilePlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "AsynchFilePlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -67,9 +67,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "AsynchFilePlugin 30 December 2013 (i)" + "AsynchFilePlugin 4 January 2014 (i)" #else - "AsynchFilePlugin 30 December 2013 (e)" + "AsynchFilePlugin 4 January 2014 (e)" #endif ; static void * sCOAFfn; @@ -214,7 +214,7 @@ bufferSize = bufferSize * 4; } interpreterProxy->success((startIndex >= 1) && (((startIndex + count) - 1) <= bufferSize)); - bufferPtr = (((pointerForOop(buffer)) + (BASE_HEADER_SIZE)) + startIndex) - 1; + bufferPtr = ((((sqMemoryBase) + buffer) + (BASE_HEADER_SIZE)) + startIndex) - 1; if (!(interpreterProxy->failed())) { r = asyncFileReadResult(f, bufferPtr, count); } @@ -306,7 +306,7 @@ bufferSize = bufferSize * (BYTES_PER_WORD); } interpreterProxy->success((startIndex >= 1) && (((startIndex + count) - 1) <= bufferSize)); - bufferPtr = (((pointerForOop(buffer)) + (BASE_HEADER_SIZE)) + startIndex) - 1; + bufferPtr = ((((sqMemoryBase) + buffer) + (BASE_HEADER_SIZE)) + startIndex) - 1; if (!(interpreterProxy->failed())) { asyncFileWriteStart(f, fPosition, bufferPtr, count); } Modified: trunk/src/plugins/B2DPlugin/B2DPlugin.c =================================================================== --- trunk/src/plugins/B2DPlugin/B2DPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/B2DPlugin/B2DPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:38 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:39 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - BalloonEnginePlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + BalloonEnginePlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "BalloonEnginePlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "BalloonEnginePlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -447,9 +447,9 @@ static void * loadBBFn; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "B2DPlugin 30 December 2013 (i)" + "B2DPlugin 4 January 2014 (i)" #else - "B2DPlugin 30 December 2013 (e)" + "B2DPlugin 4 January 2014 (e)" #endif ; static int* objBuffer; Modified: trunk/src/plugins/B3DAcceleratorPlugin/B3DAcceleratorPlugin.c =================================================================== --- trunk/src/plugins/B3DAcceleratorPlugin/B3DAcceleratorPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/B3DAcceleratorPlugin/B3DAcceleratorPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:49 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:58 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - B3DAcceleratorPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + B3DAcceleratorPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "B3DAcceleratorPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "B3DAcceleratorPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -107,9 +107,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "B3DAcceleratorPlugin 30 December 2013 (i)" + "B3DAcceleratorPlugin 4 January 2014 (i)" #else - "B3DAcceleratorPlugin 30 December 2013 (e)" + "B3DAcceleratorPlugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/BMPReadWriterPlugin/BMPReadWriterPlugin.c =================================================================== --- trunk/src/plugins/BMPReadWriterPlugin/BMPReadWriterPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/BMPReadWriterPlugin/BMPReadWriterPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:35 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:36 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - BMPReadWriterPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + BMPReadWriterPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "BMPReadWriterPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "BMPReadWriterPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -58,9 +58,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "BMPReadWriterPlugin 30 December 2013 (i)" + "BMPReadWriterPlugin 4 January 2014 (i)" #else - "BMPReadWriterPlugin 30 December 2013 (e)" + "BMPReadWriterPlugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/BitBltPlugin/BitBltPlugin.c =================================================================== --- trunk/src/plugins/BitBltPlugin/BitBltPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/BitBltPlugin/BitBltPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:39 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:41 pm */ /* Automatically generated by - SmartSyntaxPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + SmartSyntaxPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - BitBltSimulation VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + BitBltSimulation VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "BitBltSimulation VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "BitBltSimulation VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -119,7 +119,6 @@ static sqInt copyLoopPixMap(void); static unsigned int * default8To32Table(void); static sqInt destinationWordwith(sqInt sourceWord, sqInt destinationWord); -static sqInt dstLongAt(sqInt idx); static sqInt fetchIntOrFloatofObject(sqInt fieldIndex, sqInt objectPointer); static sqInt fetchIntOrFloatofObjectifNil(sqInt fieldIndex, sqInt objectPointer, sqInt defaultValue); static sqInt fixAlphawith(sqInt sourceWord, sqInt destinationWord); @@ -257,9 +256,9 @@ }; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "BitBltPlugin 30 December 2013 (i)" + "BitBltPlugin 4 January 2014 (i)" #else - "BitBltPlugin 30 December 2013 (e)" + "BitBltPlugin 4 January 2014 (e)" #endif ; static sqInt nWords; @@ -729,8 +728,8 @@ sqInt dstY; sqInt ditherIndex; sqInt addThreshold; - sqInt addThreshold1; sqInt dstValue; + sqInt addThreshold1; sqInt dstValue1; @@ -770,7 +769,7 @@ } while (((deltaX -= 1)) != 0) { ditherThreshold = ditherMatrix4x4[ditherBase + ((ditherIndex = (ditherIndex + 1) & 3))]; - sourceWord = long32At(srcIndex); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0])); srcAlpha = ((usqInt) sourceWord) >> 24; if (srcAlpha == 255) { @@ -785,10 +784,10 @@ sourceWord = sourceWord << srcShift; } /* begin dstLongAt:put:mask: */ - dstValue = long32At(dstIndex); + dstValue = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); dstValue = dstValue & dstMask; dstValue = dstValue | sourceWord; - long32Atput(dstIndex, dstValue); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = dstValue)); } else { /* srcAlpha ~= 255 */ @@ -798,7 +797,7 @@ /* 0 < srcAlpha < 255 */ /* If we have to mix colors then just copy a single word */ - destWord = long32At(dstIndex); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); destWord = destWord & (~dstMask); /* Expand from 16 to 32 bit by adding zero bits */ @@ -821,10 +820,10 @@ sourceWord = sourceWord << srcShift; } /* begin dstLongAt:put:mask: */ - dstValue1 = long32At(dstIndex); + dstValue1 = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); dstValue1 = dstValue1 & dstMask; dstValue1 = dstValue1 | sourceWord; - long32Atput(dstIndex, dstValue1); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = dstValue1)); } } srcIndex += 4; @@ -895,17 +894,17 @@ deltaX = bbW + 1; while (((deltaX -= 1)) != 0) { - sourceWord = long32At(srcIndex); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0])); srcAlpha = ((usqInt) sourceWord) >> 24; if (srcAlpha == 255) { - long32Atput(dstIndex, sourceWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = sourceWord)); srcIndex += 4; /* Now copy as many words as possible with alpha = 255 */ dstIndex += 4; - while ((((deltaX -= 1)) != 0) && ((((usqInt) ((sourceWord = long32At(srcIndex)))) >> 24) == 255)) { - long32Atput(dstIndex, sourceWord); + while ((((deltaX -= 1)) != 0) && ((((usqInt) ((sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0]))))) >> 24) == 255)) { + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = sourceWord)); srcIndex += 4; dstIndex += 4; } @@ -920,7 +919,7 @@ /* Now skip as many words as possible, */ dstIndex += 4; - while ((((deltaX -= 1)) != 0) && ((((usqInt) ((sourceWord = long32At(srcIndex)))) >> 24) == 0)) { + while ((((deltaX -= 1)) != 0) && ((((usqInt) ((sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0]))))) >> 24) == 0)) { srcIndex += 4; dstIndex += 4; } @@ -930,9 +929,9 @@ /* 0 < srcAlpha < 255 */ /* If we have to mix colors then just copy a single word */ - destWord = long32At(dstIndex); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); destWord = alphaBlendScaledwith(sourceWord, destWord); - long32Atput(dstIndex, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = destWord)); srcIndex += 4; dstIndex += 4; } @@ -1006,7 +1005,7 @@ dstMask = mask2; while (((deltaX -= 1)) != 0) { - sourceWord = ((long32At(srcIndex)) & (~adjust)) + adjust; + sourceWord = ((((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0]))) & (~adjust)) + adjust; srcAlpha = ((usqInt) sourceWord) >> 24; if (srcAlpha > 31) { @@ -1016,7 +1015,7 @@ /* Everything above 224 is opaque */ - destWord = long32At(dstIndex); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); destWord = destWord & (~dstMask); destWord = ((usqInt) destWord) >> srcShift; destWord = mappingTable[destWord]; @@ -1045,10 +1044,10 @@ sourceWord = sourceWord << srcShift; /* begin dstLongAt:put:mask: */ - dstValue = long32At(dstIndex); + dstValue = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); dstValue = dstValue & dstMask; dstValue = dstValue | sourceWord; - long32Atput(dstIndex, dstValue); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = dstValue)); } srcIndex += 4; if (destMSB) { @@ -1805,21 +1804,6 @@ sqInt i; sqInt thisWord; sqInt notSkewMask; - sqInt idx; - sqInt idx1; - sqInt idx2; - sqInt idx3; - sqInt idx4; - sqInt idx5; - sqInt idx6; - sqInt idx7; - sqInt idx8; - sqInt idx9; - sqInt idx10; - sqInt idx11; - sqInt idx12; - sqInt idx13; - sqInt idx14; mergeFnwith = ((sqInt (*)(sqInt, sqInt)) (opTable[combinationRule + 1])); mergeFnwith; @@ -1849,7 +1833,7 @@ halftoneWord = AllOnes; halftoneHeight = 0; } else { - halftoneWord = long32At(halftoneBase + ((0 % halftoneHeight) * 4)); + halftoneWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + (halftoneBase + ((0 % halftoneHeight) * 4)))))[0])); } y = dy; for (i = 1; i <= bbH; i += 1) { @@ -1860,38 +1844,33 @@ /* Otherwise, its always the same */ - halftoneWord = long32At(halftoneBase + ((y % halftoneHeight) * 4)); + halftoneWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + (halftoneBase + ((y % halftoneHeight) * 4)))))[0])); y += vDir; } if (preload) { /* load the 64-bit shifter */ - /* begin srcLongAt: */ - idx = sourceIndex; - prevWord = long32At(idx); + prevWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); sourceIndex += hInc; } else { prevWord = 0; } destMask = mask1; - /* begin srcLongAt: */ - idx12 = sourceIndex; - thisWord = long32At(idx12); + + /* pick up next word */ + + thisWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); sourceIndex += hInc; /* 32-bit rotate */ skewWord = (((unskew < 0) ? ((usqInt) (prevWord & notSkewMask) >> -unskew) : ((usqInt) (prevWord & notSkewMask) << unskew))) | (((skew < 0) ? ((usqInt) (thisWord & skewMask) >> -skew) : ((usqInt) (thisWord & skewMask) << skew))); prevWord = thisWord; - /* begin dstLongAt: */ - idx13 = destIndex; - destWord = long32At(idx13); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0])); mergeWord = mergeFnwith(skewWord & halftoneWord, destWord); destWord = (destMask & mergeWord) | (destWord & (~destMask)); - /* begin dstLongAt:put: */ - idx14 = destIndex; - long32Atput(idx14, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = destWord)); /* This central horizontal loop requires no store masking */ @@ -1907,13 +1886,9 @@ /* Woeful patch: revert to older code for hDir = -1 */ for (word = 2; word <= (nWords - 1); word += 1) { - /* begin srcLongAt: */ - idx1 = sourceIndex; - thisWord = long32At(idx1); + thisWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); sourceIndex += hInc; - /* begin dstLongAt:put: */ - idx2 = destIndex; - long32Atput(idx2, thisWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = thisWord)); destIndex += hInc; } } else { @@ -1921,13 +1896,9 @@ /* Note loop starts with prevWord loaded (due to preload) */ - /* begin dstLongAt:put: */ - idx3 = destIndex; - long32Atput(idx3, prevWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = prevWord)); destIndex += hInc; - /* begin srcLongAt: */ - idx4 = sourceIndex; - prevWord = long32At(idx4); + prevWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); sourceIndex += hInc; } } @@ -1936,18 +1907,14 @@ /* Special inner loop for STORE mode -- no need to call merge */ for (word = 2; word <= (nWords - 1); word += 1) { - /* begin srcLongAt: */ - idx5 = sourceIndex; - thisWord = long32At(idx5); + thisWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); sourceIndex += hInc; /* 32-bit rotate */ skewWord = (((unskew < 0) ? ((usqInt) (prevWord & notSkewMask) >> -unskew) : ((usqInt) (prevWord & notSkewMask) << unskew))) | (((skew < 0) ? ((usqInt) (thisWord & skewMask) >> -skew) : ((usqInt) (thisWord & skewMask) << skew))); prevWord = thisWord; - /* begin dstLongAt:put: */ - idx6 = destIndex; - long32Atput(idx6, skewWord & halftoneWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = (skewWord & halftoneWord))); destIndex += hInc; } } @@ -1956,40 +1923,36 @@ /* Normal inner loop does merge: */ - /* begin srcLongAt: */ - idx7 = sourceIndex; - thisWord = long32At(idx7); + + /* pick up next word */ + + thisWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); sourceIndex += hInc; /* 32-bit rotate */ skewWord = (((unskew < 0) ? ((usqInt) (prevWord & notSkewMask) >> -unskew) : ((usqInt) (prevWord & notSkewMask) << unskew))) | (((skew < 0) ? ((usqInt) (thisWord & skewMask) >> -skew) : ((usqInt) (thisWord & skewMask) << skew))); prevWord = thisWord; - mergeWord = mergeFnwith(skewWord & halftoneWord, dstLongAt(destIndex)); - /* begin dstLongAt:put: */ - idx8 = destIndex; - long32Atput(idx8, mergeWord); + mergeWord = mergeFnwith(skewWord & halftoneWord, ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0]))); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = mergeWord)); destIndex += hInc; } } if (nWords > 1) { destMask = mask2; - /* begin srcLongAt: */ - idx9 = sourceIndex; - thisWord = long32At(idx9); + + /* pick up next word */ + + thisWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); sourceIndex += hInc; /* 32-bit rotate */ skewWord = (((unskew < 0) ? ((usqInt) (prevWord & notSkewMask) >> -unskew) : ((usqInt) (prevWord & notSkewMask) << unskew))) | (((skew < 0) ? ((usqInt) (thisWord & skewMask) >> -skew) : ((usqInt) (thisWord & skewMask) << skew))); - /* begin dstLongAt: */ - idx10 = destIndex; - destWord = long32At(idx10); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0])); mergeWord = mergeFnwith(skewWord & halftoneWord, destWord); destWord = (destMask & mergeWord) | (destWord & (~destMask)); - /* begin dstLongAt:put: */ - idx11 = destIndex; - long32Atput(idx11, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = destWord)); destIndex += hInc; } sourceIndex += sourceDelta; @@ -2009,13 +1972,6 @@ sqInt word; sqInt i; sqInt idx; - sqInt idx1; - sqInt idx2; - sqInt idx3; - sqInt idx4; - sqInt idx5; - sqInt idx6; - sqInt idx7; mergeFnwith = ((sqInt (*)(sqInt, sqInt)) (opTable[combinationRule + 1])); mergeFnwith; @@ -2028,17 +1984,13 @@ } else { /* begin halftoneAt: */ idx = (dy + i) - 1; - halftoneWord = long32At(halftoneBase + ((idx % halftoneHeight) * 4)); + halftoneWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + (halftoneBase + ((idx % halftoneHeight) * 4)))))[0])); } destMask = mask1; - /* begin dstLongAt: */ - idx6 = destIndex; - destWord = long32At(idx6); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0])); mergeWord = mergeFnwith(halftoneWord, destWord); destWord = (destMask & mergeWord) | (destWord & (~destMask)); - /* begin dstLongAt:put: */ - idx7 = destIndex; - long32Atput(idx7, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = destWord)); /* This central horizontal loop requires no store masking */ @@ -2050,9 +2002,7 @@ destWord = halftoneWord; for (word = 2; word <= (nWords - 1); word += 1) { - /* begin dstLongAt:put: */ - idx1 = destIndex; - long32Atput(idx1, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = destWord)); destIndex += 4; } } else { @@ -2063,26 +2013,18 @@ /* Normal inner loop does merge */ - /* begin dstLongAt: */ - idx2 = destIndex; - destWord = long32At(idx2); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0])); mergeWord = mergeFnwith(halftoneWord, destWord); - /* begin dstLongAt:put: */ - idx3 = destIndex; - long32Atput(idx3, mergeWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = mergeWord)); destIndex += 4; } } if (nWords > 1) { destMask = mask2; - /* begin dstLongAt: */ - idx4 = destIndex; - destWord = long32At(idx4); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0])); mergeWord = mergeFnwith(halftoneWord, destWord); destWord = (destMask & mergeWord) | (destWord & (~destMask)); - /* begin dstLongAt:put: */ - idx5 = destIndex; - long32Atput(idx5, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = destWord)); destIndex += 4; } destIndex += destDelta; @@ -2124,10 +2066,6 @@ sqInt nPix; sqInt scrStartBits; sqInt idx; - sqInt idx1; - sqInt value; - sqInt idx2; - sqInt idx3; sqInt sourcePix; sqInt srcShift1; sqInt sourceWord; @@ -2136,10 +2074,9 @@ sqInt nPix1; sqInt destWord1; sqInt pv; - sqInt idx4; sqInt val; - sqInt idx11; - sqInt idx21; + sqInt idx1; + sqInt idx2; mergeFnwith = ((sqInt (*)(sqInt, sqInt)) (opTable[combinationRule + 1])); mergeFnwith; @@ -2187,7 +2124,7 @@ } else { /* begin halftoneAt: */ idx = (dy + i) - 1; - halftoneWord = long32At(halftoneBase + ((idx % halftoneHeight) * 4)); + halftoneWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + (halftoneBase + ((idx % halftoneHeight) * 4)))))[0])); } srcBitShift = srcShift; dstBitShift = dstShift; @@ -2202,9 +2139,7 @@ /* pick up the word */ /* begin pickSourcePixels:flags:srcMask:destMask:srcShiftInc:dstShiftInc: */ - /* begin srcLongAt: */ - idx21 = sourceIndex; - sourceWord = long32At(idx21); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + sourceIndex)))[0])); destWord1 = 0; srcShift1 = srcBitShift; dstShift1 = dstBitShift; @@ -2222,8 +2157,8 @@ srcShift1 -= 32; } /* begin srcLongAt: */ - idx4 = (sourceIndex += 4); - sourceWord = long32At(idx4); + idx1 = (sourceIndex += 4); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + idx1)))[0])); } } while(!(((nPix1 -= 1)) == 0)); } else { @@ -2256,8 +2191,8 @@ srcShift1 -= 32; } /* begin srcLongAt: */ - idx11 = (sourceIndex += 4); - sourceWord = long32At(idx11); + idx2 = (sourceIndex += 4); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + idx2)))[0])); } } while(!(((nPix1 -= 1)) == 0)); } @@ -2268,23 +2203,16 @@ /* avoid read-modify-write */ - mergeWord = mergeFnwith(skewWord & halftoneWord, dstLongAt(destIndex)); - /* begin dstLongAt:put: */ - idx1 = destIndex; - value = destMask & mergeWord; - long32Atput(idx1, value); + mergeWord = mergeFnwith(skewWord & halftoneWord, ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0]))); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = (destMask & mergeWord))); } else { /* General version using dest masking */ - /* begin dstLongAt: */ - idx2 = destIndex; - destWord = long32At(idx2); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0])); mergeWord = mergeFnwith(skewWord & halftoneWord, destWord & destMask); destWord = (destMask & mergeWord) | (destWord & (~destMask)); - /* begin dstLongAt:put: */ - idx3 = destIndex; - long32Atput(idx3, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = destWord)); } destIndex += 4; if (words == 2) { @@ -2366,11 +2294,7 @@ return destinationWord; } -static sqInt dstLongAt(sqInt idx) { - return long32At(idx); -} - /* Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers. */ static sqInt fetchIntOrFloatofObject(sqInt fieldIndex, sqInt objectPointer) { @@ -2570,14 +2494,17 @@ sqInt formPointer; sqInt formPointer1; sqInt destBitsSize; + char *ptr; sqInt sourceBitsSize; sqInt oop; sqInt cmOop; sqInt cmSize; sqInt oldStyle; sqInt halftoneBits; + char *ptr1; sqInt mapOop; sqInt mapOop1; + char *ptr2; bitBltOop = bbObj; isWarping = aBool; @@ -2670,7 +2597,9 @@ ok = 0; goto l3; } - destBits = oopForPointer(interpreterProxy->firstIndexableField(destBits)); + /* begin bits_oopForPointer: */ + ptr = interpreterProxy->firstIndexableField(destBits); + destBits = ((usqInt) (ptr - (sqMemoryBase))); } ok = 1; l3: /* end loadBitBltDestForm */; @@ -2718,7 +2647,9 @@ ok = 0; goto l4; } - sourceBits = oopForPointer(interpreterProxy->firstIndexableField(sourceBits)); + /* begin bits_oopForPointer: */ + ptr1 = interpreterProxy->firstIndexableField(sourceBits); + sourceBits = ((usqInt) (ptr1 - (sqMemoryBase))); } ok = 1; l4: /* end loadBitBltSourceForm */; @@ -2858,7 +2789,9 @@ halftoneBits = halftoneForm; halftoneHeight = interpreterProxy->slotSizeOf(halftoneBits); } - halftoneBase = oopForPointer(interpreterProxy->firstIndexableField(halftoneBits)); + /* begin bits_oopForPointer: */ + ptr2 = interpreterProxy->firstIndexableField(halftoneBits); + halftoneBase = ((usqInt) (ptr2 - (sqMemoryBase))); ok = 1; l6: /* end loadHalftoneForm */; if (!(ok)) { @@ -3389,7 +3322,7 @@ left = destX; sourcePtr = interpreterProxy->firstIndexableField(sourceString); for (charIndex = startIndex; charIndex <= stopIndex; charIndex += 1) { - ascii = byteAtPointer((sourcePtr + charIndex) - 1); + ascii = ((sqInt) ((((unsigned char *) ((sourcePtr + charIndex) - 1)))[0])); glyphIndex = interpreterProxy->fetchIntegerofObject(ascii, glyphMap); if ((glyphIndex < 0) || (glyphIndex > maxGlyph)) { return interpreterProxy->primitiveFail(); @@ -3885,14 +3818,14 @@ } while (((deltaX -= 1)) != 0) { ditherThreshold = ditherMatrix4x4[ditherBase + ((ditherIndex = (ditherIndex + 1) & 3))]; - sourceWord = long32At(srcIndex); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0])); srcAlpha = sourceWord & 16777215; if (!(srcAlpha == 0)) { /* 0 < srcAlpha */ /* If we have to mix colors then just copy a single word */ - destWord = long32At(dstIndex); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); destWord = destWord & (~dstMask); /* Expand from 16 to 32 bit by adding zero bits */ @@ -3915,10 +3848,10 @@ sourceWord = sourceWord << srcShift; } /* begin dstLongAt:put:mask: */ - dstValue = long32At(dstIndex); + dstValue = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); dstValue = dstValue & dstMask; dstValue = dstValue | sourceWord; - long32Atput(dstIndex, dstValue); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = dstValue)); } srcIndex += 4; if (destMSB) { @@ -3988,7 +3921,7 @@ deltaX = bbW + 1; while (((deltaX -= 1)) != 0) { - sourceWord = long32At(srcIndex); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0])); srcAlpha = sourceWord & 16777215; if (srcAlpha == 0) { srcIndex += 4; @@ -3996,7 +3929,7 @@ /* Now skip as many words as possible, */ dstIndex += 4; - while ((((deltaX -= 1)) != 0) && ((((sourceWord = long32At(srcIndex))) & 16777215) == 0)) { + while ((((deltaX -= 1)) != 0) && ((((sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0])))) & 16777215) == 0)) { srcIndex += 4; dstIndex += 4; } @@ -4006,9 +3939,9 @@ /* 0 < srcAlpha */ /* If we have to mix colors then just copy a single word */ - destWord = long32At(dstIndex); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); destWord = rgbComponentAlpha32with(sourceWord, destWord); - long32Atput(dstIndex, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = destWord)); srcIndex += 4; dstIndex += 4; } @@ -4194,7 +4127,7 @@ dstMask = mask2; while (((deltaX -= 1)) != 0) { - sourceWord = ((long32At(srcIndex)) & (~adjust)) + adjust; + sourceWord = ((((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0]))) & (~adjust)) + adjust; /* set srcAlpha to the average of the 3 separate aR,Ag,AB values */ @@ -4210,7 +4143,7 @@ sourceWord = 4294967295U; } - destWord = long32At(dstIndex); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); destWord = destWord & (~dstMask); destWord = ((usqInt) destWord) >> srcShift; destWord = mappingTable[destWord]; @@ -4238,10 +4171,10 @@ sourceWord = sourceWord << srcShift; /* begin dstLongAt:put:mask: */ - dstValue = long32At(dstIndex); + dstValue = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0])); dstValue = dstValue & dstMask; dstValue = dstValue | sourceWord; - long32Atput(dstIndex, dstValue); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + dstIndex)))[0] = dstValue)); } srcIndex += 4; if (destMSB) { @@ -4896,7 +4829,7 @@ sqInt pAy; sqInt dstShiftInc; sqInt pBx; - sqInt sourceMapOop; + usqInt sourceMapOop; sqInt xDelta; sqInt pAx; sqInt deltaP12y; @@ -4905,10 +4838,7 @@ sqInt deltaP12x; sqInt smoothingCount; sqInt idx; - sqInt idx1; - sqInt value; - sqInt idx2; - sqInt idx3; + char *ptr; sqInt i1; sqInt words1; sqInt sourcePix; @@ -4917,16 +4847,12 @@ sqInt dstMask; sqInt destWord1; sqInt pv; - sqInt xx; - sqInt yy; + sqInt val; sqInt sourcePix1; sqInt sourceWord; sqInt srcIndex; sqInt x; sqInt y; - sqInt val; - sqInt xx1; - sqInt yy1; sqInt sourcePix2; sqInt sourceWord1; sqInt srcIndex1; @@ -5034,7 +4960,9 @@ return interpreterProxy->primitiveFail(); } - sourceMapOop = oopForPointer(interpreterProxy->firstIndexableField(sourceMapOop)); + /* begin bits_oopForPointer: */ + ptr = interpreterProxy->firstIndexableField(sourceMapOop); + sourceMapOop = ((usqInt) (ptr - (sqMemoryBase))); } } else { smoothingCount = 1; @@ -5149,7 +5077,7 @@ } else { /* begin halftoneAt: */ idx = (dy + i) - 1; - halftoneWord = long32At(halftoneBase + ((idx % halftoneHeight) * 4)); + halftoneWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + (halftoneBase + ((idx % halftoneHeight) * 4)))))[0])); } destMask = mask1; @@ -5172,14 +5100,12 @@ if (mapperFlags == (ColorMapPresent | ColorMapIndexedPart)) { do { /* begin pickWarpPixelAtX:y: */ - xx = sx; - yy = sy; - if ((xx < 0) || ((yy < 0) || ((((x = ((usqInt) xx) >> BinaryPoint)) >= sourceWidth) || (((y = ((usqInt) yy) >> BinaryPoint)) >= sourceHeight)))) { + if ((sx < 0) || ((sy < 0) || ((((x = ((usqInt) sx) >> BinaryPoint)) >= sourceWidth) || (((y = ((usqInt) sy) >> BinaryPoint)) >= sourceHeight)))) { sourcePix = 0; goto l7; } srcIndex = (sourceBits + (y * sourcePitch)) + ((((usqInt) x) >> warpAlignShift) * 4); - sourceWord = long32At(srcIndex); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0])); srcBitShift = warpBitShiftTable[x & warpAlignMask]; sourcePix1 = (((usqInt) sourceWord) >> srcBitShift) & warpSrcMask; sourcePix = sourcePix1; @@ -5193,14 +5119,12 @@ } else { do { /* begin pickWarpPixelAtX:y: */ - xx1 = sx; - yy1 = sy; - if ((xx1 < 0) || ((yy1 < 0) || ((((x1 = ((usqInt) xx1) >> BinaryPoint)) >= sourceWidth) || (((y1 = ((usqInt) yy1) >> BinaryPoint)) >= sourceHeight)))) { + if ((sx < 0) || ((sy < 0) || ((((x1 = ((usqInt) sx) >> BinaryPoint)) >= sourceWidth) || (((y1 = ((usqInt) sy) >> BinaryPoint)) >= sourceHeight)))) { sourcePix = 0; goto l8; } srcIndex1 = (sourceBits + (y1 * sourcePitch)) + ((((usqInt) x1) >> warpAlignShift) * 4); - sourceWord1 = long32At(srcIndex1); + sourceWord1 = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex1)))[0])); srcBitShift = warpBitShiftTable[x1 & warpAlignMask]; sourcePix2 = (((usqInt) sourceWord1) >> srcBitShift) & warpSrcMask; sourcePix = sourcePix2; @@ -5241,23 +5165,16 @@ /* avoid read-modify-write */ - mergeWord = mergeFnwith(skewWord & halftoneWord, dstLongAt(destIndex)); - /* begin dstLongAt:put: */ - idx1 = destIndex; - value = destMask & mergeWord; - long32Atput(idx1, value); + mergeWord = mergeFnwith(skewWord & halftoneWord, ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0]))); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = (destMask & mergeWord))); } else { /* General version using dest masking */ - /* begin dstLongAt: */ - idx2 = destIndex; - destWord = long32At(idx2); + destWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0])); mergeWord = mergeFnwith(skewWord & halftoneWord, destWord & destMask); destWord = (destMask & mergeWord) | (destWord & (~destMask)); - /* begin dstLongAt:put: */ - idx3 = destIndex; - long32Atput(idx3, destWord); + ((sqInt) ((((unsigned int *) ((sqMemoryBase) + destIndex)))[0] = destWord)); } destIndex += 4; if (words == 2) { @@ -5362,7 +5279,7 @@ goto l1; } srcIndex = (sourceBits + (y1 * sourcePitch)) + ((((usqInt) x1) >> warpAlignShift) * 4); - sourceWord = long32At(srcIndex); + sourceWord = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + srcIndex)))[0])); srcBitShift = warpBitShiftTable[x1 & warpAlignMask]; sourcePix = (((usqInt) sourceWord) >> srcBitShift) & warpSrcMask; rgb = sourcePix; @@ -5376,7 +5293,7 @@ /* Get RGBA values from sourcemap table */ - rgb = long32At(sourceMap + (rgb << 2)); + rgb = ((sqInt) ((((unsigned int *) ((sqMemoryBase) + (sourceMap + (rgb << 2)))))[0])); } else { /* Already in RGB format */ Modified: trunk/src/plugins/CameraPlugin/CameraPlugin.c =================================================================== --- trunk/src/plugins/CameraPlugin/CameraPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/CameraPlugin/CameraPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:51 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:59 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - CameraPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + CameraPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "CameraPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "CameraPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -64,9 +64,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "CameraPlugin 30 December 2013 (i)" + "CameraPlugin 4 January 2014 (i)" #else - "CameraPlugin 30 December 2013 (e)" + "CameraPlugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/ClipboardExtendedPlugin/ClipboardExtendedPlugin.c =================================================================== --- trunk/src/plugins/ClipboardExtendedPlugin/ClipboardExtendedPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/ClipboardExtendedPlugin/ClipboardExtendedPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:51 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:04 pm */ /* Automatically generated by - SmartSyntaxPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + SmartSyntaxPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - ClipboardExtendedPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + ClipboardExtendedPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "ClipboardExtendedPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "ClipboardExtendedPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -61,9 +61,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "ClipboardExtendedPlugin 30 December 2013 (i)" + "ClipboardExtendedPlugin 4 January 2014 (i)" #else - "ClipboardExtendedPlugin 30 December 2013 (e)" + "ClipboardExtendedPlugin 4 January 2014 (e)" #endif ; @@ -215,8 +215,8 @@ {"ClipboardExtendedPlugin", "setInterpreter", (void*)setInterpreter}, {"ClipboardExtendedPlugin", "ioGetClipboardFormat", (void*)ioGetClipboardFormat}, {"ClipboardExtendedPlugin", "ioCreateClipboard", (void*)ioCreateClipboard}, + {"ClipboardExtendedPlugin", "ioAddClipboardData", (void*)ioAddClipboardData}, {"ClipboardExtendedPlugin", "ioReadClipboardData", (void*)ioReadClipboardData}, - {"ClipboardExtendedPlugin", "ioAddClipboardData", (void*)ioAddClipboardData}, {NULL, NULL, NULL} }; Modified: trunk/src/plugins/CroquetPlugin/CroquetPlugin.c =================================================================== --- trunk/src/plugins/CroquetPlugin/CroquetPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/CroquetPlugin/CroquetPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:39 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:42 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - CroquetPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + CroquetPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "CroquetPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "CroquetPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -73,9 +73,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "CroquetPlugin 30 December 2013 (i)" + "CroquetPlugin 4 January 2014 (i)" #else - "CroquetPlugin 30 December 2013 (e)" + "CroquetPlugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/DBusPlugin/DBusPlugin.c =================================================================== --- trunk/src/plugins/DBusPlugin/DBusPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/DBusPlugin/DBusPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,6 +1,6 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:51 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:04:01 pm */ /* Automatically generated by - SmartSyntaxPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + SmartSyntaxPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from DBusPlugin DBus-Plugin-dtl.35 uuid: 2ae30f08-4793-4acb-876b-c443a5f5e665 */ @@ -143,9 +143,9 @@ static DBusMessageIter messageIter[DBUS_MAXIMUM_TYPE_RECURSION_DEPTH]; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "DBusPlugin 30 December 2013 (i)" + "DBusPlugin 4 January 2014 (i)" #else - "DBusPlugin 30 December 2013 (e)" + "DBusPlugin 4 January 2014 (e)" #endif ; static DBusMessage* writeMessage; Modified: trunk/src/plugins/DSAPrims/DSAPrims.c =================================================================== --- trunk/src/plugins/DSAPrims/DSAPrims.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/DSAPrims/DSAPrims.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:40 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:42 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - DSAPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + DSAPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "DSAPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "DSAPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -67,9 +67,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "DSAPrims 30 December 2013 (i)" + "DSAPrims 4 January 2014 (i)" #else - "DSAPrims 30 December 2013 (e)" + "DSAPrims 4 January 2014 (e)" #endif ; static sqInt remainderDigitCount; Modified: trunk/src/plugins/DropPlugin/DropPlugin.c =================================================================== --- trunk/src/plugins/DropPlugin/DropPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/DropPlugin/DropPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:40 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:44 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - DropPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + DropPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "DropPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "DropPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -62,9 +62,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "DropPlugin 30 December 2013 (i)" + "DropPlugin 4 January 2014 (i)" #else - "DropPlugin 30 December 2013 (e)" + "DropPlugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/FFTPlugin/FFTPlugin.c =================================================================== --- trunk/src/plugins/FFTPlugin/FFTPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/FFTPlugin/FFTPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:41 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:44 pm */ /* Automatically generated by - VMPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + VMPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - FFTPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + FFTPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "FFTPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "FFTPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -68,9 +68,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "FFTPlugin 30 December 2013 (i)" + "FFTPlugin 4 January 2014 (i)" #else - "FFTPlugin 30 December 2013 (e)" + "FFTPlugin 4 January 2014 (e)" #endif ; static sqInt nu; Modified: trunk/src/plugins/FT2Plugin/FT2Plugin.c =================================================================== --- trunk/src/plugins/FT2Plugin/FT2Plugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/FT2Plugin/FT2Plugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,4 +1,4 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:41 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:03:45 pm */ /* Automatically generated by FT2PluginCodeGenerator * FreeType-nice.442 uuid: 9895a884-7d42-4783-9fb8-1a71ef244e16 from @@ -121,9 +121,9 @@ static FT_Library library; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "FT2Plugin 30 December 2013 (i)" + "FT2Plugin 4 January 2014 (i)" #else - "FT2Plugin 30 December 2013 (e)" + "FT2Plugin 4 January 2014 (e)" #endif ; Modified: trunk/src/plugins/FileCopyPlugin/FileCopyPlugin.c =================================================================== --- trunk/src/plugins/FileCopyPlugin/FileCopyPlugin.c 2013-12-30 18:28:08 UTC (rev 2838) +++ trunk/src/plugins/FileCopyPlugin/FileCopyPlugin.c 2014-01-04 19:09:42 UTC (rev 2839) @@ -1,10 +1,10 @@ -/* Smalltalk from Squeak4.4 with VMMaker 4.12.11 translated as C source on 30 December 2013 1:11:53 pm */ +/* Smalltalk from Squeak4.4 with VMMaker 4.12.12 translated as C source on 4 January 2014 2:04:03 pm */ /* Automatically generated by - SmartSyntaxPluginCodeGenerator VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + SmartSyntaxPluginCodeGenerator VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f from - FileCopyPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 + FileCopyPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f */ -static char __buildInfo[] = "FileCopyPlugin VMMaker-dtl.333 uuid: 9ffe16dc-ba45-44c6-a894-ed3d96a8c916 " __DATE__ ; +static char __buildInfo[] = "FileCopyPlugin VMMaker-dtl.334 uuid: 61416154-73bc-45d7-9f3a-739a51ae816f " __DATE__ ; @@ -57,9 +57,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "FileCopyPlugin 30 December 2013 (i)" + "FileCopyPlugin 4 January 2014 (i)" #else - "FileCopyPlugin 30 December 2013 (e)" + "FileCopyPlugin 4 January 2014 (e)" #endif ; @@ -125,8 +125,8 @@ @@ Diff output truncated at 50000 characters. @@

1 0

VM Maker: VMMaker-dtl.334.mcz
by commits＠source.squeak.org 04 Jan '14

04 Jan '14

David T. Lewis uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-dtl.334.mcz ==================== Summary ==================== Name: VMMaker-dtl.334 Author: dtl Time: 4 January 2014, 2:02:44.168 pm UUID: 61416154-73bc-45d7-9f3a-739a51ae816f Ancestors: VMMaker-dtl.333 VMMaker 4.12.12 Convert Scratch plugins to pragmas. Changes to generated code are cosmetic, e.g. variable names and ordering. Conversion script: converter := Pragmatizer on: 'VMMaker' selectors: #(#export: #static: #inline: #returnTypeC: #var:declareC: #var:type: ). converter classes: { CameraPlugin . ScratchPlugin . WeDoPlugin . UnicodePlugin }. converter pragmatize. =============== Diff against VMMaker-dtl.333 =============== Item was changed: ----- 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 | + <export: true> + <var: 'nameStr' declareC: 'char* nameStr'> + <var: 'dst' declareC: 'char* 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 changed: ----- Method: CameraPlugin>>primCloseCamera (in category 'primitives') ----- primCloseCamera "Close the camera. Do nothing if it was not open." | cameraNum | + <export: true> - 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 changed: ----- 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 | + <export: true> - 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 changed: ----- Method: CameraPlugin>>primGetFrame (in category 'primitives') ----- primGetFrame "Copy a camera frame into the given Bitmap. The Bitmap should be for a Form of depth 32 that is the same width and height as the current camera frame. Fail if the camera is not open or if the bitmap is not the right size. If successful, answer the number of frames received from the camera since the last call. If this is zero, then there has been no change." | cameraNum bitmapOop bitmap pixCount result | + <export: true> + <var: 'bitmap' declareC: 'unsigned char *bitmap'> - 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 changed: ----- Method: CameraPlugin>>primGetParam (in category 'primitives') ----- primGetParam "Answer the given integer parameter of the given camera." | cameraNum paramNum result | + <export: true> - 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 changed: ----- Method: CameraPlugin>>primOpenCamera (in category 'primitives') ----- primOpenCamera "Open a camera. Takes one argument, the index of the device to open." | cameraNum desiredFrameWidth desiredFrameHeight ok | + <export: true> - 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: 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 | + <inline: true> + <var: 'bitmap' declareC: 'unsigned int *bitmap'> - 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 changed: ----- 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." + <inline: true> + <returnTypeC: 'double *'> - self inline: true. - self returnTypeC: 'double *'. interpreterProxy success: (interpreterProxy isWordsOrBytes: oop). interpreterProxy failed ifTrue: [^ 0]. ^ self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'double *' ! Item was changed: ----- 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." + <inline: true> + <returnTypeC: 'unsigned int *'> - 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 changed: ----- 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 | + <inline: true> - 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 changed: ----- 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 | + <inline: true> - 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 changed: ----- 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 | + <inline: true> + <var: 'bitmap' declareC: 'unsigned int *bitmap'> - 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 changed: ----- Method: ScratchPlugin>>primClose (in category 'serial port') ----- primClose "Close the given serial port." | portNum | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primGetOption (in category 'serial port') ----- primGetOption "Return the given option value for the given serial port." | portNum attrNum result | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primIsPortOpen (in category 'serial port') ----- primIsPortOpen "Answer the true if the given port is open." | portNum result | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primOpenPortNamed (in category 'serial port') ----- primOpenPortNamed "Open the port with the given name and baud rate." | nameStr src nameOop baudRate count portNum | + <export: true> + <var: 'nameStr' declareC: 'char nameStr[1000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primPortCount (in category 'serial port') ----- primPortCount "Answer the number of serial ports." | result | + <export: true> - 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 changed: ----- 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 | + <export: true> + <var: 'nameStr' declareC: 'char nameStr[1000]'> + <var: 'dst' declareC: 'char* 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 changed: ----- Method: ScratchPlugin>>primRead (in category 'serial port') ----- primRead "Read data from the given serial port into the given buffer (a ByteArray or String). Answer the number of bytes read." | portNum bufOop bufPtr bufSize bytesRead | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 changed: ----- Method: ScratchPlugin>>primSetOption (in category 'serial port') ----- primSetOption "Return the given option value for the given serial port." | portNum attrNum attrValue result | + <export: true> - 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 changed: ----- Method: ScratchPlugin>>primWrite (in category 'serial port') ----- primWrite "Write data to the given serial port from the given buffer (a ByteArray or String). Answer the number of bytes written." | portNum bufOop bufPtr bufSize bytesWritten | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 changed: ----- Method: ScratchPlugin>>primitiveBlur (in category 'other filters') ----- primitiveBlur | inOop outOop width in out sz height n rTotal gTotal bTotal pix outPix | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveBrightnessShift (in category 'hsv filters') ----- primitiveBrightnessShift | inOop outOop shift in sz out pix r g b max min hue saturation brightness | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveCondenseSound (in category 'sound') ----- primitiveCondenseSound | srcOop dstOop factor sz src dst count max v | + <export: true> + <var: 'src' declareC: 'short *src'> + <var: 'dst' declareC: 'short *dst'> - 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 changed: ----- Method: ScratchPlugin>>primitiveDoubleSize (in category 'scaling') ----- primitiveDoubleSize | in out inOop outOop inW inH outW outH dstX dstY baseIndex pix i | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveExtractChannel (in category 'sound') ----- primitiveExtractChannel | srcOop dstOop rightFlag sz src dst | + <export: true> + <var: 'src' declareC: 'short *src'> + <var: 'dst' declareC: 'short *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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> + <var: 'scaleX' declareC: 'double scaleX'> + <var: 'scaleY' declareC: 'double scaleY'> + <var: 'whirlRadians' declareC: 'double whirlRadians'> + <var: 'radiusSquared' declareC: 'double radiusSquared'> + <var: 'dx' declareC: 'double dx'> + <var: 'dy' declareC: 'double dy'> + <var: 'd' declareC: 'double d'> + <var: 'factor' declareC: 'double factor'> + <var: 'ang' declareC: 'double ang'> + <var: 'sina' declareC: 'double sina'> + <var: 'cosa' declareC: 'double cosa'> + <var: 'r' declareC: 'double r'> + <var: 'scaledPower' declareC: 'double 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 changed: ----- 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 | + <export: true> + <var: 'nameStr' declareC: 'char nameStr[2000]'> + <var: 'dst' declareC: 'char* dst'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveHueShift (in category 'hsv filters') ----- primitiveHueShift | inOop outOop shift in sz out pix r g b max min brightness saturation hue | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveInterpolate (in category 'bilinear interpolation') ----- primitiveInterpolate | inOop xFixed yFixed width in sz result | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> - 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 changed: ----- Method: ScratchPlugin>>primitiveIsHidden (in category 'os functions') ----- primitiveIsHidden "Answer true if the file or folder with the given path should be hidden from the user. On Windows, this is the value of the 'hidden' file property." | pathOop src count fullPath result | + <export: true> + <var: 'fullPath' declareC: 'char fullPath[1000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primitiveOpenURL (in category 'os functions') ----- primitiveOpenURL "Open a web browser on the given URL." | urlStr src urlOop count | + <export: true> + <var: 'urlStr' declareC: 'char urlStr[2000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primitiveSaturationShift (in category 'hsv filters') ----- primitiveSaturationShift | inOop outOop shift in sz out pix r g b max min brightness saturation hue | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'int *in'> + <var: 'out' declareC: 'int *out'> - 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 changed: ----- Method: ScratchPlugin>>primitiveSetUnicodePasteBuffer (in category 'os functions') ----- primitiveSetUnicodePasteBuffer "Set the Mac OS X Unicode paste buffer." | utf16 strOop count | + <export: true> + <var: 'utf16' declareC: 'short int *utf16'> - 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 changed: ----- Method: ScratchPlugin>>primitiveSetWindowTitle (in category 'os functions') ----- primitiveSetWindowTitle "Set the title of the Scratch window." | titleStr src titleOop count | + <export: true> + <var: 'titleStr' declareC: 'char titleStr[1000]'> + <var: 'src' declareC: 'char * src'> - 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 changed: ----- Method: ScratchPlugin>>primitiveShortToLongPath (in category 'os functions') ----- primitiveShortToLongPath "On Windows, convert a short file/path name into a long one. Fail on other platforms." | shortPath longPath ptr shortPathOop result count resultOop | + <export: true> + <var: 'shortPath' declareC: 'char shortPath[1000]'> + <var: 'longPath' declareC: 'char longPath[1000]'> + <var: 'ptr' declareC: 'char * ptr'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> + <var: 'aArray' declareC: 'double *aArray'> + <var: 'bArray' declareC: 'double *bArray'> + <var: 'ripply' declareC: 'int ripply'> + <var: 'temp' declareC: 'double temp'> + <var: 'pix' declareC: 'unsigned int pix'> + <var: 'dist' declareC: 'double dist'> + <var: 'dx2' declareC: 'double dx2'> + <var: 'dy2' declareC: 'double dy2'> - 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 changed: ----- 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 | + <export: true> + <var: 'in' declareC: 'unsigned int *in'> + <var: 'out' declareC: 'unsigned int *out'> + <var: 'scaleX' declareC: 'double scaleX'> + <var: 'scaleY' declareC: 'double scaleY'> + <var: 'whirlRadians' declareC: 'double whirlRadians'> + <var: 'radiusSquared' declareC: 'double radiusSquared'> + <var: 'dx' declareC: 'double dx'> + <var: 'dy' declareC: 'double dy'> + <var: 'd' declareC: 'double d'> + <var: 'factor' declareC: 'double factor'> + <var: 'ang' declareC: 'double ang'> + <var: 'sina' declareC: 'double sina'> + <var: 'cosa' declareC: 'double cosa'> - 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 changed: ----- Method: UnicodePlugin>>asCString: (in category 'utility') ----- asCString: stringOop "Return a C char * pointer into the given Squeak string object." "Warning: A Squeak string is not necessarily null-terminated." "Warning: the resulting pointer may become invalid after the next garbage collection and should only be using during the current primitive call." + <inline: false> + <returnTypeC: 'char *'> - 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 changed: ----- Method: UnicodePlugin>>cWordsPtr:minSize: (in category 'utility') ----- cWordsPtr: oop minSize: minSize "Return a C pointer to the first indexable field of oop, which must be a words object of at least the given size." "Warning: the resulting pointer may become invalid after the next garbage collection and should only be using during the current primitive call." + <inline: false> + <returnTypeC: 'void *'> - 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 changed: ----- Method: UnicodePlugin>>copyString:into:max: (in category 'utility') ----- copyString: stringOop into: stringPtr max: maxChars "Copy the Squeak string into a temporary buffer and add a terminating null byte. Fail if there is not sufficent space in the buffer." | srcPtr count | + <inline: false> + <var: 'stringPtr' declareC: 'char *stringPtr'> + <var: 'srcPtr' declareC: 'char *srcPtr'> - 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 changed: ----- Method: UnicodePlugin>>primitiveClipboardGet (in category 'primitives') ----- primitiveClipboardGet "Read the clipboard into the given UTF16 string.." | utf16Oop utf16 utf16Length count | + <export: true> + <var: 'utf16' declareC: 'unsigned short *utf16'> - 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 changed: ----- Method: UnicodePlugin>>primitiveClipboardPut (in category 'primitives') ----- primitiveClipboardPut "Set the clipboard to a UTF16 string.." | strOop count utf16 utf16Length | + <export: true> + <var: 'utf16' declareC: 'unsigned short *utf16'> - 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 changed: ----- Method: UnicodePlugin>>primitiveClipboardSize (in category 'primitives') ----- primitiveClipboardSize | count | + <export: true> - self export: true. count := self cCode: 'unicodeClipboardSize()'. interpreterProxy pop: 1 thenPush: (interpreterProxy integerObjectOf: count). ^ 0 ! Item was changed: ----- Method: UnicodePlugin>>primitiveDrawString (in category 'primitives') ----- primitiveDrawString | utf8Oop utf8 w h bitmapOop bitmapPtr utf8Length result | + <export: true> + <var: 'utf8' declareC: 'char *utf8'> + <var: 'bitmapPtr' declareC: 'void *bitmapPtr'> - 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 changed: ----- Method: UnicodePlugin>>primitiveGetFontList (in category 'primitives') ----- primitiveGetFontList | strOop str strLength count | + <export: true> + <var: 'str' declareC: 'char *str'> - 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 changed: ----- Method: UnicodePlugin>>primitiveGetXRanges (in category 'primitives') ----- primitiveGetXRanges | utf8Oop utf8 resultOop resultPtr utf8Length count resultLength | + <export: true> + <var: 'utf8' declareC: 'char *utf8'> + <var: 'resultPtr' declareC: 'int *resultPtr'> - 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 changed: ----- Method: UnicodePlugin>>primitiveMeasureString (in category 'primitives') ----- primitiveMeasureString | utf8Oop utf8 utf8Length w h result | + <export: true> + <var: 'utf8' declareC: 'char *utf8'> - 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 changed: ----- Method: UnicodePlugin>>primitiveSetColors (in category 'primitives') ----- primitiveSetColors | fgRed fgGreen fgBlue bgRed bgGreen bgBlue mapBGToTransparent | + <export: true> - 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 changed: ----- Method: UnicodePlugin>>primitiveSetFont (in category 'primitives') ----- primitiveSetFont | fontName fontSize boldFlag italicFlag antiAliasFlag | + <export: true> + <var: 'fontName' declareC: 'char fontName[200]'> - 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: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.12.12'! - ^'4.12.11'! Item was changed: ----- Method: WeDoPlugin>>primClosePort (in category 'translated prims') ----- primClosePort "Close the WeDo port." + <export: true> - self export: true. interpreterProxy success: (self cCode: 'WeDoClosePort()'). ^ 0 ! Item was changed: ----- Method: WeDoPlugin>>primOpenPort (in category 'translated prims') ----- primOpenPort "Open the WeDo port." + <export: true> - self export: true. interpreterProxy success: (self cCode: 'WeDoOpenPort()'). ^ 0 ! Item was changed: ----- Method: WeDoPlugin>>primRead (in category 'translated prims') ----- primRead "Read data from the WeDo port into the given buffer (a ByteArray or String). Answer the number of bytes read." | bufOop bufPtr bufSize byteCount | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 changed: ----- Method: WeDoPlugin>>primWrite (in category 'translated prims') ----- primWrite "Write data to the WeDo port from the given buffer (a ByteArray or String). Answer the number of bytes written." | bufOop bufPtr bufSize byteCount | + <export: true> + <var: 'bufPtr' declareC: 'char *bufPtr'> - 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 !

1 0

Incorrect return type of positive64BitIntegerFor in FilePlugin.c
by Nicolas Cellier 04 Jan '14

04 Jan '14

positive64BitIntegerFor return type is declared sqLong, but should be sqInt (it returns an oop).

2 4

Strange return type of longLongAt
by Nicolas Cellier 04 Jan '14

04 Jan '14

longLongAt return type is defined as sqInt in sqMemory.h (cog branch rev. 2837) Shouldn't it be sqLong?

2 1

VM Maker: VMMaker.oscog-eem.573.mcz
by commits＠source.squeak.org 04 Jan '14

04 Jan '14

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 + !

1 0

VM Maker: VMMaker.oscog-eem.571.mcz
by commits＠source.squeak.org 04 Jan '14

04 Jan '14

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.571.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.571 Author: eem Time: 3 January 2014, 6:17:54.152 pm UUID: be9dbbdd-7f8c-48f6-a820-a6b42ee3749b 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 information 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. 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 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: + ----- 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: 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 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 */ - '!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev January 2014