Hi,
Here are two new primitives made for
calling primitives. They are useful for
implementing mirrors, smalltalk debugger,
simulator, ...
I've implemented a small example to see
how you can use them.
Cheers,
Gwen
>From 7e5238291182fafcbf8aa11256b5c6ba2bd64c2a Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio <[email protected]>
Date: Thu, 19 Dec 2013 12:05:08 +0100
Subject: [PATCH] Add two primitives VMpr_Object_primitiveOn,
VMpr_Object_primitiveOn WithArguments for calling primitives.
---
ChangeLog | 5 +++
libgst/prims.def | 109 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 114 insertions(+)
diff --git a/ChangeLog b/ChangeLog
index d5395cc..947f32a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2013-12-19 Gwenael Casaccio <[email protected]>
+
+ * libgst/prims.def: Add VMpr_Object_primitiveOnWithArguments and
+ VMpr_Object_primitiveOn primitives.
+
2013-06-14 Jochen Schmitt <[email protected]>
* smalltalk-mode-init.el.in: Use inhibit-local-variables-regexps
diff --git a/libgst/prims.def b/libgst/prims.def
index 7e8eaaf..c75010a 100644
--- a/libgst/prims.def
+++ b/libgst/prims.def
@@ -6211,5 +6211,114 @@ primitive VMpr_Random_next [succeed]
PRIM_FAILED;
}
+/* Object primitive:on:ifFailed:
+ Object primitive:on:with:ifFailed:
+ Object primitive:on:with:withifFailed:
+ Object primitive:on:with:with:with:ifFailed: */
+primitive VMpr_Object_primitiveOn [succeed,fail]
+{
+ OOP oop1, receiver_oop, failed_oop;
+ OOP *oopVec;
+ int i, numPrimitive;
+ _gst_primitives_executed++;
+
+ if (numArgs < 3)
+ PRIM_FAILED;
+
+ oopVec = alloca (numArgs * sizeof (OOP));
+
+ failed_oop = POP_OOP ();
+
+ for (i = 0; i < numArgs - 3; i++)
+ oopVec[i] = POP_OOP ();
+
+ receiver_oop = POP_OOP ();
+
+ oop1 = POP_OOP ();
+ if (!IS_INT (oop1))
+ {
+ UNPOP (numArgs);
+ PRIM_FAILED;
+ }
+
+ numPrimitive = TO_INT (oop1);
+
+ PUSH_OOP (receiver_oop);
+
+ for (i = numArgs - 4; i >= 0; i--)
+ PUSH_OOP (oopVec[i]);
+
+ if COMMON (!execute_primitive_operation(numPrimitive, numArgs - 3))
+ PRIM_SUCCEEDED;
+
+ UNPOP (numArgs - 1);
+
+ PUSH_OOP (oop1);
+ PUSH_OOP (receiver_oop);
+
+ for (i = numArgs - 4; i >= 0; i--)
+ PUSH_OOP (oopVec[i]);
+
+ PUSH_OOP (failed_oop);
+
+ PRIM_FAILED;
+}
+
+/* Object primitive:on:withArguments:ifFailed: */
+primitive VMpr_Object_primitiveOnWithArguments [succeed,fail]
+{
+ OOP oop1;
+ OOP oop2;
+ OOP oop3;
+ OOP receiver_oop;
+ int numPrimitive;
+
+ _gst_primitives_executed++;
+
+ if (numArgs != 4)
+ PRIM_FAILED;
+
+ oop3 = POP_OOP ();
+ oop2 = POP_OOP ();
+ receiver_oop = POP_OOP ();
+ oop1 = POP_OOP ();
+
+ if (!IS_INT (oop1) || !IS_CLASS (oop2, _gst_array_class))
+ {
+ UNPOP (numArgs);
+ PRIM_FAILED;
+ }
+
+ numPrimitive = TO_INT (oop1);
+
+ {
+ OOP result_oop;
+ int i, args;
+ mst_Boolean succeed;
+
+ args = NUM_INDEXABLE_FIELDS (oop2);
+
+ PUSH_OOP (receiver_oop);
+
+ for (i = 1; i <= args; i++)
+ PUSH_OOP (ARRAY_AT (oop2, i));
+
+ if COMMON (!execute_primitive_operation(numPrimitive, args))
+ PRIM_SUCCEEDED;
+
+ for (i = 1; i <= args; i++)
+ POP_OOP ();
+
+ POP_OOP ();
+ }
+
+ PUSH_OOP (oop1);
+ PUSH_OOP (receiver_oop);
+ PUSH_OOP (oop2);
+ PUSH_OOP (oop3);
+
+ PRIM_FAILED;
+}
+
#undef INT_BIN_OP
#undef BOOL_BIN_OP
--
1.8.3.2
Object subclass: Primitive [
primitive: aPrimitive on: anObject ifFailed: aBlock [
<primitive: VMpr_Object_primitiveOn>
^ aPrimitive isSmallInteger
ifFalse: [ SystemExceptions.WrongClass signalOn: aPrimitive mustBe:
SmallInteger ]
ifTrue: [ aBlock value: aPrimitive value: anObject ]
]
primitive: aPrimitive on: anObject with: aParameter1 ifFailed: aBlock [
<primitive: VMpr_Object_primitiveOn>
^ aPrimitive isSmallInteger
ifFalse: [ SystemExceptions.WrongClass signalOn: aPrimitive mustBe:
SmallInteger ]
ifTrue: [ aBlock value: aPrimitive value: anObject value:
aParameter1 ]
]
primitive: aPrimitive on: anObject with: aParameter1 with: aParameter2
ifFailed: aBlock [
<primitive: VMpr_Object_primitiveOn>
^ aPrimitive isSmallInteger
ifFalse: [ SystemExceptions.WrongClass signalOn: aPrimitive mustBe:
SmallInteger ]
ifTrue: [ aBlock valueWithArguments: {aPrimitive. anObject.
aParameter1. aParameter2} ]
]
primitive: aPrimitive on: anObject with: aParameter1 with: aParameter2
with: aParameter3 ifFailed: aBlock [
<primitive: VMpr_Object_primitiveOn>
^ aPrimitive isSmallInteger
ifFalse: [ SystemExceptions.WrongClass signalOn: aPrimitive mustBe:
SmallInteger ]
ifTrue: [ aBlock valueWithArguments: {aPrimitive. anObject.
aParameter1. aParameter2. aParameter3} ]
]
primitive: aPrimitive on: anObject with: aParameter1 with: aParameter2
with: aParameter3 with: aParameter4 ifFailed: aBlock [
<primitive: VMpr_Object_primitiveOn>
^ aPrimitive isSmallInteger
ifFalse: [ SystemExceptions.WrongClass signalOn: aPrimitive mustBe:
SmallInteger ]
ifTrue: [ aBlock valueWithArguments: {aPrimitive. anObject.
aParameter1. aParameter2. aParameter3. aParameter4} ]
]
primitive: aPrimitive on: anObject withArguments: anArray ifFailed: aBlock
[
<primitive: VMpr_Object_primitiveOnWithArguments>
aPrimitive isSmallInteger ifFalse: [ ^ SystemExceptions.WrongClass
signalOn: aPrimitive mustBe: SmallInteger ].
anArray isArray ifFalse: [ ^ SystemExceptions.WrongClass signalOn:
anArray mustBe: Array ].
^ aBlock value: aPrimitive value: anObject value: anArray
]
]
Eval [
| array |
[ (Primitive new primitive: $a on: 1 ifFailed: [ :aPrimitive :anObject |
]). 'KO' printNl. ] on: Error do: [ :err | 'OK' printNl ].
(Primitive new primitive: VMpr_Object_basicAt on: #(14 24 34) ifFailed: [
:aPrimitive :anObject | (aPrimitive == VMpr_Object_basicAt and: [ anObject =
#(14 24 34) ]) ifTrue: [ 'OK' printNl] ifFalse: [ 'KO' printNl ] ]).
(Primitive new primitive: VMpr_Object_class on: 1 ifFailed: [ :aPrimitive
:anObject |'KO' printNl. ]) == SmallInteger ifTrue: [ 'OK' printNl ] ifFalse: [
'KO' printNl ].
(Primitive new primitive: VMpr_Object_basicAt on: #(14 24 34) with: 1
ifFailed: [ :aPrimitive :anObject :arg1 | 'KO' printNl ]) == 14 ifTrue: [ 'OK'
printNl ] ifFalse: [ 'KO' printNl ].
(Primitive new primitive: VMpr_Object_basicAtPut on: #(14 24 34) with: 1
with: 'abc' ifFailed: [ :aPrimitive :anObject :arg1 :arg2 |
(aPrimitive == VMpr_Object_basicAtPut and: [ anObject = #(14 24 34)
and: [ arg1 == 1 and: [ arg2 = 'abc' ] ] ]) ifTrue: [ 'OK' printNl ] ifFalse:
[ 'KO' printNl ] ] ).
array := Array with: 14 with: 24 with: 34.
(Primitive new primitive: VMpr_Object_basicAtPut on: array with: 1 with:
'abc' ifFailed: [ :aPrimitive :anObject :arg1 :arg2 | ] ) = 'abc' ifTrue: [
'OK' printNl] ifFalse: [ 'KO' printNl ].
(array at: 1) = 'abc' ifFalse: [ 'KO' printNl ].
"b VMpr_Object_primitiveOn"
array := Array with: 14 with: 24 with: 34.
(Primitive new primitive: VMpr_Object_basicAt on: array withArguments: #(1)
ifFailed: [ :aPrimitive :anObject :anArray | ]) == 14 ifFalse: [ 'KO' printNl ]
ifTrue: [ 'OK' printNl ].
array := Array with: 14 with: 24 with: 34.
(Primitive new primitive: VMpr_Object_basicAtPut on: array withArguments:
#(1 2) ifFailed: [ :aPrimitive :anObject :anArray | ]).
(array at: 1) == 2 ifTrue: [ 'OK' printNl ] ifFalse: [ 'KO' printNl ].
array := Array with: 14 with: 24 with: 34.
(Primitive new primitive: VMpr_Object_basicAtPut on: #(14 24 34)
withArguments: #(1 2) ifFailed: [ :aPrimitive :anObject :anArray | 'OK' printNl
]).
"b VMpr_Object_primitiveOnWithArguments"
]
_______________________________________________
help-smalltalk mailing list
[email protected]
https://lists.gnu.org/mailman/listinfo/help-smalltalk
